Author: wmb
Date: 2008-12-24 01:49:38 +0100 (Wed, 24 Dec 2008)
New Revision: 1046
Added:
cpu/arm/build/builder.dic
Log:
ARM version - Added builder.dic to svn
Property changes on: cpu/arm/build/builder.dic
___________________________________________________________________
Added: svn:executable
+ *
Added: svn:mime-type
+ application/octet-stream
1
0
Author: wmb
Date: 2008-12-24 01:18:20 +0100 (Wed, 24 Dec 2008)
New Revision: 1045
Modified:
cpu/x86/pc/olpc/smbios.fth
Log:
smbios.fth - added a different model name string for qualification
testing against a BIOS-locked kernel.
Modified: cpu/x86/pc/olpc/smbios.fth
===================================================================
--- cpu/x86/pc/olpc/smbios.fth 2008-12-24 00:16:44 UTC (rev 1044)
+++ cpu/x86/pc/olpc/smbios.fth 2008-12-24 00:18:20 UTC (rev 1045)
@@ -309,6 +309,8 @@
( 02 ) h# 7f01 w, \ Handle
+: test-name$ ( -- $ ) " IE8y2D ScD%g4r2bAIFA." ;
+: test-version$ ( -- $ ) " OLPC Ver 1.00.01" ;
: fw-version$ ( -- $ )
" /openprom" find-package if
" model" rot get-package-property 0= if
@@ -378,8 +380,10 @@
'smbios h# 1f + ( adr )
bios-info copy-smbios-table ( adr )
- +OLPC
- fw-version$ +smbios$
+ test-name$ +smbios$
+ test-version$ +smbios$
+\ +OLPC
+\ fw-version$ +smbios$
fw-date$ +smbios$
end-smbios-table
1
0
Author: wmb
Date: 2008-12-24 01:16:44 +0100 (Wed, 24 Dec 2008)
New Revision: 1044
Modified:
cpu/x86/pc/olpc/nandcastui.fth
Log:
Added a licensing comment.
Modified: cpu/x86/pc/olpc/nandcastui.fth
===================================================================
--- cpu/x86/pc/olpc/nandcastui.fth 2008-12-24 00:15:58 UTC (rev 1043)
+++ cpu/x86/pc/olpc/nandcastui.fth 2008-12-24 00:16:44 UTC (rev 1044)
@@ -1,4 +1,5 @@
purpose: User interface for NAND multicast updater
+\ See license at end of file
: mesh-ssids ( -- $ )
" olpc-mesh"nolpc-mesh"nolpc-mesh"nolpc-mesh"nolpc-mesh"nolpc-mesh"
1
0
Author: wmb
Date: 2008-12-24 01:15:58 +0100 (Wed, 24 Dec 2008)
New Revision: 1043
Modified:
cpu/x86/call.fth
Log:
x86/call.fth - Increased the number of arguments passed to a
C routine, in case we need to change the API for crypto calls.
Modified: cpu/x86/call.fth
===================================================================
--- cpu/x86/call.fth 2008-12-24 00:14:56 UTC (rev 1042)
+++ cpu/x86/call.fth 2008-12-24 00:15:58 UTC (rev 1043)
@@ -1,7 +1,7 @@
\ See license at end of file
purpose: From Forth, call the C subroutine whose address is on the stack
-code sp-call ( [ arg7 .. arg0 ] adr sp -- [ arg5 .. arg0 ] result )
+code sp-call ( [ arg19 .. arg0 ] adr sp -- [ arg19 .. arg0 ] result )
bx pop \ Get the new stack pointer
ax pop \ Get the subroutine address
@@ -9,7 +9,21 @@
rp 'user saved-rp mov \ Save for callbacks
sp bx xchg \ Switch to new SP, with EBX set to old SP
- 7 /n* [ebx] push \ Copy the arguments to the new stack
+
+ \ Copy the arguments to the new stack
+ d# 19 /n* [ebx] push
+ d# 18 /n* [ebx] push
+ d# 17 /n* [ebx] push
+ d# 16 /n* [ebx] push
+ d# 15 /n* [ebx] push
+ d# 14 /n* [ebx] push
+ d# 13 /n* [ebx] push
+ d# 12 /n* [ebx] push
+ d# 11 /n* [ebx] push
+ d# 10 /n* [ebx] push
+ 9 /n* [ebx] push
+ 8 /n* [ebx] push
+ 7 /n* [ebx] push
6 /n* [ebx] push
5 /n* [ebx] push
4 /n* [ebx] push
1
0
Author: wmb
Date: 2008-12-24 01:14:56 +0100 (Wed, 24 Dec 2008)
New Revision: 1042
Modified:
cpu/x86/pc/biosload/HOWTO_QEMU.txt
Log:
Biosload version - Wordsmithing in HOWTO_QEMU.txt documentation.
Modified: cpu/x86/pc/biosload/HOWTO_QEMU.txt
===================================================================
--- cpu/x86/pc/biosload/HOWTO_QEMU.txt 2008-12-24 00:14:23 UTC (rev 1041)
+++ cpu/x86/pc/biosload/HOWTO_QEMU.txt 2008-12-24 00:14:56 UTC (rev 1042)
@@ -1,4 +1,4 @@
-== Booting OFW Under QEMU ==
+== Booting OFW Under QEMU or VirtualBox ==
You can boot OFW directly from the BIOS in QEMU; you don't need
Coreboot (formerly LinuxBIOS) or external bootloaders like GRUB
@@ -19,7 +19,7 @@
The "config-virtualbox.fth" configuration is known to work with QEMU.
Other configurations may work also - but the "qemu-loaded" config
-option isn't what you want for this technique, because itt is a subcase
+option isn't what you want for this technique, because it's a subcase
of the CoreBoot-payload configuration.
You will use the "floppyofw.img" output file in a later step.
@@ -62,7 +62,11 @@
The "makefloppy.fth" program that creates the image is pretty simple; it copies
bootsec.img to the output file "floppy.img", creates a couple of initially
empty FAT tables, zeros the root directory area, and fills the data area with
-zeros. Here's a pair of Linux commands that accomplish the same thing
+zeros.
+
+== Making a Prototype Floppy Image with Linux Commands ==
+
+Here's a pair of Linux commands that accomplish the same thing
as makefloppy.fth:
Step6a $ /sbin/mkdosfs -C -f 2 -F 12 -R 2 -r 224 -s 1 -S 512 floppy.img 1440
@@ -72,11 +76,10 @@
is specified in the BIOS parameter block in bootsec.img.
The advantage of makefloppy.fth is that it reads the filesystem layout parameters
-from the BPB in bootsec.img, so its guaranteed to be conistent. If bootsec.fth
+from the BPB in bootsec.img, so its guaranteed to be consistent. If bootsec.fth
were edited to change the layout, the arguments to "mkdosfs" would have to change.
(But there's little need to change that layout, since it's a standard floppy
size.)
The advantage of the Linux command sequence is that it creates a file with
-"holes", thus saving disk space for awhile (until something happens to fill
-in the holes).
+"holes", thus saving disk space for awhile (until something fills in the holes).
1
0
Author: wmb
Date: 2008-12-24 01:14:23 +0100 (Wed, 24 Dec 2008)
New Revision: 1041
Added:
forth/kernel/metanswapmap.fth
Modified:
cpu/arm/kernel.bth
cpu/ppc/kernel.bth
Log:
ARM and PowerPC versions - fixed some kernel compilation script problems.
Modified: cpu/arm/kernel.bth
===================================================================
--- cpu/arm/kernel.bth 2008-12-20 08:00:00 UTC (rev 1040)
+++ cpu/arm/kernel.bth 2008-12-24 00:14:23 UTC (rev 1041)
@@ -56,7 +56,7 @@
only forth also definitions
\needs bitset fload ${BP}/forth/lib/bitops.fth
-fload ${BP}/forth/kernel/nswapmap.fth \ Null swap map
+fload ${BP}/forth/kernel/metanswapmap.fth \ Null swap map
\ : : : lastacf .name cr ;
fload ${BP}/cpu/arm/target.fth
fload ${BP}/forth/kernel/forward.fth
Modified: cpu/ppc/kernel.bth
===================================================================
--- cpu/ppc/kernel.bth 2008-12-20 08:00:00 UTC (rev 1040)
+++ cpu/ppc/kernel.bth 2008-12-24 00:14:23 UTC (rev 1041)
@@ -45,6 +45,10 @@
fload ${BP}/cpu/ppc/metainit.fth
+" kernel.tag" r/w create-file drop meta-tag-file !
+
+always-headers
+
\ Comment out the following line(s) when debugging
-1 threshold ! \ Turn OFF ALL debugging messages
warning-t off \ Turn OFF target warning messages
@@ -78,6 +82,8 @@
fload ${BP}/forth/kernel/init.fth
fload ${BP}/cpu/ppc/finish.fth
+meta-tag-file @ fclose meta-tag-file off
+
fload ${BP}/cpu/ppc/savemeta.fth
.( --- Saving kernel.dic ---) " kernel.dic" $save-meta
Added: forth/kernel/metanswapmap.fth
===================================================================
--- forth/kernel/metanswapmap.fth (rev 0)
+++ forth/kernel/metanswapmap.fth 2008-12-24 00:14:23 UTC (rev 1041)
@@ -0,0 +1,4 @@
+\ Null byte swap table management for metacompiler
+
+: set-swap-bit-t ( addr -- ) drop ;
+: note-string-t ( adr len -- adr len ) ;
1
0
Author: wmb
Date: 2008-12-20 09:00:00 +0100 (Sat, 20 Dec 2008)
New Revision: 1040
Modified:
cpu/x86/disassem.fth
cpu/x86/pc/biosints.fth
dev/geode/smi.fth
Log:
BIOS emulation - fixed some problems with installation from USB and CD-ROM.
Modified: cpu/x86/disassem.fth
===================================================================
--- cpu/x86/disassem.fth 2008-12-20 07:55:35 UTC (rev 1039)
+++ cpu/x86/disassem.fth 2008-12-20 08:00:00 UTC (rev 1040)
@@ -160,8 +160,8 @@
then ( reg mod )
swap modes16 count $add-text ( mod )
case
- 1 of op8@ +disp16 endof
- 2 of op16@ +disp16 endof
+ 1 of op8@ bext +disp16 endof
+ 2 of op16@ wext +disp16 endof
endcase
;
: .ea ( -- )
Modified: cpu/x86/pc/biosints.fth
===================================================================
--- cpu/x86/pc/biosints.fth 2008-12-20 07:55:35 UTC (rev 1039)
+++ cpu/x86/pc/biosints.fth 2008-12-20 08:00:00 UTC (rev 1040)
@@ -1,7 +1,8 @@
+purpose: Emulate legacy PC BIOS real-mode INTs
+\ See license at end of file
-[ifdef] syslinux-loaded : disk-name ( -- $ ) " /pci/ide@0" ; [then]
-[ifdef] preof-loaded : disk-name ( -- $ ) " /pci/ide@0" ; [then]
-[ifdef] rom-loaded : disk-name ( -- $ ) " sd:0" ; [then]
+8 /l* buffer: init-regs
+h# 80 value bios-boot-dev#
struct
2 field >rm-gs
@@ -74,6 +75,8 @@
: rm-esi@ caller-regs >rm-esi l@ ;
: rm-esi! caller-regs >rm-esi l! ;
+: rm-si@ caller-regs >rm-esi w@ ;
+
: rm-retaddr@ caller-regs >rm-retaddr seg:off@ ;
: rm-flags@ caller-regs >rm-flags w@ ;
@@ -84,6 +87,7 @@
true value show-rm-int?
: noshow false to show-rm-int? ;
+: noshow! false to show-rm-int? ;
variable save-eax
: snap-int
true to show-rm-int? rm-eax@ save-eax !
@@ -399,18 +403,41 @@
h# 26 rm-eax! \ 32 bits
;
-0 value disk-ih
+0 value bios-ih
+0 value bios-cdrom-ih
+0 value bios-disk-ih
+
false value show-reads?
-1 value read-match
-: disk-read-sectors ( adr sector# #sectors -- #read )
+: drive-sectors ( -- n ) " #blocks" bios-ih $call-method ;
+: drive-/sector ( -- n ) " block-size" bios-ih $call-method ;
+[ifndef] notdef
+: (bios-read-sectors) ( adr sector# #sectors -- #sectors-read )
+ drive-/sector >r ( adr #sectors d.byte# r: /sector )
+ swap r@ um* ( adr #sectors d.byte# r: /sector )
+ " seek" bios-ih $call-method if ( adr #sectors r: /sector )
+ r> 3drop 0 exit
+ then ( adr #sectors r: /sector )
+ r@ * " read" bios-ih $call-method ( actual#bytes r: /sector )
+ r> / ( #sectors-read )
+;
+[else]
+: (bios-read-sectors) ( adr sector# #sectors -- #sectors-read )
+ " read-blocks" bios-ih $call-method
+;
+[then]
+
+: bios-read-sectors ( adr sector# #sectors -- #sectors-read )
noshow
over read-match = if ." Reading block " read-match . debug-me then
- show-reads? if ." Read " 2 pick . over . dup . ." -- " then
- " read-blocks" disk-ih $call-method
+ show-reads? if ." Read " 2 pick . over . dup . ." -- " then ( adr sec# #sec )
+
+ (bios-read-sectors) ( #sectors-read )
+\ " read-blocks" bios-ih $call-method
+
show-reads? if dup . cr then
-
;
0 value entry-count
@@ -420,43 +447,53 @@
then
;
-: disk-write-sectors ( adr sector# #sectors -- #read )
+: bios-write-sectors ( adr sector# #sectors -- #read )
\ ?hack
noshow
\ ." Write " 2 pick . over . dup . ." -- "
\ over h# 8b74aaa = if debug-me then
- " write-blocks" disk-ih $call-method
+ " write-blocks" bios-ih $call-method
\ dup . cr
;
+: select-bios-disk ( drive# -- )
+ h# 82 = if bios-cdrom-ih else bios-disk-ih then to bios-ih
+;
: check-drive ( -- error? )
- rm-dl@ h# 80 <> if rm-set-cf 7 rm-ah! true exit then
- disk-ih 0= dup if rm-set-cf h# aa rm-ah! then
+ show-reads? if ." Drive " rm-dl@ .x then
+ rm-dl@ h# 80 h# 81 between 0= if rm-set-cf 7 rm-ah! true exit then
+ bios-disk-ih to bios-ih
+ bios-ih 0= dup if rm-set-cf h# aa rm-ah! then
;
-: read-sectors ( -- )
+: lba-check-drive ( -- error? )
+ show-reads? if ." Drive " rm-dl@ .x then
+ rm-dl@ h# 80 h# 82 between 0= if rm-set-cf 7 rm-ah! true exit then
+ rm-dl@ select-bios-disk
+ bios-ih 0= dup if rm-set-cf h# aa rm-ah! then
+;
+: chs-read-sectors ( -- )
check-drive if exit then
- disk-ih 0= if rm-set-cf h# aa rm-ah! exit then
+ bios-ih 0= if rm-set-cf h# aa rm-ah! exit then
rm-ch@ rm-cl@ 6 rshift bwjoin ( cylinder# )
h# ff * rm-dh@ + ( trk# ) \ 255 heads
h# 3f * rm-cl@ h# 3f and 1- + ( sector# ) \ 63 is max sector#
rm-bx@ rm-es@ seg:off> ( sector# adr )
swap rm-al@ ( adr sector# #sectors )
- disk-read-sectors rm-al!
+ bios-read-sectors rm-al!
;
-: write-sectors ( -- )
+: chs-write-sectors ( -- )
check-drive if exit then
- disk-ih 0= if rm-set-cf h# aa rm-ah! exit then
+ bios-ih 0= if rm-set-cf h# aa rm-ah! exit then
rm-ch@ rm-cl@ 6 rshift bwjoin ( cylinder# )
h# ff * rm-dh@ + ( trk# ) \ 255 heads
h# 3f * rm-cl@ h# 3f and 1- + ( sector# ) \ 63 is max sector#
rm-bx@ rm-es@ seg:off> ( sector# adr )
swap rm-al@ ( adr sector# #sectors )
- disk-write-sectors rm-al!
+ bios-write-sectors rm-al!
;
-: drive-sectors ( -- n ) " #blocks" disk-ih $call-method ;
: drive-params ( -- )
noshow
check-drive if exit then
@@ -472,37 +509,45 @@
rm-clr-cf
;
-: ds:si ( -- adr ) rm-esi@ rm-ds@ seg:off> ;
+: ds:si ( -- adr ) rm-si@ rm-ds@ seg:off> ;
: lba-read ( -- )
- check-drive if exit then
+ lba-check-drive if exit then
ds:si ( packet-adr )
>r r@ 4 + seg:off@ r@ 8 + l@ r@ 2+ w@ ( adr sector# #sectors )
\ ." LBA "
- disk-read-sectors r> 2+ w!
+ bios-read-sectors r> 2+ w!
;
: lba-write ( -- )
- check-drive if exit then
+ lba-check-drive if exit then
ds:si ( packet-adr )
>r r@ 4 + seg:off@ r@ 8 + l@ r@ 2+ w@ ( adr sector# #sectors )
\ ." LBA "
- disk-write-sectors r> 2+ w!
+ bios-write-sectors r> 2+ w!
;
: check-disk-extensions ( -- )
noshow
- check-drive if 0 rm-bx! exit then
+ lba-check-drive if 0 rm-bx! exit then
rm-bx@ h# 55aa <> if exit then
h# aa55 rm-bx!
h# 20 rm-ah! 1 rm-cx!
;
: ext-get-drive-params ( -- )
noshow
- check-drive if exit then
+ lba-check-drive if exit then
0 rm-ah!
ds:si >r ( adr )
r@ 2 + h# 0e erase \ CHS info not valid
+
+ \ h# 70 is ATAPI, removable, LBA
+ \ h# 10 is LBA
+\ rm-dl@ h# 81 = if h# 70 else h# 10 then r@ h# a + w!
+\ XXX this might be a problem
+ rm-dl@ h# 82 = if ( 4 ) h# 34 else 0 then r@ 2 + w!
+
drive-sectors r@ h# 10 + l! 0 r@ h# 14 + l! \ Total #sectors
- h# 200 r@ h# 18 + w! \ Sector len
+
+ drive-/sector r@ h# 18 + w! \ Sector len
h# 1a ( written-length )
r@ w@ h# 1e >= if
-1 r@ h# 1a + l! \ No EDD
@@ -525,26 +570,56 @@
;
: reset-disks ( -- ) noshow ;
+\ c.f. El Torito CD booting spec
+\ We construct a valid status packet, even though NT doesn't look at its
+\ contents. It only looks at the return value in AX. Most of the fields
+\ herein are irrelevant for the "get status" function anyway.
+create cd-stat
+\ len type drive# ctlr# LBA devspec(master/slave, SCSI LUN, etc)
+ h# 13 c, 0 c, h# 82 c, 0 c, 0 l, 0 w,
+\ userbuf loadseg #sectors #cyls sec,cyl #heads
+ 0 w, 0 w, 0 w, 0 c, 0 c, 0 c,
+
+: cdrom-status ( -- )
+ \ We don't distinguish between AL=00 and AL=01; both return the same
+ \ status. AL=00 also terminates hard disk emulation, but we don't
+ \ do emulation, so that is effectively a no-op. The NT SETUPLDR
+ \ only uses AL=01 anyway.
+ \ DL should be the drive number (82); we don't check that
+ cd-stat ds:si h# 13 move
+ \ This is the return code. The El Torito spec doesn't say what
+ \ the return codes are supposed to be. NT SETUPLDR fails if anything
+ \ other than 0 is returned.
+ 0 rm-ax!
+ rm-set-cf \ CF set means that the system is not in emulation mode
+;
+
: disk-int ( -- ) \ INT 13 handler
rm-ah@ case
h# 00 of reset-disks endof \ Reset disk system
- h# 02 of read-sectors endof
- h# 03 of write-sectors endof
+ h# 02 of chs-read-sectors endof
+ h# 03 of chs-write-sectors endof
h# 08 of drive-params endof
h# 15 of get-disk-type endof
h# 41 of check-disk-extensions endof
h# 42 of lba-read endof
h# 43 of lba-write endof
h# 48 of ext-get-drive-params endof
+ h# 4b of cdrom-status endof
( default ) ." Unsupported disk INT 13 - AH = " dup . cr
endcase
;
+false value debug-mem?
+
: /1k d# 10 rshift ;
: bigmem-16bit ( -- )
memory-limit
dup h# 100.0000 min h# 10.0000 - 0 max /1k dup rm-ax! rm-cx!
h# 100.0000 - 0 max d# 16 rshift dup rm-bx! rm-dx!
+ debug-mem? if
+ ." Bigmem 16: " rm-ax@ . rm-cx@ . rm-bx@ . rm-dx@ . cr
+ then
;
: allmem ( -- n )
" /memory" find-package 0= abort" No /memory node" ( phandle )
@@ -571,7 +646,8 @@
h# 9fc00 0 d, h# a0000 h# 9fc00 - 0 d, 2 l, \ 28 reserved
\ End test
- h# e0000. d, h# 20000. d, 2 l, \ 3c reserved
+\ h# e0000. d, h# 20000. d, 2 l, \ 3c reserved
+ h# e8000. d, h# 08000. d, 2 l, \ 3c reserved
h# 100000. d, 0. d, 1 l, \ 50 available
\ 0. d, 0. d, 4 l, \ 64 don't reclaim (yet)
0. d, 0. d, 2 l, \ 64 reserved fw memory
@@ -597,6 +673,9 @@
\ Otherwise copy out the next table entry, return length in ECX and next address in EBX
dup rm-edi@ h# ffff and rm-es@ seg:off> ( adr dst )
rm-ecx@ move ( adr )
+ debug-mem? if
+ ." E820 Mem: " dup rm-ecx@ ldump cr
+ then
rm-ecx@ + rm-ebx! ( ) \ Continuation
;
@@ -688,8 +767,12 @@
noop
h# 53 of apm endof
h# 86 of rm-dx@ rm-cx@ wljoin us endof \ Delay microseconds
- h# 8a of memory-limit h# 400.0000 - 0 max /1k lwsplit rm-dx! rm-ax! endof
- h# 88 of h# fffc rm-ax! endof \ Extended memory - at least 64 MB
+ h# 8a of memory-limit h# 400.0000 - 0 max /1k lwsplit rm-dx! rm-ax!
+ debug-mem? if ." Mem 15/8a: " rm-dx@ . rm-ax@ . cr then
+ endof
+ h# 88 of h# fffc rm-ax!
+ debug-mem? if ." Mem 15/88: " rm-ax@ . cr then
+ endof \ Extended memory - at least 64 MB
h# c0 of get-conf endof
\ We use the extended BIOS data area as our workspace when loaded from another BIOS
\ h# c1 of rm-set-cf h# 86 rm-ah! endof \ No extended BIOS data area
@@ -727,7 +810,7 @@
0 value polled?
: poll-keystroke ( -- )
noshow
- polled? 0= if ." ? " then
+\ polled? 0= if ." ? " then
true to polled?
poll-key if ( scancode,ascii )
rm-ax!
@@ -743,15 +826,16 @@
0 to the-key
rm-ax!
- rm-al@ [char] q = if debug-me then
+\ rm-al@ [char] d = if debug-me then
false to polled?
;
: keyboard-int ( -- ) \ INT 16 handler
+ noshow!
rm-ah@ case
0 of get-keystroke endof
1 of poll-keystroke endof
- 2 of noshow 0 rm-al! endof \ Claim that no shift keys are active
+ 2 of 0 rm-al! endof \ Claim that no shift keys are active
5 of rm-cx@ to the-key endof \ Put keystroke in buffer
( bit 7:sysrq 6:capslock 5:numlock 4:scrlock 3:ralt 2:rctrl 1:lalt 0:lctrl )
( default ) ." Keyboard INT called with AH = " dup . cr
@@ -830,12 +914,14 @@
h# 13 of disk-int endof
h# 16 of keyboard-int endof
h# 15 of system-int endof
- h# 12 of 'ebda /1k rm-ax! endof \ Low memory size
+ h# 12 of 'ebda /1k rm-ax!
+ debug-mem? if ." Lowmem: " rm-ax@ . cr then
+ endof \ Low memory size
h# 1a of int-1a endof
h# 18 of ." Entering Open Firmware" cr interact endof
h# 19 of ." Rebooting" cr bye endof
h# 17 of printer-int endof
- h# 1c of noshow 0 dispatch-interrupt endof \ Timer bounce vector
+ h# 1c of noshow! 0 dispatch-interrupt endof \ Timer bounce vector
( default ) ." Interrupt " dup . cr interact
endcase
?showint
@@ -844,10 +930,13 @@
h# 7c00 constant mbr-base
: get-mbr ( -- )
-\ mbr-base h# 3f 1 disk-read-sectors 1 <> abort" Didn't read MBR"
- mbr-base 0 1 disk-read-sectors 1 <> abort" Didn't read MBR"
+\ mbr-base h# 3f 1 bios-read-sectors 1 <> abort" Didn't read MBR"
+ mbr-base 0 1 bios-read-sectors 1 <> abort" Didn't read MBR"
;
+\ : #hard-drives ( -- n ) bios-boot-dev# h# 82 = if 2 else 1 then ;
+: #hard-drives ( -- n ) 1 ;
+
: make-bda ( -- )
h# 400 h# 200 erase
'ebda h# 400 erase
@@ -863,6 +952,7 @@
\ 46c.l is tick count, 470.b is midnight flag
\ 4701.b bit 0x80 is ctrl-break flag
h# 1234 h# 472 w! \ Skip memory test
+ #hard-drives h# 475 c! \ Number of hard drives
d# 25 1- h# 484 c! \ Screen max row #
d# 16 h# 485 w! \ Character height
h# 100.0000 h# 487 l! \ Video RAM size
@@ -870,7 +960,7 @@
1 'ebda w! \ Size of EBDA in KiB
\ 'ebda h# 3d + .. HD0 parameter table
\ 'ebda h# 4d + .. HD1 parameter table
- 1 'ebda h# 70 + c! \ Number of hard disks
+ #hard-drives 'ebda h# 70 + c! \ Number of hard disks
;
label bounce-timer \ Redirect the timer interrupt through INT 1c
@@ -894,11 +984,6 @@
0 h# 82 w! h# c0 h# 80 w! \ CS = 0, IP = h# c0 = INT 30
;
-: open-bios-disk ( -- )
- disk-ih if exit then
- disk-name open-dev to disk-ih
-;
-
0 value rm-prepped?
: prep-rm ( -- )
rm-prepped? if exit then true to rm-prepped?
@@ -915,25 +1000,33 @@
populate-memory-map
rm-platform-fixup
;
-: close-bios-disk ( -- ) disk-ih ?dup if close-dev 0 to disk-ih then ;
-' close-bios-disk to quiesce-devices
+: close-bios-disk ( -- ) bios-disk-ih ?dup if close-dev 0 to bios-disk-ih then ;
+: close-bios-cdrom ( -- ) bios-cdrom-ih ?dup if close-dev 0 to bios-cdrom-ih then ;
+: close-bios-devices ( -- ) close-bios-disk close-bios-cdrom ;
+' close-bios-devices to quiesce-devices
+[ifdef] notdef \ Doesn't work with CD-ROM
: rm-go ( -- )
prep-rm
open-bios-disk
get-mbr \ Load boot image at 7c00
- usb-quiet
- mbr-base rm-run
+\ usb-quiet
+ init-regs mbr-base rm-run
;
+[then]
+0 value mbr-boot?
: is-mbr? ( adr len -- flag )
- h# 200 <> if drop false exit then
- h# 1fe + w@ h# aa55 =
+ mbr-boot? 0= if 2drop false exit then
+ + 2 - le-w@ h# aa55 =
;
: init-program ( -- )
loaded is-mbr? if
prep-rm
- load-base mbr-base h# 200 move
+ loaded mbr-base swap move
+\ init-regs /sregs+gregs erase
+ \ XXX
+ bios-boot-dev# init-regs >rm-edx c! \ DL
exit
then
init-program
@@ -943,33 +1036,111 @@
: execute-buffer ( adr len -- )
rm-prepped? if ( adr len )
2drop ( )
- usb-quiet ( )
- mbr-base rm-run ( )
+\ usb-quiet ( )
+ init-regs mbr-base rm-run ( )
exit \ Precautionary; rm-run shouldn't return
then
execute-buffer
;
+0 value boot-sector#
+1 value boot-#sectors
+: get-cdrom-sector ( sector# -- error? )
+ load-base swap 1 (bios-read-sectors) 1 <>
+;
+: close-bios-ih ( -- ) bios-ih ?dup if close-dev 0 to bios-ih then ;
+: bootable-cdrom? ( -- flag )
+ drive-/sector h# 800 <> if false exit then
+
+ \ Check Boot Record
+ h# 11 get-cdrom-sector if false exit then
+ load-base " "(00)CD001"(01)EL TORITO SPECIFICATION" comp if false exit then
+
+ \ Check Boot Catalog and Section Entry
+ load-base h# 47 + le-l@ get-cdrom-sector if false exit then
+ load-base le-l@ 1 <> if false exit then
+ 0 load-base h# 20 bounds do i le-w@ + /w +loop
+ h# ffff and if false exit then
+ load-base 1+ c@ if false exit then \ Must be for x86 platform
+
+ \ Record pointer to boot code
+ load-base h# 20 + c@ h# 88 <> if false exit then \ Must be bootable
+ load-base h# 28 + le-l@ to boot-sector#
+ load-base h# 26 + le-w@ 4 / 1 max to boot-#sectors
+
+ true
+;
+: set-hd-boot ( dev$ -- )
+ open-dev to bios-disk-ih
+ 0 to boot-sector# 1 to boot-#sectors
+ h# 80 to bios-boot-dev#
+ bios-disk-ih to bios-ih
+;
+: get-one-sector ( dev$ -- error? )
+ open-dev to bios-ih
+ load-base 0 1 (bios-read-sectors) ( #read )
+ close-bios-ih ( #read )
+ 1 <> ( error? )
+;
+: mbr-bootable? ( dev$ -- flag )
+ get-one-sector if false exit then
+ load-base h# 1be + c@ h# 80 =
+;
+
+: ntfs? ( dev$ -- flag )
+ get-one-sector if false exit then
+ load-base 3 + " NTFS " comp 0= ( flag )
+;
+
+: mbr-load ( adr -- #bytes )
+ bios-boot-dev# select-bios-disk
+ boot-sector# boot-#sectors bios-read-sectors
+ bios-boot-dev# h# 82 = if h# 800 else h# 200 then *
+ true to mbr-boot?
+;
+
0 0 " " " /" begin-package
" xp" device-name
: open
- " sd:1" open-dev ?dup 0= if false exit then ( ih )
- >r
- load-base h# 200 " read" r@ $call-method ( #read )
- r> close-dev
- h# 200 <> if false exit then
- load-base 3 + " NTFS " comp if false exit then
- true
+ " sd:1" ntfs? if " sd:0" set-hd-boot true exit then
+ false
;
: close ;
- \ Possible change: load at adr, then have init-program do all
- \ the other fixups (prep-rm) and move the MBR to mbr-base
- : load ( adr -- 0 )
- open-bios-disk
- 0 1 disk-read-sectors h# 200 *
- ;
+ : load ( adr -- nbytes ) mbr-load ;
end-package
+0 0 " " " /" begin-package
+ " xpinstall" device-name
+ : open
+ " /usb/disk:0" open-dev ?dup if ( ih )
+ to bios-ih
+ bootable-cdrom? if
+ bios-ih to bios-cdrom-ih
+ " sd:0" open-dev ?dup if
+ to bios-disk-ih
+ else
+ ." Can't open SD device. Install from CD-ROM probably won't work." cr
+ then
+ h# 82 to bios-boot-dev#
+ true exit
+ then
+ close-bios-ih
+ then
+
+ \ The device was not a bootable CDROM, but it might be a USB memory stick
+
+ " /usb/disk:0" mbr-bootable? if " /usb/disk:0" set-hd-boot true exit then
+
+ " sd:0" mbr-bootable? if " sd:0" set-hd-boot true exit then
+
+ false
+ ;
+ : close ;
+ : load ( adr -- nbytes ) mbr-load ;
+end-package
+
+: install-xp ( -- ) " /xpinstall" $boot ;
+
label xx h# 99 # al mov al h# 80 # out begin again end-code
here xx - constant /xx
: put-xx ( adr -- ) xx swap /xx move ;
@@ -1073,3 +1244,27 @@
c;
[then]
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2008 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Modified: dev/geode/smi.fth
===================================================================
--- dev/geode/smi.fth 2008-12-20 07:55:35 UTC (rev 1039)
+++ dev/geode/smi.fth 2008-12-20 08:00:00 UTC (rev 1040)
@@ -644,6 +644,8 @@
smm-io-port h# fff0 and h# 30 = if
smm-io-port h# 20 - to rm-int@
rm-sp la1+ >caller-physical w@ smm-rmeflags w!
+ \ Bias by -2 to point to INT instruction
+ rm-sp >caller-physical l@ 2- smm-retaddr l!
handle-bios-call
smm-rmeflags w@ rm-sp la1+ >caller-physical w!
exit
@@ -671,8 +673,10 @@
\ require jumping to a given address in real mode.
-1 value rm-entry-adr
-: rm-run ( eip -- ) to rm-entry-adr smi ;
+0 value rm-regs
+: rm-run ( 'gregs eip -- ) to rm-entry-adr to rm-regs smi ;
+
: smm-stack-w! ( w offset -- ) smm-sp +smm + w! ;
: smm-stack-l! ( l offset -- ) smm-sp +smm + l! ;
\ : smi-to-forth ( ip -- )
@@ -943,7 +947,7 @@
: smm-trace ( -- )
." EBP RETADR CALLTO" cr
- smm-ebp
+ smm-ebp l@
begin ?dup while ( ebp )
dup 8 u.r smm>physical ( padr )
dup la1+ l@ dup 9 u.r .callto cr ( padr )
@@ -997,25 +1001,29 @@
\ to the address "eip" in real mode. This is an implementation
\ factor of the "rm-run" mechanism.
-: rm-setup ( eip -- )
- >seg:off 2>r ( r: off seg )
+4 /w* 8 /l* + constant /sregs+gregs
- smm-header h# 30 -
- h# 38 l!++ \ SMM_CTL
- 0 l!++ \ I/O DATA
- 0 l!++ \ I/O ADDRESS, I/O SIZE
- h# 938009 l!++ \ SS_FLAGS, SMM Flags
- h# ffff l!++ \ CS_LIMIT
- r@ 4 lshift l!++ \ CS_BASE
- r> h# 9a wljoin l!++ \ CS_FLAGS.CS_INDEX
- r> l!++ \ NEXT_IP
- 0 l!++ \ CURRENT_IP
- h# 10 l!++ \ CR0
- h# 2 l!++ \ EFLAGS
- h# 400 l!++ \ DR7
+: rm-setup ( -- )
+ rm-entry-adr >seg:off 2>r ( off seg )
+
+ smm-header h# 30 - ( adr )
+ h# 38 l!++ ( adr' ) \ SMM_CTL
+ 0 l!++ ( adr' ) \ I/O DATA
+ 0 l!++ ( adr' ) \ I/O ADDRESS, I/O SIZE
+ h# 938009 l!++ ( adr' ) \ SS_FLAGS, SMM Flags
+ h# ffff l!++ ( adr' ) \ CS_LIMIT
+ r@ 4 lshift l!++ ( adr' ) \ CS_BASE
+
+ r> h# 9a wljoin l!++ ( adr' ) \ CS_FLAGS.CS_INDEX
+ r> l!++ ( adr' ) \ NEXT_IP
+ 0 l!++ ( adr' ) \ CURRENT_IP
+ h# 10 l!++ ( adr' ) \ CR0
+ h# 2 l!++ ( adr' ) \ EFLAGS
+ h# 400 l!++ ( adr' ) \ DR7
drop
- smm-sregs 4 /w* erase smm-gregs 8 /l* erase
+ rm-regs caller-regs /sregs+gregs move
+
0 smm-save-esp +smm l!
smm-save-seg +smm
@@ -1040,11 +1048,12 @@
: soft-smi ( -- )
smi-debug? if ." SOFT" cr then
rm-entry-adr -1 <> if
- rm-entry-adr rm-setup
+ rm-setup
-1 to rm-entry-adr
exit
then
+ smm-pc smm-retaddr l! \ So .caller-regs will work
sbpadr @ if
sbpadr @ smm>physical smm-pc smm>physical <> if
." Not at SMI breakpoint!" cr
1
0
Author: wmb
Date: 2008-12-20 08:55:35 +0100 (Sat, 20 Dec 2008)
New Revision: 1039
Added:
cpu/arm/
cpu/arm/Linux/
cpu/arm/Linux/Makefile
cpu/arm/asmtools.fth
cpu/arm/assem.fth
cpu/arm/basefw.bth
cpu/arm/bitops.fth
cpu/arm/boot.fth
cpu/arm/build/
cpu/arm/build/Makefile
cpu/arm/builder.bth
cpu/arm/call.fth
cpu/arm/centry.fth
cpu/arm/code.fth
cpu/arm/cpubpsup.fth
cpu/arm/cpustate.fth
cpu/arm/ctrace.fth
cpu/arm/debugm.fth
cpu/arm/decompm.fth
cpu/arm/disassem.fth
cpu/arm/dodoesad.fth
cpu/arm/extra.fth
cpu/arm/fb8-ops.fth
cpu/arm/field.fth
cpu/arm/filecode.fth
cpu/arm/finish.fth
cpu/arm/float.fth
cpu/arm/forthint.fth
cpu/arm/ftrace.fth
cpu/arm/getms.fth
cpu/arm/inflate
cpu/arm/inflater.fth
cpu/arm/initpgm.fth
cpu/arm/kerncode.fth
cpu/arm/kernel.bth
cpu/arm/kernfloat.fth
cpu/arm/kernrel.fth
cpu/arm/loadmach.fth
cpu/arm/loadvmem.fth
cpu/arm/memtest.fth
cpu/arm/metainit.fth
cpu/arm/metarel.fth
cpu/arm/minifth.fth
cpu/arm/mmu.fth
cpu/arm/muldiv.fth
cpu/arm/native.bth
cpu/arm/objcode.fth
cpu/arm/objsup.fth
cpu/arm/psr.fth
cpu/arm/regacc.fth
cpu/arm/register.fth
cpu/arm/savefort.fth
cpu/arm/savemeta.fth
cpu/arm/scc.fth
cpu/arm/sqroot.fth
cpu/arm/sync.fth
cpu/arm/sys.fth
cpu/arm/target.fth
cpu/arm/testasm.txt
cpu/arm/testmmu.fth
cpu/arm/tools.bth
cpu/arm/traps.fth
cpu/arm/version.fth
Log:
ARM - initial checking of core OFW code for ARM
Added: cpu/arm/Linux/Makefile
===================================================================
--- cpu/arm/Linux/Makefile (rev 0)
+++ cpu/arm/Linux/Makefile 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,36 @@
+# Wrapper makefile for ARM Linux
+# Copyright 2008 FirmWorks. All rights reserved.
+#
+BP=../../..
+
+CFLAGS = -DARM -mlittle-endian
+
+WRTAIL = forth/wrapper
+WRDIR = ${BP}/${WRTAIL}
+ZIPTAIL = ${WRTAIL}/zip
+ZIPDIR = ${BP}/${ZIPTAIL}
+
+ZIPOBJS = zipmem.o deflate.o trees.o bits.o util.o inflate.o
+
+OBJS = wrapper.o logger.o ${ZIPOBJS}
+
+all: forth
+
+# Use forth when you just need to run Forth but don't care what
+# native instruction set it is on.
+# Use x86forth when you need to compile new dictionaries that will
+# run on x86 systems.
+forth: armforth
+ @ln -sf armforth forth
+
+armforth: ${OBJS}
+ ${CC} ${CFLAGS} ${LFLAGS} -o $@ ${OBJS}
+
+%.o: ${WRDIR}/%.c
+ ${CC} -c ${CFLAGS} $< -o $@
+
+%.o: ${ZIPDIR}/%.c
+ ${CC} -c ${CFLAGS} -I${ZIPDIR} $< -o $@
+
+clean:
+ @rm -f ${OBJS} forth armforth
Property changes on: cpu/arm/Linux/Makefile
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/asmtools.fth
===================================================================
--- cpu/arm/asmtools.fth (rev 0)
+++ cpu/arm/asmtools.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,114 @@
+purpose: Tools for creating disembodied assembly code sequences
+\ See license at end of file
+
+[ifndef] set-transize
+fload ${BP}/forth/lib/transien.fth
+true is suppress-transient? \ Disable transient definitions for now
+[then]
+
+\needs suppress-headerless? fload ${BP}/forth/lib/headless.fth
+
+[ifndef] arm-assembler
+fload ${BP}/cpu/arm/assem.fth
+fload ${BP}/cpu/arm/code.fth
+fload ${BP}/forth/lib/loclabel.fth
+[then]
+
+also forth definitions
+: c$, ( adr len -- )
+ 1+ here swap note-string dup allot move 4 (align)
+;
+previous definitions
+
+[ifdef] notyet
+also arm-assembler definitions
+\needs $-to-r3 fload ${BP}/cpu/powerpc/asmmacro.fth
+
+: $find-dropin, ( adr len -- )
+ $-to-r3 \ Assemble string and skip it
+ " find-dropin bl *" evaluate \ and call find routine
+;
+previous definitions
+[then]
+
+false value transient-labels?
+0 value asm-origin
+0 value asm-base
+: pad-to ( n -- )
+ begin dup here asm-base - asm-origin + u> while 0 c, repeat drop
+;
+: align-to ( boundary -- )
+ here asm-base - swap round-up pad-to
+;
+
+[ifndef] enable-transient?
+: enable-transient ( -- )
+ suppress-transient? if
+ unused 4 / d# 1000 set-transize
+ false is suppress-transient?
+ false is suppress-headerless?
+ then
+;
+[then]
+enable-transient
+
+: tconstant ( value "name" -- )
+ transient? 0= dup >r if transient then
+ constant
+ r> if resident then
+;
+: label ( "name" -- )
+ transient-labels? if
+ here tconstant
+ [ also assembler ] init-labels [ previous ] !csp entercode
+ else
+ label
+ then
+;
+
+: set-asm-origin ( -- )
+ here to asm-base
+ 0 to asm-origin
+;
+
+0 0 2value old-asms
+: start-assembling ( -- )
+ \ Use "is" instead of "to" in the next line because "to" is a PowerPC
+ \ assembly mnemonic (trap on overflow).
+ [ also assembler also helpers ]
+ ['] asm@ behavior ['] asm! behavior to old-asms
+ ['] le-l@ is asm@ ['] le-l! is asm!
+ [ previous previous ]
+ set-asm-origin
+ true to transient-labels?
+;
+: end-assembling ( -- )
+ [ also assembler also helpers ]
+ old-asms is asm! is asm@
+ [ previous previous ]
+ false to transient-labels?
+;
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1995 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/asmtools.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/assem.fth
===================================================================
--- cpu/arm/assem.fth (rev 0)
+++ cpu/arm/assem.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,1085 @@
+purpose: Prefix assembler for ARM Instruction Set
+\ See license at end of file
+
+\ create testing
+
+[ifndef] skipwhite
+: skipwhite ( adr1 len1 -- adr2 len2 )
+ begin dup 0> while ( adr len )
+ over c@ bl > if exit then
+ 1 /string
+ repeat ( adr' 0 )
+;
+[then]
+\needs land : land and ;
+
+\needs cindex fload ${BP}/forth/lib/parses1.fth
+\needs lex fload ${BP}/forth/lib/lex.fth
+\needs 2nip : 2nip ( n1 n2 n3 n4 -- n3 n4 ) 2swap 2drop ;
+vocabulary arm-assembler also arm-assembler definitions
+
+\ Define symbolic names for constants in this vocabulary
+\ vocabulary register-names
+\ vocabulary constant-names
+vocabulary helpers
+
+also helpers definitions
+
+headerless
+hex
+
+[ifdef] testing
+0 value aoffset
+[then]
+
+0 value newword
+
+defer here \ ( -- adr ) actual dictionary pointer, metacomp. calculates host/target adresses
+defer asm-allot \ ( n -- ) allocate memory in the code address space
+
+\ defer byte! \ ( c adr -- ) write char to adr, metacompiler changes this
+defer asm! \ ( n adr -- ) write n to adr "
+defer asm@ \ ( adr -- n ) read n at adr "
+
+defer asm-set-relocation-bit
+
+also arm-assembler definitions
+: asm, ( n -- ) here /l asm-allot asm! ;
+previous definitions
+
+: !op ( -- ) newword asm, ;
+
+0 value op-end
+
+0 value last-len
+
+0 value rem-adr
+0 value rem-len
+: set-rem$ ( adr len -- ) is rem-len is rem-adr ;
+: rem$ ( -- adr len ) rem-adr rem-len ;
+
+d# 128 buffer: cbuf
+0 value clen
+
+: field-bounds ( -- end start )
+ op-end dup rem-len - swap last-len -
+;
+
+0 value adr-delim
+
+: xop ( change-bits -- ) newword xor is newword ;
+: iop ( on-bits -- ) newword or is newword ;
+
+: ad-error ( msg$ -- )
+ \ Types the message passed in, the contents of cbuf and the stack.
+ type cr
+ where #out @ >r
+ source type cr
+ field-bounds dup r> + spaces ( end start ) ?do ." ^" loop cr
+ abort
+;
+
+\ : $asm-find ( word$ -- word$ false | xt true ) ['] register-names $vfind ;
+: $asm-find ( word$ -- word$ false | xt true ) ['] arm-assembler $vfind ;
+
+: $asm-execute ( name$ -- ?? )
+ $asm-find 0= if " Unknown symbol" ad-error then execute
+;
+
+: set-parse ( adr len -- )
+ cbuf over set-rem$ cbuf swap move rem-len is clen
+ cbuf clen lower
+;
+
+: mark-position ( -- )
+ >in @ source drop >in @ + 1- c@ bl <= if 1- then is op-end
+;
+: save-parse ( -- )
+ \ Save the current >in pointer, parse the next word and copy it
+ \ into cbuf for processing, then erase the rest of cbuf.
+ parse-word set-parse
+ mark-position
+;
+
+: /rem ( n -- ) rem$ rot /string set-rem$ ;
+
+: init-operands ( -- )
+\ We can't do this because rem$ isn't set if we have an exact match
+\ rem-len abort" Invalid opcode"
+ 0 0 set-rem$
+;
+
+\ Backup one character if the last get-field found a non-zero delimiter.
+: backover-delim ( -- ) adr-delim 0<> /rem ;
+
+: set-field ( n bit# -- ) lshift iop ;
+: rotr ( x cnt -- x' )
+ \ Rotate x right cnt bits within a 32 bit "register."
+ d# 32 mod 2dup rshift -rot d# 32 swap - lshift or
+;
+
+: rotl ( x cnt -- x' )
+ \ Rotate x ldef cnt bits within a 32 bit "register."
+ d# 32 mod 2dup lshift -rot d# 32 swap - rshift or
+;
+
+: 2chars ( -- n )
+ \ This packs the first two characters of the string onto TOS.
+ rem-adr dup 1+ c@ swap c@ bwjoin
+;
+
+: parse-1 ( ch -- flag )
+ rem-len 1 >= if
+ rem-adr c@ = if 1 /rem true exit then
+ else
+ drop
+ then
+ false
+;
+
+\ ----------------
+\ : lex ( text$ delim$ -- rem$ head$ delim true | text$ false )
+
+: next-cons dup 1+ swap ;
+78f1e000
+next-cons constant adt-empty \ End of line.
+next-cons constant adt-delimiter \ Delimiter is 1st character.
+next-cons constant adt-1st \ First of the address word types.
+next-cons constant adt-psrfld \ _c, _f, etc.
+next-cons constant adt-reg \ r0, r1, ..., pc.
+next-cons constant adt-coreg \ c0, c1, ...
+next-cons constant adt-coproc \ p0, p1, ...
+next-cons constant adt-xpsr \ cpsr, spsr.
+next-cons constant adt-shift \ Shift op in Shifter Operands.
+next-cons constant adt-rrx
+next-cons constant adt-immed \ #immediate_value.
+ constant adt-last \ Last +1 of the address word types.
+
+: adt? ( n -- adt? ) adt-1st adt-last within ;
+
+\ -----------------------------
+( Here's some code from the PowerPC assembler that will handle
+ *
+ | <based-number>
+where <based-number> is
+ <decimal-digits>
+ | d#<decimal-digits>
+ | h#<hex-digits>
+ | 0x<hex-digits>
+ | o#<octal-digits>
+ | b#<binary-digits>
+ | <any-word-in-the-'constant-names'-vocabulary>
+ )
+
+\ If adr2,len2 is an initial substring of adr1,len1, return the remainder
+\ of the adr1,len1 string following that initial substring.
+\ Otherwise, return adr1,len1
+: ?remove ( adr1 len1 adr2 len2 -- adr1 len1 false | adr1+len2 len1-len2 true )
+ 2 pick over u< if 2drop false exit then \ len2 too long?
+ 3 pick rot 2 pick ( adr len1 len2 adr1 adr2 len2 )
+ caps-comp 0= if /string true else drop false then
+;
+: set-base ( adr len -- adr' len' )
+ " h#" ?remove if hex exit then
+ " 0x" ?remove if hex exit then
+ " d#" ?remove if decimal exit then
+ " o#" ?remove if octal exit then
+ " 0o" ?remove if octal exit then
+ " b#" ?remove if binary exit then
+ " 0b" ?remove if binary exit then
+;
+
+headers
+
+headerless
+: get-based-number ( adr len -- true | n false )
+ \ The following case statement handles preceding signs because
+ \ the <mumble> who laid out the assembler addressing put the sign
+ \ after the # sign on ldr and str instructions.
+ over c@ case
+ ascii - of true >r 1 /string endof
+ ascii + of false >r 1 /string endof
+ ( default ) false >r
+ endcase
+
+\ ['] register-names $vfind if execute r> if negate then false exit then
+ ['] arm-assembler $vfind if execute r> if negate then false exit then
+ base @ >r decimal
+ set-base
+ $number
+ r> base !
+ r> over 0= land if swap negate swap then
+;
+: number ( [ n1 ] adr len -- n2 )
+ 2dup " *" $= if 2drop then
+ get-based-number abort" Bad number"
+;
+
+headers hex
+\ -----------------------------
+
+: ?next-word ( -- empty? )
+ \ If the current string is empty, parse another word.
+ rem-len 0= if ( )
+ parse-word set-parse mark-position ( )
+ then ( )
+ false ( false )
+;
+
+: start-field ( -- )
+ rem$ skipwhite set-rem$
+ rem-len is last-len
+;
+
+\ False means that there was nothing at all; no delimiter, and no field
+: get-field ( -- false | fld$ true )
+ ?next-word if false exit then
+ rem-len is last-len
+
+ \ Get a field out of the string.
+ rem$ " !#*+,-[]^_{}`" lex 0= if ( field$ )
+ 0 0 2swap 0 ( rem$ field$ delim )
+ then ( rem$ field$ delim )
+ is adr-delim 2swap set-rem$ ( field$ )
+ dup 0<> adr-delim or if ( field$ )
+ true ( field$ true )
+ else ( null$ )
+ 2drop false ( false )
+ then ( false | field$ true )
+;
+
+: ?missing-operand ( empty? -- ) 0= if " Missing operand" ad-error then ;
+: require-field ( -- field$ ) get-field ?missing-operand ;
+
+: cond: ( n1 "name" -- ) d# 28 lshift constant ;
+
+: psr: ( n1 "name" -- ) create 10 lshift , does> @ adt-psrfld ;
+: psrs: ( 10x"name" -- ) 10 1 do i psr: loop ;
+
+\ define the registers
+: reg: ( n "name" -- ) create , does> @ adt-reg ;
+: regs: ( 10x"name" -- ) 10 0 do i reg: loop ;
+
+\ Define the co-processors.
+: coproc: ( n "name" -- ) create , does> @ adt-coproc ;
+: coprocs: ( 10x"name" -- ) 10 0 do i coproc: loop ;
+
+\ Define the co-processor registers.
+: coreg: ( n "name" -- ) create , does> @ adt-coreg ;
+: coregs: ( 10x"name" -- ) 10 0 do i coreg: loop ;
+
+: range-error ( n msg$ -- ) type .d cr abort ;
+
+: expecting ( $ -- ) ." Expecting " ad-error ;
+: ?expecting ( flag msg$ -- ) rot if expecting else 2drop then ;
+: ?#bits ( n #bits -- n )
+ 2dup 1 swap lshift 1- invert and if ( n #bits )
+ ." Value won't fit in " .d " bits" ad-error
+ then ( n #bits )
+ drop
+;
+
+: fits? ( n -- okay? )
+ 10 0 do
+ dup ffffff00 land 0= if
+ \ This rotation fits, package it.
+ i 8 set-field iop true unloop exit
+ else
+ 2 rotl
+ then
+ loop
+ drop false
+;
+: do-#32 ( x -- )
+ fits? 0= if " Immediate value won't fit in 8 bits" ad-error then
+;
+
+: get-number ( -- n )
+ ?next-word 0= ?missing-operand
+
+ \ Get a field out of the string.
+ rem$ " !*,[]^_{}" lex 0= if ( field$ )
+ 0 0 2swap 0 ( rem$ field$ delim )
+ then ( rem$ field$ delim )
+ is adr-delim 2swap set-rem$ ( field$ )
+
+ get-based-number " number" ?expecting ( n )
+;
+
+: parse-error ( -- ) " Unrecognized address field" ad-error ;
+: fix-parse-buffer ( -- )
+ \ Now we have to fix up the parse buffer
+ source >in @ > if ( adr )
+ \ The input buffer is not empty
+ >in @ + c@ case ( char )
+ [char] ] of [char] ] is adr-delim 1 >in +! endof
+ [char] , of [char] , is adr-delim 1 >in +! endof
+ endcase ( )
+ else ( adr )
+ drop
+ then
+ " " set-parse mark-position
+;
+: execute-inline ( -- ?? )
+ rem-len if ( )
+ rem$ " `" lex if ( rem$ field$ delim )
+ \ Delimiter was found; handle field and exit
+ drop 2swap set-rem$ ( field$ )
+ evaluate
+ [char] ] parse-1 if [char] ] is adr-delim else
+ [char] , parse-1 if [char] , is adr-delim then then
+ exit ( ?? )
+ then ( field$ )
+ 0 0 set-rem$ ( field$ )
+ cbuf place ( )
+ " " cbuf $cat ( )
+ else ( )
+ 0 cbuf c! ( )
+ then ( )
+ [char] ` parse cbuf $cat ( )
+ cbuf count evaluate ( ??' )
+
+ fix-parse-buffer
+;
+: get-whatever ( -- [ value ] adt-code )
+ get-field 0= if adt-empty exit then ( field$ )
+ dup if ( field$ )
+ 2dup $asm-find if ( field$ xt )
+ execute 2nip ( n adt-code)
+ dup adt? 0= if parse-error then
+ else ( field$ field$ )
+ get-based-number if parse-error then ( field$ n )
+ adt-immed 2nip ( n adt-code )
+ then ( n adt-code )
+ else ( null$ )
+ \ Empty string, is this delimiter only?
+ 2drop adr-delim case ( delim )
+ ascii # of ( )
+ \ Immediate value.
+ \ Now we have a slight problem with the current get-field; the
+ \ delimiter # is acceptable within the number string, e.g.,
+ \ h#0ff0, and other delimiters are allowed after the number,
+ \ e.g., #h#0ff0]! is legitimate in load and store instructions.
+ \ Until I figure a nicer hack for get-field, we'll handle the
+ \ problem by hand here, using get-number above.
+ get-number adt-immed ( value adt-code )
+ endof ( value adt-code )
+ ascii * of ( value adt-code )
+ \ Value from Stack
+ dup adt? 0= if adt-immed then
+ endof ( value adt-code )
+ ascii ` of
+ \ In-line Forth commands, terminated by another `
+ execute-inline ( ?? )
+ dup adt? 0= if adt-immed then
+ endof
+ ( delim )
+ \ A no action (here, at least) delimiter, pass it back.
+ adt-delimiter over
+ endcase ( value adt-code )
+ then ( value adt-code )
+;
+
+: get-this ( adt-x msk pos -- )
+ >r >r >r get-whatever ( value adt-code R: pos msk adt-x )
+ dup r> <> swap adt-immed <> and " immediate" ?expecting
+ ( val R: pos msk )
+ r> invert over land if " Value exceeds field size" ad-error then
+ r> set-field
+;
+
+: ?register ( adt -- ) adt-reg <> " register" ?expecting ;
+
+: get-immediate ( -- n )
+ get-whatever adt-immed <> " immediate" ?expecting
+;
+
+: get-register ( -- reg )
+ require-field
+ dup if ( field$ )
+ $asm-execute ?register ( reg )
+ else ( null$ )
+ 2drop ( )
+ adr-delim ascii * <> " register" ?expecting ( reg [ adt-reg ] )
+ ascii , parse-1 drop ( reg [ adt-reg ] )
+ dup adt-reg = if drop then ( reg )
+ dup fffffff0 land if " Invalid register number: " range-error then
+ then ( reg )
+;
+
+: get-rn ( bit# -- ) get-register swap set-field ;
+: get-r00 ( -- ) 0 get-rn ;
+: get-r08 ( -- ) 8 get-rn ;
+: get-r12 ( -- ) d# 12 get-rn ;
+: get-r16 ( -- ) d# 16 get-rn ;
+
+: expecting-reg/immed ( -- ) " register or immediate" expecting ;
+: get-shiftr# ( -- )
+ \ Back over a real delimiter, then get the next thing.
+ backover-delim get-whatever case
+ adt-reg of 8 set-field 0000.0010 iop endof
+ adt-immed of 6 ?#bits 7 set-field endof
+ expecting-reg/immed
+ endcase
+;
+
+: get-shift# ( -- )
+ backover-delim get-immediate 6 ?#bits 7 set-field
+;
+
+: expecting-shift ( -- ) " shift specifier" expecting ;
+: get-shiftop ( -- )
+ require-field ( field$ )
+ \ We have something, check it out.
+ $asm-execute case
+ adt-shift of iop get-shiftr# endof
+ adt-rrx of iop endof
+ expecting-shift
+ endcase
+;
+
+: get-shiftop2 ( -- )
+ get-whatever case
+ adt-empty of endof
+ adt-shift of iop get-shiftr# endof
+ adt-rrx of iop endof
+ expecting-shift
+ endcase
+;
+
+: get-shiftls ( -- )
+ get-whatever case
+ adt-shift of iop get-shift# endof
+ adt-rrx of iop endof
+ expecting-shift
+ endcase
+;
+
+: set-i ( -- ) 0200.0000 iop ;
+: p? ( -- flag ) newword 0100.000 land 0<> ;
+: flip-u ( -- ) 0080.0000 xop ;
+: flip-b ( -- ) 0040.0000 xop ;
+: flip-w ( -- ) 0020.0000 xop ;
+
+: get-opr2 ( -- ? )
+ adr-delim ascii , = if 0 is adr-delim then
+ backover-delim get-whatever case
+ adt-reg of iop adr-delim ascii , = if get-shiftop2 then endof
+ adt-immed of set-i do-#32 endof
+ expecting-reg/immed
+ endcase
+;
+
+
+: >offset ( to from -- offset ) 8 + - ;
+
+: >br-offset ( to from -- masked-offset )
+ >offset 2 >>a
+ dup -0080.0000 007f.ffff between
+ 0= abort" Branch displacement out of 24-bit range"
+ 00ffffff land
+;
+: amode-bbl ( b-adr -- )
+ init-operands
+[ifdef] testing
+ get-whatever drop aoffset
+[else]
+ get-immediate here
+[then]
+ >br-offset iop
+ !op
+;
+
+: amode-bx ( -- ) init-operands get-r00 !op ;
+
+: ?psr ( adt -- ) adt-xpsr <> " [cs]psr" ?expecting ;
+
+: amode-mrs ( -- ) init-operands get-r12 get-whatever ?psr iop !op ;
+
+: amode-msr ( -- )
+ init-operands
+
+ \ get xpsr and fields
+ require-field $asm-execute ?psr iop ( )
+
+ \ Get any _X PSR subfields
+ begin adr-delim ascii _ = while
+ \ Get the field following the _ and back over the _.
+ require-field -1 /rem ( field$ )
+ $asm-execute adt-psrfld <> " PSR-field" ?expecting ( psr-field )
+ iop ( )
+ repeat ( )
+
+ \ get r-or-imed, if imed, field = 8 or error.
+ \ Get the next field which we expect to be rx, or #num.
+ require-field adr-delim case ( field$ delim )
+ ascii * of \ Take the address from the stack ( n adt-code field$ )
+ 2drop do-#32 newword fff0ffff land 02080000 or is newword
+ endof
+
+ ascii # of ( field$ )
+ \ Immediate address, the field should be empty and the real
+ \ field is the next one.
+ \ get an immediate field, the default is _f = 8,
+ newword fff0ffff land 02080000 or is newword
+ endof
+
+ 0 of \ This should be a register. ( field$ )
+ $asm-execute ?register xop ( )
+
+ \ If no field bits are set, use the default _cf
+ 000f0000 newword and 0= if 0009.0000 xop then
+
+ \ There should be nothing left on the parse string.
+ rem-len if " Extra characters" ad-error then
+ endof
+
+ expecting-reg/immed
+ endcase
+ !op
+;
+
+: (amode-mul) ( -- ) init-operands get-r16 get-r00 get-r08 ;
+: amode-mul ( -- ) (amode-mul) !op ;
+: amode-mla ( -- ) (amode-mul) get-r12 !op ;
+: amode-lmul ( -- ) init-operands get-r12 get-r16 get-r00 get-r08 !op ;
+: amode-rrop2 ( -- ) init-operands get-r12 get-r16 get-opr2 !op ;
+: amode-rnop2 ( -- ) init-operands get-r16 get-opr2 !op ;
+: amode-rdop2 ( -- ) init-operands get-r12 get-opr2 !op ;
+
+: amode-lsm ( -- )
+ init-operands
+ get-r16 ( )
+ adr-delim ascii ! = if ( )
+ flip-w ( )
+ require-field " ," ?expecting drop ( )
+ then ( )
+
+ \ There should be a comma on the end of the register.
+ adr-delim ascii , <> " ," ?expecting
+
+ \ The next thing up should be an open brace for the register list.
+ get-whatever adt-delimiter <> " {" ?expecting
+ ascii { <> " {" ?expecting
+
+ begin adr-delim ascii } <> while
+ get-whatever case ( value adt )
+
+ adt-reg of ( reg )
+ \ Check the delimiter for - meaning a range.
+ adr-delim ascii - = if ( reg1 )
+ get-whatever ?register ( reg1 reg2 )
+ 1+ swap ?do 1 i set-field loop ( )
+ else ( reg )
+ \ Simple register, set its bit.
+ 1 swap set-field
+ then
+ endof
+
+ " register or }" expecting
+ endcase
+ repeat
+
+ \ We've finished the register list, is there a ^ hanging on the end?
+ ascii ^ parse-1 if flip-b then
+
+ !op
+;
+
+\ rd, [rn, <immed12>] {!}
+\ rd, [rn, +-rm] {!}
+\ rd, [rn, +-rm, <shift>] {!}
+\ rd, [rn], <immed12>
+\ rd, [rn], +-rm
+\ rd, [rn], +-rm, <shift>
+\ The first 3 can be followed by "!" unless the opcode has a "t" at the end
+\ The {!} is handled by amode-lsr
+
+: get-off12 ( -- )
+ get-whatever case
+ adt-delimiter of
+ case
+ ascii + of endof \ Redundant but there.
+ ascii - of flip-u endof \ Clear the add bit, I[23]=0.
+ ascii ] of endof \ Can this happen?
+ " Unexpected delimiter in address" ad-error
+ endcase
+ \ Process the rest of the address, which should be a register plus?.
+ set-i get-r00 adr-delim ascii ] <> if get-shiftls then
+ endof
+
+ adt-immed of
+ \ If the value is negative, switch things around.
+ dup 0< if negate flip-u then
+ d# 12 ?#bits iop
+ \ Check for terminating ] as needed ( if I[24]=1 ).
+ newword 0100.0000 land if
+ adr-delim ascii ] <> " ] " ?expecting
+ then
+ endof
+
+ adt-reg of
+ iop set-i adr-delim ascii , = if get-shiftls then
+ endof
+
+ expecting-reg/immed
+ endcase
+;
+
+defer do-offset
+: get-ea ( do-offset-xt -- )
+ is do-offset
+
+\ adr-delim ascii [ = if exit then
+
+ 0100.0000 iop \ Assume pre-indexing
+
+ require-field dup if ( adr len )
+ ['] arm-assembler $vfind if execute exit then ( adr len )
+ " address specifier" expecting
+ then ( adr 0 )
+ 2drop ( )
+
+ adr-delim ascii [ <> " [" ?expecting
+ 0 is adr-delim
+
+ get-r16
+ adr-delim ascii ] = if \ [rn]
+ \ Look for a comma after the close bracket.
+ ascii , parse-1 if \ [rn], <immed>
+ 0100.0000 xop do-offset
+ then
+ else \ [rn, ...
+ do-offset
+ then
+;
+
+: (amode-ls) ( -- )
+ \ The default case is to add to the base register, which is I[23]=1.
+ \ If we have a negative offset we clear the appropriate bits later.
+ 0080.0000 iop
+
+ get-r12 ['] get-off12 get-ea
+;
+: amode-lst ( -- ) init-operands (amode-ls) !op ;
+
+: {!} ( -- ) ascii ! parse-1 if flip-w then ;
+
+: amode-lsr ( -- ) init-operands (amode-ls) {!} !op ;
+
+: get-off8 ( -- )
+ \ Get the offset for [ldr|str][h\sh\sb] instructions.
+ get-whatever case
+ adt-delimiter of
+ case
+ ascii + of flip-b get-r00 endof
+ ascii - of flip-u flip-b get-r00 endof
+ " +, -, or number" expecting
+ endcase
+ endof
+
+ adt-immed of
+ \ If the value is negative, switch things around.
+ dup 0< if negate flip-u then
+ 8 ?#bits dup f0 land 4 set-field 0f land iop
+ endof
+
+ adt-reg of xop flip-b endof
+
+ expecting-reg/immed
+ endcase
+ p? if {!} then
+;
+
+\ rd, [rn, <immed8>] {!}
+\ rd, [rn, +-rm] {!}
+\ rd, [rn], <immed8>
+\ rd, [rn], +-rm
+
+: amode-lssh ( -- )
+ init-operands
+ \ Set the add offset and immediate value as defaults.
+ 00c0.0000 iop
+ get-r12 ['] get-off8 get-ea
+ !op
+;
+
+: amode-imed24 ( -- )
+ init-operands get-immediate d# 24 ?#bits iop !op
+;
+
+: get-off0 ( -- ) " Offset not allowed" ad-error ;
+: amode-swp ( -- )
+ init-operands get-r12 get-r00 ['] get-off0 get-ea !op
+;
+
+: amode-copr ( -- ) \ Co-processors: mcr, mrc
+ \ p, #, r, c, c, #
+ init-operands
+ adt-coproc 0f 08 get-this
+ adt-immed 07 15 get-this
+ adt-reg 0f 0c get-this
+ adt-coreg 0f 10 get-this
+ adt-coreg 0f 00 get-this
+ adt-immed 07 05 get-this
+ !op
+;
+
+: amode-cdp ( -- ) \ Co-processors: cdp
+ \ p, #, c, c, c, #
+ init-operands
+ adt-coproc 0f 08 get-this
+ adt-immed 0f 14 get-this
+ adt-coreg 0f 0c get-this
+ adt-coreg 0f 10 get-this
+ adt-coreg 0f 00 get-this
+ adt-immed 07 05 get-this
+ !op
+;
+
+\ Get the offset for ldc, stc instructions.
+: get-off-c ( -- )
+ get-immediate
+ \ If the value is negative, negate value, otherwise set add.
+ dup 0< if negate else flip-u then
+ dup 3 and if " Unaligned offset" ad-error then
+ 2 rshift 8 ?#bits iop
+ p? if {!} else flip-w then
+;
+
+: amode-lsc ( -- ) \ Co-processors: ldc, stc
+ init-operands
+ adt-coproc 0f 08 get-this
+ adt-coreg 0f 0c get-this
+ ['] get-off-c get-ea
+ !op
+;
+
+\ ----------------
+
+: next-2? ( -- $ true | false )
+ rem-len 2 < if
+ false ( false )
+ else ( )
+ rem-adr 2 true 2 /rem 0 is adr-delim
+ then
+;
+
+\ This word looks for [|b] on swp commands.
+: {b} ( -- ) ascii b parse-1 if flip-b then ;
+
+\ If the s flag is found, set bit 20 for alu commmands.
+: {s} ( -- ) ascii s parse-1 if 0010.0000 iop then ;
+
+: {hbt} ( -- )
+ ascii h parse-1 if 0400.00b0 xop amode-lssh exit then
+ ascii b parse-1 if flip-b then
+ ascii t parse-1 if flip-w amode-lst exit then
+ amode-lsr
+;
+: {shbt} ( -- )
+ ascii s parse-1 if
+ ascii b parse-1 if 0400.00d0 xop else
+ ascii h parse-1 if 0400.00f0 xop else " b or h" expecting then then
+ amode-lssh
+ else
+ {hbt}
+ then
+;
+
+: parse-condition? ( -- cond true | false )
+ \ The next two characters of the input string will be checked for a
+ \ valid condition code. If found, the appropriate code will be
+ \ left on the stack between the updated string pair and true (TOS).
+ \ If not, The original string pair and false will be left on the stack.
+ next-2? if
+ \ Correct conditions get an even result from sindex.
+ " eqnecsccmiplvsvchilsgeltgtleal00eqnehslo" sindex dup 1 and if
+ drop -2 /rem false
+ else ( index )
+ 2/ h# f land true
+ then
+ else
+ false
+ then
+;
+
+: {cond} ( opcode -- )
+ is newword
+ \ The next two characters of the input string will be checked for a
+ \ valid condition code. If found, the appropriate code will be
+ \ inserted in newword and the string pointer / length will be
+ \ updated. If not, the code for always will be inserted in newword
+ \ and the string pair will be unchanged.
+ parse-condition? 0= if h# e then
+ d# 28 set-field \ put the condition code in.
+;
+: {cond/s} ( opcode -- ) {cond} {s} ;
+
+: parse-inc ( l-flag -- )
+ \ Parse the increment tag for ldm and stm. There MUST be a two letter
+ \ code to specify the increment option so we bail if we don't get one
+ \ of the eight possible codes. l-flag true specifies ldm, vice stm.
+ 0= >r next-2? 0= " increment specifier" ?expecting
+
+ \ Correct tags have an even index from sindex.
+ " daiadbibfafdeaed" sindex dup 1 land " increment specifier" ?expecting
+
+ \ If we have an alternative code and stm, invert the bits.
+ dup 8 land r> land if 6 xor then
+
+ 6 land d# 22 lshift xop
+;
+
+: ?match ( #chars -- false | xt true )
+ rem-len over < if drop false exit then ( #chars )
+ rem-adr over ['] arm-assembler search-wordlist if ( #chars xt )
+ swap /rem true ( xt true )
+ else ( #chars )
+ drop false ( false )
+ then
+;
+: $arm-assem-do-undefined ( adr len -- )
+ \ Get the next string on the input stream, copy it and make it lower case.
+ set-parse rem$ lower ( )
+
+ 5 ?match if execute exit then
+ 3 ?match if execute exit then
+
+ \ Don't try a 2-character match if the string length is 3, because,
+ \ for example, "blt" (i.e. b{lt}) would then match "bl" instead of "b".
+ rem-len 3 <> if 2 ?match if execute then then
+
+ 1 ?match if execute exit then
+
+ rem$ $interpret-do-undefined
+;
+: $assemble ( adr len -- )
+ dup 0= if 2drop exit then
+
+\ ['] directives $vfind if execute exit then ( adr len )
+
+ $arm-assem-do-undefined
+;
+
+: resident ( -- )
+\ little-endian
+\ aligning? on
+ [ also forth ] ['] here [ previous ] is here
+ [ also forth ] ['] allot [ previous ] is asm-allot
+ [ also forth ] ['] le-l@ [ previous ] is asm@
+ [ also forth ] ['] instruction! [ previous ] is asm!
+[ifdef] set-relocation-bit
+ ['] set-relocation-bit is asm-set-relocation-bit
+[else]
+ ['] noop is asm-set-relocation-bit
+[then]
+;
+resident
+
+headers
+also arm-assembler definitions
+\ also register-names definitions
+: lsl ( -- n1 n2 ) 00000000 adt-shift ;
+: lsr ( -- n1 n2 ) 00000020 adt-shift ;
+: asr ( -- n1 n2 ) 00000040 adt-shift ;
+: ror ( -- n1 n2 ) 00000060 adt-shift ;
+: rrx ( -- n1 n2 ) 00000060 adt-rrx ;
+
+: spsr ( -- n1 n2 ) 00400000 adt-xpsr ;
+: cpsr ( -- n1 n2 ) 00000000 adt-xpsr ;
+
+psrs: _c _x _cx _s _cs _xs _cxs _f _cf _xf _cxf _sf _csf _xsf _cxsf
+1 psr: _ctl
+8 psr: _flg
+9 psr: _all
+
+coprocs: p0 p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 p11 p12 p13 p14 p15
+coregs: cr0 cr1 cr2 cr3 cr4 cr5 cr6 cr7 cr8 cr9 cr10 cr11 cr12 cr13 cr14 cr15
+regs: r0 r1 r2 r3 r4 r5 r6 r7 r8 r9 r10 r11 r12 r13 r14 r15
+
+previous definitions
+
+also arm-assembler definitions
+: and 0000.0000 {cond/s} amode-rrop2 ;
+: eor 0020.0000 {cond/s} amode-rrop2 ;
+: sub 0040.0000 {cond/s} amode-rrop2 ;
+: rsb 0060.0000 {cond/s} amode-rrop2 ;
+: add 0080.0000 {cond/s} amode-rrop2 ;
+: adc 00a0.0000 {cond/s} amode-rrop2 ;
+: sbc 00c0.0000 {cond/s} amode-rrop2 ;
+: rsc 00e0.0000 {cond/s} amode-rrop2 ;
+: orr 0180.0000 {cond/s} amode-rrop2 ;
+: bic 01c0.0000 {cond/s} amode-rrop2 ;
+
+: mov 01a0.0000 {cond/s} amode-rdop2 ;
+: mvn 01e0.0000 {cond/s} amode-rdop2 ;
+
+: mul 0000.0090 {cond/s} amode-mul ;
+: mla 0020.0090 {cond/s} amode-mla ;
+: umull 0080.0090 {cond/s} amode-lmul ;
+: umlal 00a0.0090 {cond/s} amode-lmul ;
+: smull 00c0.0090 {cond/s} amode-lmul ;
+: smlal 00e0.0090 {cond/s} amode-lmul ;
+
+: tst 0110.0000 {cond} amode-rnop2 ;
+: teq 0130.0000 {cond} amode-rnop2 ;
+: cmp 0150.0000 {cond} amode-rnop2 ;
+: cmn 0170.0000 {cond} amode-rnop2 ;
+
+: mrs 010f.0000 {cond} amode-mrs ;
+: msr 0120.f000 {cond} amode-msr ;
+
+: ldc 0c10.0000 {cond} amode-lsc ;
+: stc 0c00.0000 {cond} amode-lsc ;
+: cdp 0e00.0000 {cond} amode-cdp ;
+: mcr 0e00.0010 {cond} amode-copr ;
+: mrc 0e10.0010 {cond} amode-copr ;
+
+: swi 0f00.0000 {cond} amode-imed24 ;
+
+: b 0a00.0000 {cond} amode-bbl ;
+: bl 0b00.0000 {cond} amode-bbl ;
+
+: bx 012f.ff10 {cond} amode-bx ;
+
+: swp 0100.0090 {cond} {b} amode-swp ;
+
+: ldm 0810.0000 {cond} 1 parse-inc amode-lsm ;
+: stm 0800.0000 {cond} 0 parse-inc amode-lsm ;
+
+: ldr ( -- ) 0410.0000 {cond} {shbt} ;
+: str ( -- ) 0400.0000 {cond} {hbt} ;
+
+: rd-field ( reg# -- ) d# 12 set-field ;
+: rb-field ( reg# -- ) d# 16 set-field ;
+
+\ XXX need ADR, SET
+\ adr{cond} rN,<address>
+: (set) ( address? -- )
+ >r
+ 0000.0000 {cond} init-operands
+ \ Put the register number on the return stack so it won't interfere
+ \ with the stack items used by any "*" operands there may be.
+ get-register >r ( r: adr? reg# )
+ get-immediate ( address r: adr? reg# )
+ dup here >offset ( address offset r: adr? reg# )
+ dup fits? if ( address offset r: adr? reg# )
+ nip nip 028f.0000 ( op r: adr? reg# ) \ add rN,pc,#<offset>
+ else ( address offset r: adr? reg# )
+ negate fits? if ( address r: adr? reg# )
+ drop 024f.0000 ( op r: adr? reg# ) \ sub rN,pc,#<offset>
+ else ( address r: adr? reg# )
+ ea00.0000 asm, ( address r: adr? reg# ) \ b here+8
+ r> r@ swap >r if ( address r: adr? reg# )
+ here asm-set-relocation-bit drop
+ then
+ asm, ( r: adr? reg# ) \ adr
+ 051f.000c ( op r: adr? reg# ) \ ldr rN,[pc,#-12]
+ then ( op r: adr? reg# )
+ then ( op r: adr? reg# )
+ iop r> rd-field ( )
+ r> drop
+ !op
+;
+: adr ( -- ) true (set) ;
+: set ( -- ) false (set) ;
+
+: nop ( -- ) h# e1a00000 asm, ; \ mov r0,r0
+
+: # ( -- adt-immed ) adt-immed ;
+: reg ( -- adt-reg ) adt-reg ;
+
+headerless
+00 cond: = 00 cond: 0=
+01 cond: <> 01 cond: 0<>
+02 cond: u>=
+03 cond: u<
+04 cond: 0<
+05 cond: 0>=
+06 cond: vs
+07 cond: vc
+08 cond: u>
+09 cond: u<=
+0a cond: >=
+0b cond: <
+0c cond: > 0c cond: 0>
+0d cond: <= 0d cond: 0<=
+0e cond: always
+
+: -cond ( cond -- !cond ) 1000.0000 xor ;
+
+: put-branch ( target where -- ) tuck >br-offset ea00.0000 or swap asm! ;
+: put-call ( target where -- ) tuck >br-offset eb00.0000 or swap asm! ;
+
+: brif ( target cond -- ) swap here >br-offset or 0a00.0000 or asm, ;
+
+\ These implementation factors are used by the local labels package
+: <mark ( -- <mark ) here ;
+: >mark ( -- >mark ) here ;
+: >resolve ( >mark -- ) here over >br-offset over asm@ + swap asm! ;
+: <resolve ( <mark -- <mark ) ;
+
+headers
+: but ( mark1 mark2 -- mark2 mark1 ) swap ;
+: yet ( mark -- mark mark ) dup ;
+
+: ahead ( -- >mark ) >mark here 8 + always brif ;
+: if ( cond -- >mark ) >mark here 8 + rot -cond brif ;
+: then ( >mark -- ) >resolve ;
+: else ( >mark -- >mark1 ) ahead but then ;
+: begin ( -- <mark ) <mark ;
+: until ( <mark cond -- ) -cond brif ;
+: again ( <mark -- ) always brif ;
+: repeat ( >mark <mark -- ) again then ;
+: while ( <mark cond -- >mark <mark ) if but ;
+
+\ previous definitions
+
+previous definitions
+
+[ifdef] testing
+0 value expected
+
+order
+also forth definitions
+: test ( "address" "expected" "assembly-code" -- )
+ parse-word $number abort" bad address" is aoffset
+ parse-word $number abort" bad code" is expected
+ parse-word $assemble newword expected <> if
+ ." oops!! expected " expected .x ." got " newword .x cr
+ else
+ ." ."
+ then
+;
+
+: testloop clear begin refill while test
+depth abort" Stack trash"
+repeat ;
+previous definitions
+[then]
+previous previous definitions
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1997 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/assem.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/basefw.bth
===================================================================
--- cpu/arm/basefw.bth (rev 0)
+++ cpu/arm/basefw.bth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,107 @@
+purpose: Load file for base firmware - no platform specifics
+\ See license at end of file
+
+dictionary: ${BP}/cpu/arm/build/tools.dic
+command: &armforth &dictionary &this
+build-now
+
+\ ' $report-name is include-hook
+
+create include-help \ Include help facility
+
+alias cfill fill
+fload ${BP}/ofw/core/ofwcore.fth \ Device tree and other OBP routines
+fload ${BP}/ofw/core/ofwfw.fth \ FirmWorks enhancements
+fload ${BP}/ofw/core/memops.fth \ Call memory node methods
+fload ${BP}/ofw/core/mmuops.fth \ Call MMU node methods
+\ : cfill fill ;
+
+fload ${BP}/cpu/arm/scc.fth \ System Control Coprocessor registers
+fload ${BP}/cpu/arm/traps.fth \ Exception handlers
+fload ${BP}/cpu/arm/psr.fth \ Special registers
+fload ${BP}/cpu/arm/getms.fth \ Timer access
+
+fload ${BP}/cpu/arm/centry.fth \ Low-level client entry and exit
+fload ${BP}/cpu/arm/fb8-ops.fth \ 8-bit frame buffer primitives
+
+fload ${BP}/ofw/confvar/loadcv.fth \ Configuration variables
+fload ${BP}/ofw/core/silentmd.fth \ NVRAM variable silent-mode?
+
+fload ${BP}/ofw/termemu/loadfb.fth \ Frame buffer support
+fload ${BP}/ofw/termemu/difont.fth \ Get font from a dropin module
+
+fload ${BP}/ofw/gui/alert.fth \ Basic dialogs and alerts
+fload ${BP}/dev/stringio.fth \ Output diversion
+
+fload ${BP}/ofw/core/loadmore.fth \ Load additional core stuff
+
+fload ${BP}/ofw/inet/loadtftp.fth \ Trivial File Transfer Protocol pkg.
+
+fload ${BP}/cpu/arm/forthint.fth \ Alarm handler
+
+fload ${BP}/cpu/arm/regacc.fth \ Register access words
+
+fload ${BP}/cpu/arm/memtest.fth \ Memory test primitives
+
+fload ${BP}/ofw/fcode/loadfcod.fth \ S Fcode interpreter
+
+fload ${BP}/ofw/fcode/regcodes.fth \ Register access words
+fload ${BP}/ofw/fcode/extcodes.fth \ Firmworks extension FCodes
+
+fload ${BP}/ofw/core/initprog.fth \ FCode and Forth source load formats
+
+fload ${BP}/ofw/core/infltdi.fth \ Support for compressed dropin drivers
+
+fload ${BP}/cpu/arm/initpgm.fth \ Basic boot handler
+
+[ifdef] resident-packages
+support-package: fat-file-system
+ fload ${BP}/ofw/fs/fatfs/loadpkg.fth \ FAT file system reader
+end-support-package
+
+support-package: iso9660-file-system
+ fload ${BP}/ofw/fs/cdfs/loadpkg.fth \ ISO 9660 CD-ROM file system reader
+end-support-package
+
+support-package: disk-label
+ fload ${BP}/ofw/disklabel/loadpkg.fth \ Disk label package
+end-support-package
+[then]
+
+[ifdef] resident-packages
+fload ${BP}/ofw/fs/fatfs/fdisk2.fth \ Partition map administration
+[else]
+autoload: fdisk2.fth
+defines: $.partitions
+defines: .partitions
+\ defines: init-nt-disk
+defines: $partition
+[then]
+
+[ifndef] no-heads
+.( --- Saving basefw.dic --- ) cr " basefw.dic" $save-forth
+[then]
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1994 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/basefw.bth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/bitops.fth
===================================================================
--- cpu/arm/bitops.fth (rev 0)
+++ cpu/arm/bitops.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,57 @@
+purpose: Bit operations
+\ See license at end of file
+
+hex
+code bitset ( bit# array -- )
+ mov r0,tos \ r0 array
+ ldmia sp!,{r1,tos} \ r1 bit#
+ and r2,r1,#7
+ mov r3,#0x80
+ ldrb r4,[r0,r1,asr #3]
+ orr r4,r4,r3,ror r2
+ strb r4,[r0,r1,asr #3]
+c;
+
+code bitclear ( bit# array -- )
+ mov r0,tos \ r0 array
+ ldmia sp!,{r1,tos} \ r1 bit#
+ and r2,r1,#7
+ mvn r3,#0x80
+ ldrb r4,[r0,r1,asr #3]
+ and r4,r4,r3,ror r2
+ strb r4,[r0,r1,asr #3]
+c;
+
+code bittest ( bit# array -- flag )
+ pop r1,sp \ r1 bit#
+ and r2,r1,#7
+ mov r3,#0x80
+ ldrb r4,[tos,r1,asr #3]
+ ands r4,r4,r3,ror r2
+ mvnne tos,#0
+ moveq tos,#0
+c;
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1997 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/bitops.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/boot.fth
===================================================================
--- cpu/arm/boot.fth (rev 0)
+++ cpu/arm/boot.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,124 @@
+\ Contents: Boot-code for ARM Risc_OS Code
+\ See license at end of file
+
+hex
+nuser memtop \ The top of the memory used by Forth
+0 value #args \ The process's argument count
+0 value args \ The process's argument list
+
+0 constant main-task \ This pointer will be changed at boot
+
+code start-forth ( r6: header r7: syscall-vec r8: memtop )
+ ( r10: argc r11: argv r12: initial-heap-size )
+ \ Binary relocation. This code reads the relocation bitmap and
+ \ relocates each longword marked by a 1 bit in the bitmap. Each
+ \ bit in the bitmap represents an aligned address in the program
+ \ image, thus there is one relocation bit for each 32-bit word in
+ \ the program image. The bits in relocation bitmap are numbered
+ \ in big-endian order.
+ \ The 0x80 bit corresponds to a lower address than then 0x40 bit, etc.
+ add r0,r6,#0x80 \ forth-image
+ ldr r1,[r0,#0x10] \ /dictionary
+ ldr r3,[r0,#0x14] \ old origin
+ mov r2,r1,asr #2 \ words to relocate
+ add r1,r0,r1 \ dictionary size plus forth-image
+ cmp r3,r0
+ <> if
+ dec r2,#1
+ \ variables:
+ \ r0: The startof the program image
+ \ r1: The ending address of the program image,
+ \ equal to the starting address of the relocation bitmap
+ \ r2: bit-to-relocate
+ \ r3: origin at saving time
+
+ begin
+ and r4,r2,#7
+ mov r5,#0x80
+ mov r4,r5,lsr r4
+ ldrb r5,[r1,r2,asr #3]
+ ands r4,r4,r5
+ 0<> if
+ ldr r4,[r0,r2,lsl #2]
+ sub r4,r4,r3
+ add r4,r4,r0
+ str r4,[r0,r2,lsl #2]
+ then
+ subs r2,r2,#1
+ <= until
+ then
+
+ \ set user-pointer up
+
+ add up,r0,`init-user-area #` \ set user-pointer
+ str r1,'user dp \ set here
+
+ str r8,'user memtop
+ sub sp,r8,#0x40
+ \ Now the stacks are just below the end of our memory
+
+ ps-size-t rs-size-t + #
+ sub r8,r8,*
+ sub r8,r8,r12
+ str r8,'user limit
+
+ str r7,'user syscall-vec
+ str r10,'user #args
+ str r11,'user args
+
+ \ At this point, the stack pointer is at the top of the unused
+ \ memory and the user pointer has been set to the bottom of the
+ \ initial user area image.
+ str up,'user up0
+ str up,[pc,`'body main-task swap here 8 + - swap`]
+ mov rp,sp \ set return-stack pointer
+ str rp,'user rp0
+ rs-size-t 100 + #
+ dec sp,*
+ dec sp,#0x20
+ str sp,'user sp0
+ inc sp,1cell \ account for the top of stack register
+ adr ip,'body cold
+c;
+
+code cold-code ( r0: loadaddr r1: functions r2: memtop ... )
+ ( r3: argc sp[0]: argv )
+ here-t 8 put-call
+
+ \ Put the arguments in safe registers
+ mov r6,r0 \ r6 points to header
+ mov r7,r1 \ r7: functions
+ mov r8,r2 \ r8: memtop
+ \ r9 is up
+ mov r10,r3 \ r10: argc
+ ldr r11,[sp] \ r11: argv
+ mov r12,#0 \ r11: initial-heap-size
+
+ b 'code start-forth
+end-code
+
+: init-user ;
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/boot.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/build/Makefile
===================================================================
--- cpu/arm/build/Makefile (rev 0)
+++ cpu/arm/build/Makefile 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,27 @@
+OS := $(shell uname)
+
+all: basefw.dic
+
+.PHONY: FORCE all clean
+
+.PRECIOUS: builder.dic
+
+../${OS}/forth:
+ @make -C ../${OS} forth
+
+build: ../${OS}/forth
+ @ln -sf ../${OS}/forth $@
+
+%.dic: FORCE build
+ ./build $@
+
+builder.dic: FORCE build
+ -[ ! -f builder.sav ] && cp builder.dic builder.sav
+ ./build builder.dic
+
+inflate.bin:
+ make -C ../${OS} ../build/inflate.bin
+
+# Don't use *.dic so as not to remove builder.dic
+clean:
+ rm -f tools.dic kernel.dic basefw.dic *.log headers *~ inflate.bin build
Property changes on: cpu/arm/build/Makefile
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/builder.bth
===================================================================
--- cpu/arm/builder.bth (rev 0)
+++ cpu/arm/builder.bth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,10 @@
+purpose: Load file for i386 builder
+
+dictionary: ${BP}/cpu/arm/build/tools.dic
+command: &armforth &dictionary &this
+build-now
+
+fload ${BP}/ofw/tokenizer/tokenize.fth \ Tokenizer
+fload ${BP}/forth/lib/builder.fth \ Builder
+
+.( --- Saving builder.dic --- ) " builder.dic" $save-forth cr
Property changes on: cpu/arm/builder.bth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/call.fth
===================================================================
--- cpu/arm/call.fth (rev 0)
+++ cpu/arm/call.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,50 @@
+purpose: From Forth, call the C subroutine whose address is on the stack
+\ See license at end of file
+
+code sp-call ( [ arg5 .. arg0 ] adr sp -- [ arg5 .. arg0 ] result )
+ pop r6,sp \ Get the subroutine address
+
+ str sp,'user saved-sp \ Save for callbacks
+ psh ip,rp \ ARM Procedure Call Standard can clobber IP
+ str rp,'user saved-rp \ Save for callbacks
+
+ mov rp,#0 \ Set the frame pointer to null
+
+ \ Pass up to 6 arguments
+ ldmia sp,{r0,r1,r2,r3,r4,r5}
+
+ mov sp,tos \ Switch to the new stack
+
+ mov lk,pc \ Set link register to return address
+ mov pc,r6 \ Call the subroutine
+
+ ldr rp,'user saved-rp \ Restore the return stack pointer
+ pop ip,rp \ Restore IP
+ ldr sp,'user saved-sp \ Restore the stack pointer
+ mov tos,r0 \ Return subroutine result
+c;
+: call ( [ arg5 .. arg0 ] adr -- [ arg5 .. arg0 ] result ) sp@ sp-call ;
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1997 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/call.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/centry.fth
===================================================================
--- cpu/arm/centry.fth (rev 0)
+++ cpu/arm/centry.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,75 @@
+purpose: Client interface handler code
+\ See license at end of file
+
+d# 11 /n* buffer: cif-reg-save
+
+headerless
+code cif-return
+ mov r0,tos
+ ldr r1,'user cif-reg-save \ Address of register save area in r1
+ ldmia r1,{r4,r5,r6,r7,r8,r9,r10,r11,r12,r13,pc} \ Restore registers
+end-code
+
+: cif-exec ( args ... -- ) do-cif cif-return ;
+
+headers
+: cif-caller ( -- adr ) cif-reg-save d# 84 + @ ;
+
+headerless
+label cif-handler
+ \ Registers:
+ \ r0 argument array pointer
+ \ r4-r14 must be preserved
+ \ r1-r3 scratch
+
+
+ adr r2,'body main-task
+ ldr r2,[r2] \ Get user pointer
+ ldr r1,[r2,`'user# cif-reg-save`] \ Address of register save area in r1
+ stmia r1,{r4,r5,r6,r7,r8,r9,r10,r11,r12,r13,r14} \ Save registers
+
+ mov up,r2 \ Set user pointer
+
+ mov tos,r0 \ Set top of stack register to arg
+
+ ldr rp,'user rp0 \ Set return stack pointer
+ ldr sp,'user sp0 \ Set data stack pointer
+ inc sp,1cell \ Account for the top of stack register
+
+ adr ip,'body cif-exec \ Set interpreter pointer
+c;
+
+0 value callback-stack
+
+headers
+: callback-call ( args vector -- ) callback-stack sp-call 2drop ;
+
+\ Force allocation of buffer
+stand-init: CIF buffers
+ cif-reg-save drop
+ h# 1000 dup alloc-mem + to callback-stack
+;
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1997 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/centry.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/code.fth
===================================================================
--- cpu/arm/code.fth (rev 0)
+++ cpu/arm/code.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,160 @@
+purpose: Defining words for code definitions
+\ See license at end of file
+
+\ These words are specific to the virtual machine implementation
+: assembler ( -- ) arm-assembler ;
+
+only forth also arm-assembler also helpers also arm-assembler also definitions
+
+\ Forth Virtual Machine registers
+
+\ also register-names definitions
+\ Convenient register names for portable programming
+: base r7 ;
+: up r9 ;
+: tos r10 ;
+: rp r11 ;
+: ip r12 ;
+: sp r13 ;
+: lk r14 ;
+: lr r14 ;
+: pc r15 ;
+\ previous definitions
+
+\ also constant-names definitions
+\ also register-names definitions
+
+: asm-con: ( n "name" -- ) create , does> @ adt-immed ;
+/n asm-con: 1cell \ Offsets into the stack
+1cell drop -1 * asm-con: -1cell
+1cell drop -1 * asm-con: ~1cell
+1cell drop 2 * asm-con: 2cells
+1cell drop 3 * asm-con: 3cells
+1cell drop 4 * asm-con: 4cells
+
+1cell drop asm-con: /cf \ Size of a code field (except for "create")
+/cf drop -1 * asm-con: -/cf
+/cf drop -1 * asm-con: ~/cf
+
+1cell drop asm-con: /token \ Size of a compiled word reference
+/token drop -1 * asm-con: -/token
+/token drop -1 * asm-con: ~/token
+
+1cell drop asm-con: /branch \ Size of a branch offset
+
+/token drop 2 * asm-con: /ccf \ Size of a "create" code field
+
+/cf drop 1cell drop + asm-con: /cf+1cell \ Location of second half of
+previous definitions
+
+\ The next few words are already in the forth vocabulary;
+\ we want them in the assembler vocabulary too
+alias next next
+headerless
+: exitcode ( -- )
+ ['] $interpret-do-undefined is $do-undefined
+ previous
+;
+' exitcode is do-exitcode
+headers
+alias c; c;
+
+: set-offset ( offset -- ) d# 12 ?#bits iop ;
+: 'body ( "name" -- variable-apf adt-immed ) ' >body adt-immed ;
+: 'code ( "name" -- code-word-acf adt-immed ) ' adt-immed ;
+: 'user# ( "name" -- user# adt-immed ) ' >body @ adt-immed ;
+: 'user ( "name" -- )
+\ [ also register-names ] up [ previous ] drop ( reg# )
+ up drop rb-field
+ 'user# ( value adt-immed )
+ drop set-offset
+;
+\ lnk{cond}{s} rN
+\ is equivalent to
+\ mov{cond} rN,lk
+: lnk ( -- )
+\ [ also register-names ] lk [ previous ] drop ( reg# )
+ lk drop ( reg# )
+ 01a0.0000 or {cond/s} init-operands get-r12 !op
+;
+
+: (incdec) ( op-template -- )
+ {cond/s}
+ init-operands
+ get-register dup rd-field rb-field
+ get-opr2
+ !op
+;
+
+\ inc{cond}{s} rN,<immed>
+\ is equivalent to
+\ add{cond}{s} rN,rN,<immed>
+: inc ( -- ) 0080.0000 (incdec) ;
+
+\ dec{cond}{s} rN,<immed>
+\ is equivalent to
+\ sub{cond}{s} rN,rN,<immed>
+: dec ( -- ) 0040.0000 (incdec) ;
+
+: (pshpop) ( op-template -- ) {cond} init-operands get-r12 get-r16 !op ;
+\ psh{cond} rN,rM
+\ is equivalent to
+\ str{cond} rN,[rM,-1cell]!
+: psh ( -- ) 0520.0004 (pshpop) ;
+
+\ pop{cond} rN,rM
+\ is equivalent to
+\ ldr{cond} rN,[rM],1cell
+: pop ( -- ) 0490.0004 (pshpop) ;
+
+\ nxt{cond}
+\ is equivalent to
+\ mov{cond} pc,up
+: nxt ( -- )
+\ [ also register-names ] up [ previous ] drop ( reg# )
+ up drop
+ 01a0.f000 or {cond/s} init-operands !op
+;
+
+also forth definitions
+headerless
+: entercode ( -- )
+ also assembler
+\ false is disassembling?
+ [ also helpers ]
+ ['] $arm-assem-do-undefined is $do-undefined
+ [ previous ]
+;
+' entercode is do-entercode
+
+headers
+\ "code" is defined in the kernel
+
+: label \ name ( -- )
+ create !csp entercode
+;
+only forth also definitions
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/code.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/cpubpsup.fth
===================================================================
--- cpu/arm/cpubpsup.fth (rev 0)
+++ cpu/arm/cpubpsup.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,87 @@
+purpose: Processor-dependent definitions for breakpoints on ARM
+\ See license at end of file
+
+\ Machine-dependent definitions for breakpoints
+
+headerless
+defer breakpoint-trap?
+
+\ True if the exception was an undefined instruction
+: (breakpoint-trap? ( -- flag ) exception-psr h# 1f and h# 1b = ;
+' (breakpoint-trap? is breakpoint-trap?
+
+: op@ ( adr -- op ) l@ ;
+: op! ( op adr -- ) instruction! ;
+: bp-address-valid? ( adr -- flag ) 3 and 0= ;
+: at-breakpoint? ( adr -- flag ) op@ breakpoint-opcode = ;
+: put-breakpoint ( adr -- ) breakpoint-opcode swap op! ;
+
+headers
+: .instruction ( -- )
+ pc [ also disassembler ] dis-pc! dis1 [ previous ]
+;
+
+headerless
+\ Find the places to set the next breakpoint for single stepping.
+
+\ Flag is true if the branch should be followed - we don't follow branches
+\ if stepping? is false and the instruction is a "bl"
+: >b-target ( pc -- adr ) dup l@ 8 << 6 >>a + 8 + ;
+: bl? ( pc -- flag ) l@ h# 0f00.0000 and h# 0b00.0000 = ;
+: b? ( pc -- flag ) l@ h# 0e00.0000 and h# 0a00.0000 = ;
+
+: next-instruction ( stepping? -- next-adr branch-target|0 )
+ pc la1+ swap ( next-adr stepping? )
+
+ \ If we are hopping (not stepping), then we don't follow
+ \ branch-and-link instructions.
+ 0= pc bl? and if 0 exit then ( next-adr )
+
+ pc ( next-adr pc )
+ dup b? if >b-target exit then ( next-adr pc )
+ dup bl? if >b-target exit then ( next-adr pc )
+\ XXX need to handle all sorts of instructions with PC as the destination
+ drop 0
+;
+
+: bumppc ( -- ) pc la1+ to pc ;
+
+alias rpc pc
+
+: return-adr ( -- adr ) r11 l@ ;
+: leaf-return-adr ( -- adr ) lr ;
+
+: backward-branch? ( adr -- flag ) \ True if adr points to a backward branch
+ dup b? if dup >b-target u> exit then ( adr )
+ drop false
+;
+: loop-exit-adr ( -- adr )
+ pc begin dup backward-branch? 0= while la1+ repeat la1+
+;
+
+headers
+: set-pc ( adr -- ) to pc ;
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1994 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/cpubpsup.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/cpustate.fth
===================================================================
--- cpu/arm/cpustate.fth (rev 0)
+++ cpu/arm/cpustate.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,42 @@
+purpose: Buffers for saving program state
+\ See license at end of file
+
+headers
+\ A place to save the CPU registers when we take a trap
+0 value cpu-state \ Pointer to CPU state save area
+
+headerless
+: >state ( offset -- adr ) cpu-state + ;
+
+\ Don't use buffer: for these because we may need to instantiate them
+\ before the buffer: mechanism has been initialized.
+0 value pssave \ Forth data stack save area
+0 value rssave \ Forth return stack save area
+
+headers
+defer .exception \ Display the exception type
+defer handle-breakpoint \ What to do after saving the state
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1985-1994 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/cpustate.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/ctrace.fth
===================================================================
--- cpu/arm/ctrace.fth (rev 0)
+++ cpu/arm/ctrace.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,102 @@
+purpose: Displays a backtrace of saved C stack frames.
+\ See license at end of file
+
+only forth also hidden also forth definitions
+: 9.r ( adr -- ) push-hex 9 u.r pop-base ;
+defer .subname ' 9.r is .subname
+
+: .subroutine ( lr -- ) \ Show soubroutine address
+ 4 - dup l@ h# 0f00.0000 and h# 0b00.0000 = if \ BAL instruction?
+ dup l@ 8 << 6 >>a + .subname exit
+ then
+ drop ." ??????" \ perhaps an indirect call
+;
+: .args ( -- ) \ Show C subroutine arguments
+ ." (" r0 9.r r1 9.r r2 9.r r3 9.r ." ... )"
+;
+: .c-call ( lr -- )
+ ." Subroutine " dup l@ .subroutine ." called from " 4 - .subname cr
+;
+: ctrace ( -- ) \ C stack backtrace
+\ XXX we should look at the first instruction in the subroutine
+\ to determine whether it is using the FP or non-FP protocol.
+\ Without an FP it will be rather tricky to find the saved PCs, but
+\ at least we might be able to avoid going off into the ozone.
+ push-hex
+ ." PC at " pc .subname cr
+ ." Last leaf: " lr .subroutine .args cr
+ ." Call-chain:" cr
+ r11 begin ( frame-pointer )
+ dup 0<> over in-return-stack? 0= and
+ while
+ >saved dup -1 l+ l@ .c-call
+ -3 la+ l@ ( next-fp )
+ repeat
+ pop-base
+;
+\ compiler options: /swst or /noswst
+\ Non-leaf:
+\ Preamble
+\ +0000 0x000080cc: 0xe1a0c00d .... : * mov r12,r13
+\ +0004 0x000080d0: 0xe92dd800 ..-. : stmdb r13!,{r11,r12,r14,pc}
+\ +0008 0x000080d4: 0xe24cb004 ..L. : sub r11,r12,#4
+\ SW stack checking goes here if enabled
+\ ...
+\ +000c 0x000080d8: 0xeb000001 .... : bl foo
+\ +0010 0x000080dc: 0xe3a00000 .... : mov r0,#0
+\ ...
+\ Postamble
+\ +0014 0x000080e0: 0xe91ba800 .... : ldmdb r11,{r11,r13,pc}
+
+\ The stack frame then looks like:
+\
+\ (previous SP) --->
+\ &code after preamble (i.e. entry-adr + 0xc)
+\ (new FP (r11))--->
+\ return address
+\ previous SP
+\ previous FP
+\ saved Rm
+\ ...
+\ saved Rn
+\ (new SP (r13))--->
+
+\ Leaf:
+\ foo
+\ +0000 0x000080e4: 0xe1a0f00e .... : mov pc,r14
+
+
+\ compiler options: /nofp
+\ main
+\ +0000 0x000080cc: 0xe92d4000 .@-. : stmdb r13!,{r14}
+\
+\ +0004 0x000080d0: 0xeb000001 .... : bl foo
+\ +0008 0x000080d4: 0xe3a00000 .... : mov r0,#0
+\
+\ +000c 0x000080d8: 0xe8bd8000 .... : ldmia r13!,{pc}
+\ foo
+\ +0000 0x000080dc: 0xe1a0f00e .... : mov pc,r14
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1997 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/ctrace.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/debugm.fth
===================================================================
--- cpu/arm/debugm.fth (rev 0)
+++ cpu/arm/debugm.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,86 @@
+purpose: Machine-dependent support routines for Forth debugger.
+\ See license at end of file
+
+hex
+
+headerless
+\ It doesn't matter what address this returns because it is only used
+\ as an argument to slow-next and fast-next, which do nothing.
+: low-dictionary-adr ( -- adr ) origin ( init-user-area + ) ;
+
+nuser debug-next \ Pointer to "next"
+vocabulary bug bug also definitions
+nuser 'debug \ code field for high level trace
+nuser <ip \ lower limit of ip
+nuser ip> \ upper limit of ip
+nuser cnt \ how many times thru debug next
+
+\ Since we use a shared "next" routine, slow-next and fast-next are no-op's
+alias slow-next 2drop ( high low -- )
+alias fast-next 2drop ( high low -- )
+
+label normal-next
+ ldr pc,[ip],1cell
+end-code
+
+label debnext
+ ldr r0,'user <ip
+ cmp ip,r0
+ u>= if
+ ldr r0,'user ip>
+ cmp ip,r0
+ u< if
+ ldr r0,'user cnt
+ inc r0,#1
+ str r0,'user cnt
+ cmp r0,#2
+ = if
+ mov r0,#0
+ str r0,'user cnt
+ adr r0,'body normal-next
+ str r0,'user debug-next
+ ldr pc,'user 'debug
+ then
+ then
+ then
+ ldr pc,[ip],1cell
+end-code
+
+\ Fix the next routine to use the debug version
+: pnext ( -- )
+ [ also arm-assembler ]
+ debnext up@ put-branch
+ [ previous ]
+;
+
+\ Turn off debugging
+: unbug ( -- ) normal-next @ up@ instruction! ;
+
+headers
+
+forth definitions
+unbug
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1997 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/debugm.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/decompm.fth
===================================================================
--- cpu/arm/decompm.fth (rev 0)
+++ cpu/arm/decompm.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,48 @@
+purpose: Machine/implementation-dependent decompiler support
+\ See license at end of file
+
+headerless
+
+only forth also hidden also definitions
+: dictionary-base ( -- adr ) up@ user-size + ;
+
+\ True if adr is a reasonable value for the interpreter pointer
+: reasonable-ip? ( adr -- flag )
+ dup in-dictionary? if ( ip )
+ #talign 1- and 0= \ must be token-aligned
+ else
+ drop false
+ then
+;
+
+\ Decompiler extension for 32-bit literals
+: .llit ( ip -- ip' ) ta1+ dup l@ n. la1+ ;
+: skip-llit ( ip -- ip' ) ta1+ la1+ ;
+' (llit) ' .llit ' skip-llit install-decomp
+
+only forth also definitions
+headers
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1994 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/decompm.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/disassem.fth
===================================================================
--- cpu/arm/disassem.fth (rev 0)
+++ cpu/arm/disassem.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,430 @@
+purpose: ARM disassembler - prefix syntax
+\ See license at end of file
+
+vocabulary disassembler
+also disassembler also definitions
+
+headerless
+
+variable instruction
+variable end-found
+variable display-offset 0 display-offset !
+headers
+variable dis-pc
+: (pc@ ( -- adr ) dis-pc @ ;
+defer dis-pc@ ' (pc@ is dis-pc@
+: (pc! ( adr -- ) dis-pc ! ;
+defer dis-pc! ' (pc! is dis-pc!
+: pc@l@ ( -- opcode ) dis-pc @ l@ ;
+headerless
+
+defer regs
+
+string-array (real-regs
+," r0" ," r1" ," r2" ," r3"
+," r4" ," r5" ," r6" ," r7"
+," r8" ," r9" ," r10" ," r11"
+," r12" ," r13" ," link" ," pc"
+end-string-array
+: real-regs ['] (real-regs is regs ;
+
+string-array (forth-regs
+," r0" ," r1" ," r2" ," r3"
+," r4" ," r5" ," r6" ," r7"
+," r8" ," up" ," tos" ," rp"
+," ip" ," sp" ," lr" ," pc"
+end-string-array
+: forth-regs ['] (forth-regs is regs ;
+forth-regs
+
+: udis. ( n -- )
+ push-hex
+ <#
+ u# u# u# u# u# u# u# u#
+ u#> type pop-base
+;
+' udis. is showaddr
+
+: +offset ( adr -- adr' ) display-offset @ - ;
+: >mask ( #bits -- mask ) 1 swap << 1- ;
+: bits ( right-bit #bits -- field )
+ instruction @ rot >> ( #bits shifted-instruction )
+ swap >mask and ( field )
+;
+: 4bits ( right-bit -- field ) 4 bits ;
+: bit? ( bit# -- f ) instruction @ 1 rot lshift and 0<> ;
+\ Extracts an index from the field "bit# #bits", indexes into the string
+\ "adr len", which is assumed to contain substrings of length /entry,
+\ and types the indexed substring.
+: .fld ( bit# #bits adr len /entry -- )
+ >r drop >r ( bit# #bits r: /entry adr )
+ bits ( index r: /entry adr )
+ r> swap r@ * + r> ( adr' /entry )
+ type
+;
+
+\ Display formatting
+variable start-column
+: op-col ( -- ) start-column @ d# 8 + to-column ;
+
+: .reg ( bit# -- ) 4bits regs ". ;
+: {<cond>} ( -- )
+ d# 28 4bits d# 14 = if exit then
+ d# 28 4 " eqnecsccmiplvsvchilsgeltgtle nv" 2 .fld
+;
+
+: ., ( -- ) ." , " ;
+: .[ ( -- ) ." [" ;
+: .] ( -- ) ." ]" ;
+
+: .rm ( -- ) 0 .reg ;
+: .rs ( -- ) 8 .reg ;
+: .rd, ( -- ) d# 12 .reg ., ;
+: op.rd, ( -- ) op-col .rd, ;
+: .rb ( -- ) d# 16 .reg ;
+alias .rn .rb
+
+: .rm,shift ( -- )
+ .rm
+ d# 4 8 bits if \ LSL #0 is no-shift; this isn't it
+ .,
+ 4 8 bits 6 = if ." rrx" exit then
+ 5 2 " lsllsrasrror" 3 .fld ." "
+ 4 bit? if .rs else ." #" 7 5 bits .d then
+ then
+;
+
+: u.h ( n -- ) dup d# 9 u> if ." 0x" then (u.) type ;
+: ror ( n cnt -- ) 2dup d# 32 swap - lshift -rot rshift or ;
+: .imm ( -- ) 0 8 bits 8 4bits 2* ror u.h ;
+
+: ?.bit ( adr len bit# -- ) bit? if type else 2drop then ;
+
+d# 20 constant d#20
+d# 21 constant d#21
+d# 22 constant d#22
+d# 23 constant d#23
+d# 24 constant d#24
+d# 25 constant d#25
+
+: {s} ( -- ) " s" d#20 ?.bit ;
+: {!} ( -- ) " !" d#21 ?.bit ;
+: {^} ( -- ) " ^" d#22 ?.bit ;
+: {b} ( -- ) " b" d#22 ?.bit ;
+: +/- ( -- ) d#23 bit? 0= if ." -" then ;
+
+: .r/imm ( -- )
+ d#25 bit? if ." #" .imm else .rm,shift then
+;
+\ Indicates the form of the instruction that affects both PC and CPSR/SPSR
+: {p} ( -- )
+ d#23 2 bits 3 = if \ MOV class
+ d# 12 4bits h# f = if ." p" then \ Rd is PC
+ then
+;
+: .alu ( -- )
+ d#21 4 " andeorsubrsbaddadcsbcrsctstteqcmpcmnorrmovbicmvn" 3 .fld
+ {<cond>}
+;
+: alu# ( -- n ) d#21 4bits ;
+\ control instruction extension space
+\ exceptions are encoded as tests with no setting of the condition codes
+\ OOIo oooS Rn/b Rd Rs shft Rm
+\ 00I1 0oo0
+\ BX{<cond>} Rm cond 0001 0010 SBO SBO SBO 0001 Rm
+\ MSR{<cond>} xPSR, y cond 00x1 0R10 fsxc SBO yyyy yyyy yyyy
+\ MRS{<cond>} Rd, xPSR cond 0001 0R00 SBO Rd SBZ
+
+: .psr ( -- ) d#22 bit? if ." s" else ." c" then ." psr" ;
+: .fields ( -- )
+ ." _" " cxsf" drop d# 16 4bits ( adr mask )
+ 4 0 do dup 1 and if over i + c@ emit then 2/ loop
+ 2drop
+;
+: .mrs/sr ( -- )
+ d#21 bit? if \ MSR
+ ." msr" {<cond>}
+ op-col .psr .fields ., .r/imm
+ else \ MRS
+ ." mrs" {<cond>} op.rd, .psr
+ then
+;
+: .special ( -- )
+ instruction @ h# 026f.fff0 and h# 002f.ff10 = if
+ ." bx" {<cond>} op-col .rm
+ exit
+ then
+ .mrs/sr
+;
+
+\ Arithmetic instruction extension space
+: .alu-ext ( -- )
+ d#23 bit? if \ 64-bit multiply
+ d#21 2 " umullumlalsmullsmlal" 5 .fld {<cond>} {s}
+ op-col .rn ., .rd, .rs ., .rm
+ else \ 32-bit multiply
+ d#21 2 " mulmla??????" 3 .fld {<cond>} {s}
+ op-col .rb ., .rm ., .rs
+ instruction @ h# 00200000 and if ., d# 12 .reg then
+ then
+;
+: w-bit ( -- flag ) d#21 bit? ;
+: p-bit ( -- flag ) d#24 bit? ;
+
+\ LD/ST extension space
+\ SWP{<cond>} Rd, Rm, [Rn] cond 0001 00ZZ Rn Rd SBZ 1001 Rm
+\ LDR{<cond>}{H|SH|SB} Rd, Rm, [Rn] cond 000P UBW1 Rn Rd addr 1SH1 addr
+\ STR{<cond>}{H|SH|SB} Rd, Rm, [Rn] cond 000P UBW0 Rn Rd addr 1SH1 addr
+: imm8 ( -- n ) 8 4bits 4 lshift 0 4bits or ;
+: ,.r/imm8 ( -- )
+ d#22 bit? if
+ imm8 if ., ." #" +/- imm8 u.h then
+ else
+ ., +/- .rm
+ then
+;
+: .ld/st ( -- ) d#20 bit? if ." ld" else ." st" then ;
+: .ldx ( -- )
+ .ld/st ." r" {<cond>} " s" 6 ?.bit " h" 5 ?.bit
+ op.rd,
+ .[ .rn p-bit if ,.r/imm8 .] {!} else .] ,.r/imm8 then
+;
+: .swp ( -- ) ." swp" {<cond>} " b" d#22 ?.bit op.rd, .rm ., .[ .rn .] ;
+
+: .ld/st-ext ( -- ) 5 2 bits if .ldx else .swp then ;
+
+: .ext ( -- ) \ Extension space
+ d#24 bit? 0= 5 2 bits 0= and if .alu-ext else .ld/st-ext then
+;
+
+\ Stop after changing PC
+: ?pc-change ( -- ) d# 12 4bits d# 15 = end-found ! ;
+
+: .alu-op ( -- ) \ d# 25 3 bits 0|1 =
+ d#25 bit? 0= d# 4 bit? and d# 7 bit? and if .ext exit then
+ alu# h# d and h# d = if \ Moves
+ .alu {s} op.rd, .r/imm
+ ?pc-change
+ exit
+ then
+ d#23 2 bits 2 = if \ Compares
+ d#20 bit? 0= if .special exit then
+ .alu op-col .rn ., .r/imm
+ exit
+ then
+ .alu {s} op.rd, .rn ., .r/imm
+;
+: .swi ( -- ) ." swi" op-col 0 d#24 bits u.h ;
+
+\ XXX handle muls they have 9 in the 4 4bits field, swp is one of them
+\ : ^ ( -- ) 00400000 op-or ; \ ldm stm PSR or force user-mode registers
+\ : # ( -- ) 02000000 op-or ; \ last operand is immediate
+\ : s ( -- ) 00100000 op-or ; \ flags are set according to result
+\ : t ( -- ) 00200000 op-or ; \ ldr str force -T pin
+\ : byte ( -- ) 00400000 op-or ; \ ldr str operate bytewide
+
+: .mregs ( -- )
+ ." {" ( )
+ 0 d# 16 bits false ( n need,? )
+ d# 16 0 do ( n need,? )
+ over 1 and if ( n need,? )
+ if ." , " then true ( n need,?' )
+ i regs ". ( n need,? )
+ then ( n need,? )
+ swap 2/ swap ( n need,?' )
+ loop ( n need,?' )
+ 2drop ( )
+ ." }" ( )
+;
+: .inc ( -- ) d#23 2 " daiadbib" 2 .fld ;
+: .ldm/stm ( -- ) \ d# 25 3 bits 4 =
+ .ld/st ." m" {<cond>} .inc
+ op-col .rb {!} ., .mregs {^}
+ d# 15 bit? d# 20 bit? and end-found ! \ Stop after PC change
+;
+: {t} ( -- ) p-bit 0= w-bit and if ." t" then ;
+: imm12 ( -- n ) 0 d# 12 bits ;
+: ,.addr-mode ( -- )
+ d#25 bit? if
+ ., +/- .rm,shift
+ else
+ imm12 if ., ." #" +/- imm12 u.h then
+ then
+;
+: .ldr/str ( -- ) \ d# 25 3 bits 2|3 =
+ 0 d# 28 bits h# 0e00.0010 and h# 0600.0010 = if
+ ." undefined" {<cond>}
+ exit
+ then
+ .ld/st ." r" {<cond>} {b} {t}
+ op.rd, .[ .rb
+ p-bit if ,.addr-mode .] {!} else .] ,.addr-mode then
+ ?pc-change
+;
+: .branch ( -- ) \ d# 25 3 bits 5 =
+ ." b" " l" d#24 ?.bit {<cond>}
+ d#24 bit? end-found !
+
+ op-col dis-pc@ 8 + 0 d#24 bits 8 << 6 >>a + +offset showaddr
+;
+
+: n.d ( n -- ) push-decimal <# u#s u#> type pop-base ;
+: .creg ( bit# -- ) 4bits ." cr" n.d ;
+[ifdef] dis-fp
+: .ldf/stf ( -- ) \ d# 25 3 bits 6 =
+ .ld/st ." f" ???
+;
+: .flt ( -- ) \ d# 25 3 bits 7 =
+ d#20 2 " fltfixwfsrfs" 3 .fld op-col .precision
+;
+XXX decode floating opcodes:
+ 0 8 fops adf mvf muf mnf suf abs rsf rnd
+ 8 8 fops dvf sqt rdf log pow lgn rpw exp
+10 8 fops rmf sin fml cos fdv tan frd asn
+18 4 fops pol acs ??? atn
+[then]
+: p# ( -- n ) 8 4bits ;
+: .p#, ( n -- ) ." p" p# n.d ., ;
+: .offset8 ( -- ) ." #" +/- 0 8 bits 4 * u.h ;
+: .ldc/stc ( -- )
+ .ld/st ." c" {<cond>} " l" d#22 ?.bit
+ op-col .p#, d# 12 .creg ., .[ .rn
+ p-bit if ., .offset8 .] {!} else .] ., .offset8 then
+;
+: .cptail ( -- ) d# 16 .creg ., 0 .creg ., 5 3 bits n.d ;
+
+\ Decode I/D Branch-Target/Write-Buffer Flush/Clean /Entry bits
+\ for ARM4 Cache and TLB control registers
+: .flushes ( -- )
+ 7 bit? if
+ 6 bit? if
+ ." Flush Branch Target"
+ else
+ 0 bit? if ." Flush Prefetch" else ." Drain Write" then
+ ." Buffer"
+ then
+ else
+ " Clean " 3 ?.bit " Flush " 2 ?.bit " I" 0 ?.bit " D" 1 ?.bit
+ then
+ " entry" 5 ?.bit
+;
+: .clocks ( -- ) \ For SA-110
+ 5 bit? if
+ 0 4bits case
+ 1 of ." Enable odd word loading of Icache LFSR" cr endof
+ 2 of ." Enable even word loading of Icache LFSR" cr endof
+ 4 of ." Clear Icache LFSR" endof
+ 8 of ." Move LFSR to R14.Abort" endof
+ endcase
+ else
+ 0 4bits case
+ 1 of ." Enable clock switching" endof
+ 2 of ." Disable clock switching" endof
+ 4 of ." Disable nMCLK output" endof
+ 8 of ." Wait for interrupt" endof
+ endcase
+ then
+;
+string-array scc-regs
+ ," ID"
+ ," Control"
+ ," TTBase"
+ ," Domain"
+ ," ?"
+ ," FaultStatus"
+ ," FaultAddress"
+ ," Cache"
+ ," TLB"
+ ," ?"
+ ," ?"
+ ," ?"
+ ," ?"
+ ," ?"
+ ," ?"
+ ," Test/Clock/Idle" \ SA-110
+end-string-array
+: .scc ( -- ) \ Decode ARM4 system control coprocessor register ops
+ \ Opcode1 should be 0
+ ." p15(SCC), 0, " .rd,
+ d# 16 .creg ." (" d# 16 4 bits dup scc-regs ". ." )" ( cr# )
+ dup 7 8 between if drop ., .flushes exit then
+ d# 15 = if .clocks then \ SA-110
+;
+: .coproc ( -- )
+ p-bit if .swi exit then
+ d# 4 bit? if \ MRC and MCR
+ d# 20 1 " mcrmrc" 3 .fld {<cond>}
+ op-col
+ p# d# 15 = if \ System Control Coprocessor
+ .scc
+ else
+ .p#, d# 21 3 bits n.d ., .rd, .cptail
+ then
+ else \ CDP
+ ." cdp" {<cond>}
+ op-col .p#, d# 20 4bits n.d ., d# 12 .creg ., .cptail
+ then
+;
+
+create classes
+ ['] .alu-op compile, \ 0
+ ['] .alu-op compile, \ 1 (immediate)
+ ['] .ldr/str compile, \ 2
+ ['] .ldr/str compile, \ 3 (immediate)
+ ['] .ldm/stm compile, \ 4
+ ['] .branch compile, \ 5
+ ['] .ldc/stc compile, \ 6
+ ['] .coproc compile, \ 7
+
+: disasm ( x -- )
+ push-hex
+ instruction !
+ classes d#25 3 bits ta+ token@ execute
+ pop-base
+;
+
+headers
+forth definitions
+alias disasm disasm
+: dis1 ( -- )
+ ??cr
+ dis-pc@ +offset showaddr ." : " pc@l@ udis. ." "
+ #out @ start-column !
+ pc@l@ disasm cr
+ /l dis-pc@ + dis-pc!
+;
+: +dis ( -- )
+ end-found off
+ begin dis1 end-found @ exit? or until
+;
+: dis ( adr -- ) dis-pc! +dis ;
+
+headerless
+alias (dis dis
+headers
+
+previous previous definitions
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1997 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/disassem.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/dodoesad.fth
===================================================================
--- cpu/arm/dodoesad.fth (rev 0)
+++ cpu/arm/dodoesad.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,32 @@
+purpose: Defined dodoesaddr at the appropropriate place
+\ See license at end of file
+
+\ dodoesaddr cannot be defined in KERNCODE because the user area is
+\ initialized after KERNCODE.
+\ This file should be loaded after uservars.fth
+
+tuser dodoesaddr
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/dodoesad.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/extra.fth
===================================================================
--- cpu/arm/extra.fth (rev 0)
+++ cpu/arm/extra.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,130 @@
+purpose: Additional kernel code words
+\ See license at end of file
+
+hex
+
+code (llit) ( -- lit ) psh tos,sp ldmia ip!,{tos,pc} c;
+
+code perform ( adr -- ) ldr r0,[tos] pop tos,sp mov pc,r0 end-code
+
+code hash ( str-adr voc-ptr -- thread )
+ pop r0,sp \ string
+ ldrb r0,[r0,#1]
+ #threads-t 1- #
+ and r0,r0,*
+ ldr tos,[tos,1cell] \ get user#
+ add tos,tos,up \ Get thread base address
+ add tos,tos,r0,lsl #2
+c;
+
+\ Starting at "link", which is the address of a memory location
+\ containing a link to the acf of a word in the dictionary, find the
+\ word whose name matches the string "adr len", returning the link
+\ field address of that word if found.
+
+\ Assumes the following header structure - [N] is size in bytes:
+\ pad[0-3] name-characters[n] name-len&flags[1] link[4] code-field[4]
+\ ^ ^ ^
+\ anf alf acf
+\ The link field points to the *code field* of the next word in the list.
+\ Padding is added, if necessary, before the name characters so that
+\ acf is aligned on a 4-byte boundary.
+
+code ($find-next) ( adr len link -- adr len alf true | adr len false )
+ \ !!!! the next line should ONLY be included for RiscOS Forthmacs testing
+\ adr base,'body origin
+ ldr base,[pc,`'body origin swap here 8 + - swap`]
+ ldr r5,[tos] \ link is kept in r5
+ mov tos,#0 \ false is the default return value
+
+\ cmp r5,#0 \ ?exit if link=BASE
+ cmp r5,base \ ?exit if link=BASE
+ nxteq
+ begin
+\ add r5,r5,base \ r5 absolute adr
+ dec r5,1cell \ r5 at linkfield
+ sub r2,r5,#1 \ r2 set to len/flag-adr
+ ldrb r0,[r2]
+ ands r0,r0,#0x1f \ r0: mask len of $find-next
+ 0<> if
+ ldmia sp,{r3,r4} \ r3 len; r4 adr
+
+ cmp r3,r0 \ both strings have same len?
+ 0= if
+ sub r2,r2,r3 \ r2: adr of potential $find-next
+ begin
+ decs r3,#1
+ >= while
+ ldrb r0,[r4],#1
+ ldrb r1,[r2],#1 \ compare one char each
+ cmp r0,r1 \ comm: CAPS not tested ?
+ 0<> until then
+ cmn r3,#1 \ all characters tested?
+ 0= if
+ psh r5,sp \ push link-adr ...
+ mvn tos,#0 \ ... and true
+ next
+ then
+ then
+ then
+ ldr r5,[r5]
+ cmp r5,BASE \ link = BASE ?
+ 0= until
+c;
+
+[ifdef] notdef
+code l+ ( l1 l2 -- l3 ) pop r0,sp add tos,tos,r0 c;
+code l- ( l1 l2 -- l3 ) pop r0,sp rsb tos,tos,r0 c;
+
+code lnegate ( l -- -l ) rsb tos,tos,#0 c;
+
+code labs ( l -- [l] ) cmp tos,#0 rsbmi tos,tos,#0 c;
+
+code l2/ ( l -- l/2 ) mov tos,tos,asr #1 c;
+
+code lmin ( l1 l2 -- l1|l2 ) pop r0,sp cmp tos,r0 movgt tos,r0 c;
+code lmax ( l1 l2 -- l1|l2 ) pop r0,sp cmp r0,tos movgt tos,r0 c;
+[then]
+
+code s->l ( n -- l ) c;
+code l->n ( l -- n ) c;
+code n->a ( n -- a ) c;
+code l->w ( l -- w ) mov tos,tos,lsl #16 mov tos,tos,lsr #16 c;
+code n->w ( n -- w ) mov tos,tos,lsl #16 mov tos,tos,lsr #16 c;
+
+code l>r ( l -- ) psh tos,rp pop tos,sp c;
+code lr> ( -- l ) psh tos,sp pop tos,rp c;
+
+#align-t constant #align
+#acf-align-t constant #acf-align
+#talign-t constant #talign
+
+: align ( -- ) #align (align) ;
+: taligned ( adr -- adr' ) #talign round-up ;
+: talign ( -- ) #talign (align) ;
+
+: wconstant ( "name" w -- ) header constant-cf , ;
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1997 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/extra.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/fb8-ops.fth
===================================================================
--- cpu/arm/fb8-ops.fth (rev 0)
+++ cpu/arm/fb8-ops.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,249 @@
+purpose: fb8 package support routines
+\ See license at end of file
+
+\ Rectangular regions are defined by "adr width height bytes/line".
+\ "adr" is the address of the upper left-hand corner of the region.
+\ "width" is the width of the region in pixels (= bytes, since
+\ this is the 8-bit-per-pixel package). "height" is the height of the
+\ region in scan lines. "bytes/line" is the distance in bytes from
+\ the beginning of one scan line to the beginning of the next one.
+
+\ Within the rectangular region, replace bytes whose current value is
+\ the same as fg-color with bg-color, and vice versa, leaving bytes that
+\ match neither value unchanged.
+code fb8-invert ( adr width height bytes/line fg-color bg-color -- )
+ mov r0,tos
+ ldmia sp!,{r1,r2,r3,r4,r5,tos}
+ \ r0:bg-colour r1:fg-colour r2:bytes/line r3:height r4:width r5:adr
+
+ begin
+ cmp r3,#0
+ > while
+ mov r6,#0
+ begin
+ cmp r4,r6 \ more pixels/line?
+ > while
+ ldrb r7,[r5,r6] \ get pixel colour at adr+offset
+ cmp r7,r0
+ streqb r1,[r5,r6]
+ cmp r7,r1
+ streqb r0,[r5,r6]
+ inc r6,#1
+ repeat
+ add r5,r5,r2
+ dec r3,#1
+ repeat
+c;
+
+\ Within the rectangular region, replace halfwords whose current value is
+\ the same as fg-color with bg-color, and vice versa, leaving bytes that
+\ match neither value unchanged.
+code fb16-invert ( adr width height bytes/line fg-color bg-color -- )
+ mov r0,tos
+ ldmia sp!,{r1,r2,r3,r4,r5,tos}
+ \ r0:bg-colour r1:fg-colour r2:bytes/line r3:height r4:width r5:adr
+
+ begin
+ cmp r3,#0
+ > while
+ mov r6,#0
+ begin
+ cmp r4,r6 \ more pixels/line?
+ > while
+ ldrh r7,[r5,r6] \ get pixel colour at adr+offset
+ cmp r7,r0
+ streqh r1,[r5,r6]
+ cmp r7,r1
+ streqh r0,[r5,r6]
+ inc r6,#2
+ repeat
+ add r5,r5,r2
+ dec r3,#1
+ repeat
+c;
+
+\ Within the rectangular region, replace halfwords whose current value is
+\ the same as fg-color with bg-color, and vice versa, leaving bytes that
+\ match neither value unchanged.
+code fb32-invert ( adr width height bytes/line fg-color bg-color -- )
+ mov r0,tos
+ ldmia sp!,{r1,r2,r3,r4,r5,tos}
+ \ r0:bg-colour r1:fg-colour r2:bytes/line r3:height r4:width r5:adr
+
+ begin
+ cmp r3,#0
+ > while
+ mov r6,#0
+ begin
+ cmp r4,r6 \ more pixels/line?
+ > while
+ ldr r7,[r5,r6] \ get pixel colour at adr+offset
+ cmp r7,r0
+ streq r1,[r5,r6]
+ cmp r7,r1
+ streq r0,[r5,r6]
+ inc r6,#4
+ repeat
+ add r5,r5,r2
+ dec r3,#1
+ repeat
+c;
+
+
+\ Draws a character from a 1-bit-deep font into an 8-bit-deep frame buffer
+\ Font bits are stored 1-bit-per-pixel, with the most-significant-bit of
+\ the font byte corresponding to the leftmost pixel in the group for that
+\ byte. "font-width" is the distance in bytes from the first font byte for
+\ a scan line of the character to the first font byte for its next scan line.
+code fb8-paint
+ ( fontadr fontbytes width height screenadr bytes/line fg-color bg-color -- )
+ ldmia sp!,{r1,r2,r3,r4,r5,r6,r7}
+ psh r9,sp
+\ tos:bg-col r1:fg-col r2:bytes/line r3: screeadr r4:height r5:width
+\ r6:font-width r7:fontadr
+\ free: r8 r9 r0
+ begin
+ cmp r4,#0
+ > while
+ mov r8,#0 \ r8: pixel-offset
+ begin
+ cmp r5,r8 \ one more pixel?
+ > while
+ ldrb r9,[r7,r8,lsr #3] \ r9 fontdatabyte
+ and r0,r8,#7
+ rsb r0,r0,#8
+ movs r0,r9,asr r0
+ strcsb r1,[r3,r8]
+ strccb tos,[r3,r8]
+ inc r8,#1
+ repeat
+ add r7,r7,r6 \ new font-line
+ add r3,r3,r2 \ new screen-line
+ dec r4,#1
+ repeat
+ ldmia sp!,{r9,tos}
+c;
+
+\ Draws a character from a 1-bit-deep font into a 16bpp frame buffer
+\ Font bits are stored 1-bit-per-pixel, with the most-significant-bit of
+\ the font byte corresponding to the leftmost pixel in the group for that
+\ byte. "font-width" is the distance in bytes from the first font byte for
+\ a scan line of the character to the first font byte for its next scan line.
+code fb16-paint
+ ( fontadr fontbytes width height screenadr bytes/line fg-color bg-color -- )
+ ldmia sp!,{r1,r2,r3,r4,r5,r6,r7}
+ psh r9,sp
+\ tos:bg-col r1:fg-col r2:bytes/line r3: screeadr r4:height r5:width
+\ r6:font-width r7:fontadr
+\ free: r8 r9 r0
+ begin
+ cmp r4,#0
+ > while
+ mov r8,#0 \ r8: pixel-offset
+ begin
+ cmp r5,r8 \ one more pixel?
+ > while
+ ldrb r9,[r7,r8,lsr #3] \ r9 fontdatabyte
+ and r0,r8,#7
+ rsb r0,r0,#8
+ movs r0,r9,asr r0
+ strcsh r1,[r3,r8]
+ strcch tos,[r3,r8]
+ inc r8,#2
+ repeat
+ add r7,r7,r6 \ new font-line
+ add r3,r3,r2 \ new screen-line
+ dec r4,#1
+ repeat
+ ldmia sp!,{r9,tos}
+c;
+
+\ Draws a character from a 1-bit-deep font into an 8-bit-deep frame buffer
+\ Font bits are stored 1-bit-per-pixel, with the most-significant-bit of
+\ the font byte corresponding to the leftmost pixel in the group for that
+\ byte. "font-width" is the distance in bytes from the first font byte for
+\ a scan line of the character to the first font byte for its next scan line.
+code fb32-paint
+ ( fontadr fontbytes width height screenadr bytes/line fg-color bg-color -- )
+ ldmia sp!,{r1,r2,r3,r4,r5,r6,r7}
+ psh r9,sp
+\ tos:bg-col r1:fg-col r2:bytes/line r3: screeadr r4:height r5:width
+\ r6:font-width r7:fontadr
+\ free: r8 r9 r0
+ begin
+ cmp r4,#0
+ > while
+ mov r8,#0 \ r8: pixel-offset
+ begin
+ cmp r5,r8 \ one more pixel?
+ > while
+ ldrb r9,[r7,r8,lsr #3] \ r9 fontdatabyte
+ and r0,r8,#7
+ rsb r0,r0,#8
+ movs r0,r9,asr r0
+ strcs r1,[r3,r8]
+ strcc tos,[r3,r8]
+ inc r8,#4
+ repeat
+ add r7,r7,r6 \ new font-line
+ add r3,r3,r2 \ new screen-line
+ dec r4,#1
+ repeat
+ ldmia sp!,{r9,tos}
+c;
+
+\ Similar to 'move', but only moves width out of every 'bytes/line' bytes
+\ "size" is "height" times "bytes/line", i.e. the total length of the
+\ region to move.
+
+\ bytes/line is a multiple of 8, src-start and dst-start are separated by
+\ a multiple of bytes/line (i.e. src and dst are simililarly-aligned), and
+\ src > dst (so move from the start towards the end). This makes it
+\ possible to optimize an assembly language version to use longword or
+\ doubleword operations.
+
+\ this assumes width to be also a multiple of 8
+code fb-window-move ( src-start dst-start size bytes/line width -- )
+ mov r0,tos
+ ldmia sp!,{r1,r2,r3,r4,tos}
+ \ r0:width r1: bytes/line r2:size r3:dst-start r4:src-start
+ sub r1,r1,r0 \ r1:bytes/line - width
+ add r2,r2,r4 \ r2:end-of-src-copy-region
+ begin
+ cmp r4,r2
+ < while
+ mov r7,r0 \ r7:loop-width
+ begin
+ decs r7,#8
+ ldmgeia r4!,{r5,r6}
+ stmgeia r3!,{r5,r6}
+ < until
+
+ add r4,r4,r1
+ add r3,r3,r1
+ repeat
+c;
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1997 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/fb8-ops.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/field.fth
===================================================================
--- cpu/arm/field.fth (rev 0)
+++ cpu/arm/field.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,39 @@
+purpose: Defining words for structures and fields
+\ See license at end of file
+
+\ field creates words which add their offset within the structure
+\ to the base address of the structure
+
+: struct ( -- 0 ) 0 ;
+
+: field ( "name" offset size -- offset+size )
+ create over , +
+ ;code ( struct-adr -- field-adr )
+ lnk r0
+ ldr r0,[r0]
+ add tos,tos,r0
+c;
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/field.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/filecode.fth
===================================================================
--- cpu/arm/filecode.fth (rev 0)
+++ cpu/arm/filecode.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,205 @@
+purpose: Code words to support the file system interface
+\ See license at end of file
+
+decimal
+
+\ signed mixed mode addition
+code ln+ ( l n -- l ) \ same as l+ or =
+ pop r0,sp
+ add tos,tos,r0
+c;
+
+\ &ptr is the address of a pointer. fetch the pointed-to character and
+\ post-increment the pointer.
+code @c@++ ( &ptr -- char )
+ mov r0,tos
+ ldr r1,[r0]
+ ldrb tos,[r1],#1
+ str r1,[r0]
+c;
+
+\ &ptr is the address of a pointer. store the character into
+\ the pointed-to location and post-increment the pointer
+code @c!++ ( char &ptr -- )
+ ldmia sp!,{r0,r2}
+ ldr r1,[tos]
+ strb r0,[r1],#1
+ str r1,[tos]
+ mov tos,r2
+c;
+
+: cindex ( adr len char -- [ adr' true ] | false )
+ false swap 2swap bounds ?do ( false char )
+ dup i c@ = if nip i true rot leave then
+ loop ( false char | adr' true char )
+ drop
+;
+
+[ifdef] notdef
+\ "adr1 len2" is the longest initial substring of the string "adr1 len1"
+\ that does not contain the character "char". "adr2 len1-len2" is the
+\ trailing substring of "adr1 len1" that is not included in "adr1 len2".
+\ Accordingly, if there are no occurrences of that character in "adr1 len1",
+\ "len2" equals "len1", so the return values are "adr1 len1 adr1+len1 0"
+
+: split-string ( adr1 len1 char -- adr1 len2 adr1+len2 len1-len2 )
+ >r 2dup r> cindex if ( adr1 len1 adr1+len2 )
+ dup 3 pick - ( adr1 len1 adr1+len2 len2 )
+ rot over - ( adr1 adr1+len2 len2 len1-len2 )
+ >r swap r>
+ else ( adr1 len1 )
+ 2dup + 0
+ then
+;
+
+\ : xxsplit-string ( adr1 len1 char -- adr1 len2 adr1+len2 len1-len2 )
+\ over 0= if \ degenerate
+\ drop 2dup exit
+\ then
+\ >r 2dup over + swap ( adr1 len1 adr1+len1 adr1 )
+\ begin
+\ 2dup u> while ( adr1 len1 adr1+len1 adr )
+\ count r@ = if \ found it! ( adr1 len1 adr1+len1 adr' )
+\ 1- nip 2 pick - ( adr1 len1 len2 )
+\ tuck - >r 2dup + r> ( adr1 len2 adr1+len2 len1-len2 )
+\ r> drop exit
+\ then ( adr1 len1 adr1+len1 adr )
+\ repeat ( adr1 len1 adr1+len1 adr )
+\ 2drop 2dup + 0
+\ ;
+
+
+\ Splits a buffer into two parts around the first line delimiter
+\ sequence. A line delimiter sequence is either CR, LF, CR followed by LF,
+\ or LF followed by CR.
+\ adr1 len2 is the initial substring before, but not including,
+\ the first line delimiter sequence.
+\ adr2 len3 is the trailing substring after, but not including,
+\ the first line delimiter sequence.
+decimal
+: parse-line ( adr1 len1 -- adr1 len2 adr2 len3 )
+ 2dup d# 10 cindex if \ has lf ( adr1 len1 adr-lf )
+ >r 2dup d# 13 cindex if \ has cr ( adr1 len1 adr-cr )
+ r> umin ( adr1 len1 adr-delim )
+ else \ lf only
+ r> ( adr1 len1 adr-delim )
+ then ( adr1 len1 adr-delim )
+ else \ no lf ( adr1 len1 )
+ 2dup d# 13 cindex if \ has cr ( adr1 len1 adr-cr )
+ else \ neither
+ 2dup + 0 exit
+ then
+ then ( adr1 len1 adr-delim )
+ dup 3 pick - -rot 1+ swap ( adr1 len2 adr2 len1 )
+ 2 pick - 1-
+;
+[else]
+\ "adr1 len2" is the longest initial substring of the string "adr1 len1"
+\ that does not contain the character "char". "adr2 len1-len2" is the
+\ trailing substring of "adr1 len1" that is not included in "adr1 len2".
+\ Accordingly, if there are no occurrences of that character in "adr1 len1",
+\ "len2" equals "len1", so the return values are "adr1 len1 adr1+len1 0"
+code split-string ( adr1 len1 char -- adr1 len2 adr1+len2 len1-len2 )
+ ldmia sp!,{r3,r4} \ r3: len1 r4: adr1
+ mov r1,r4 \ r1: adr1
+ add r2,r3,r4 \ r2: lastchar of string
+ mvn r0,#0
+ begin
+ cmp r1,r2
+ < while
+ ldrb r0,[r1],#1 \ getchar - postincr
+ cmp r0,tos
+ 0= until then
+ cmp r0,tos \ delimiter was found
+ deceq r1,#1 \ last non-delimiter character adr
+ \ r1: adr1 r2: *lastchar+1
+ sub r2,r1,r4 \ r2: len2
+ sub tos,r3,r2
+ add r1,r4,r2 \ r1: adr1+len2
+ stmdb sp!,{r4,r2,r1}
+c;
+
+\ Splits a buffer into two parts around the first line delimiter
+\ sequence. A line delimiter sequence is either CR, LF, CR followed by LF,
+\ or LF followed by CR.
+\ adr1 len2 is the initial substring before, but not including,
+\ the first line delimiter sequence.
+\ adr2 len3 is the trailing substring after, but not including,
+\ the first line delimiter sequence.
+code parse-line ( adr1 len1 -- adr1 len2 adr2 len3 )
+ ldr r4,[sp],1cell \ r4 adr
+ mov r1,r4 \ r1 abs adr1
+ add r2,r1,tos \ r2 abs lastchar
+ mvn r0,#0
+
+ begin
+ cmp r1,r2
+ < while
+ ldrb r0,[r1],#1
+ cmp r0,#10
+ cmpne r0,#13
+ 0= until then
+ sub r3,r1,r4 \ r3 len2
+ cmp r0,#10
+ cmpne r0,#13
+ deceq r3,1 \ correct r3
+ cmp r1,r2 \ more chars in line?
+ < if
+ ldrb tos,[r1]
+ cmp tos,#10
+ cmpne tos,#13
+ = if
+ cmpeq tos,r0 \ not the same delimiter
+ incne r1,#1
+ then
+ then
+ sub tos,r2,r1
+ stmdb sp!,{r4,r3,r1}
+c;
+[then]
+
+nuser delimiter
+
+nuser file
+
+:-h struct ( -- 0 ) 00 ;-h
+
+\ header-t (file-field)
+code-field: dofield ( -- fd+offset )
+ psh tos,sp
+ lnk r0
+ ldr r0,[r0]
+ ldr tos,'user file
+ add tos,tos,r0
+c;
+
+:-h file-field-cf ( -- ) dofield place-cf-t ;-h
+
+\ Assembles the code field when metacompiling a field
+:-h file-field ( "name" offset size -- offset )
+ " file-field-cf" header-t over ,-t + ?debug
+;-h
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/filecode.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/finish.fth
===================================================================
--- cpu/arm/finish.fth (rev 0)
+++ cpu/arm/finish.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,39 @@
+purpose: Final steps of the kernel metacompilation process
+\ See license at end of file
+
+hex
+' init is do-init
+\ ' warm-hook ' 'lastacf >user-t token!-t
+
+assembler dodoes meta is dodoesaddr
+forth-h
+
+metaoff
+
+only forth also definitions
+
+' symbols fixall
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/finish.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/float.fth
===================================================================
--- cpu/arm/float.fth (rev 0)
+++ cpu/arm/float.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,409 @@
+purpose: Forth floating point package for ARM FPU/FPE
+\ See license at end of file
+
+\ Contributed by Hanno Schwalm
+\ Implements ths ANS Forth floating and floating extended package.
+\ needs Fothmacs V. 3.1/2.12 or higher
+\ All floating point numbers are IEEE double-precision format
+\ using a seperate floating stack assigned by a user variable fp.
+
+only forth also arm-assembler also definitions
+
+: popf0 s" r7 'user fp ldr f0 r7 popf r7 'user fp str" evaluate ;
+: popf1 s" r7 'user fp ldr f1 r7 popf r7 'user fp str" evaluate ;
+: popf2 s" r7 'user fp ldr f2 r7 popf r7 'user fp str" evaluate ;
+: pushf0 s" r7 'user fp ldr f0 r7 pushf r7 'user fp str" evaluate ;
+: pushf1 s" r7 'user fp ldr f1 r7 pushf r7 'user fp str" evaluate ;
+: pushf2 s" r7 'user fp ldr f2 r7 pushf r7 'user fp str" evaluate ;
+
+only forth also system also definitions hex
+
+code @fs ( -- n ) \ get the floating status
+ top sp push
+ top rfs
+ top top 0f # and c;
+code !fs ( n -- ) \ set the floating status
+ r1 top 0f # and
+ top sp pop
+ r0 rfs
+ r0 r0 ff00 # and
+ r0 r0 r1 orr
+ r0 wfs c;
+
+nuser fbuff /float 2* ualloc drop
+: @sign ( -- f) fbuff @ 80000000 and 0<> ;
+: @esign ( -- f) fbuff @ 40000000 and 0<> ;
+: !sign ( f ) 0<> 80000000 and fbuff @ 4fffffff and or fbuff ! ;
+: !esign ( f ) 0<> 40000000 and fbuff @ 8fffffff and or fbuff ! ;
+: @nibble ( #nibb -- n2 )
+ 8 /mod swap >r cells fbuff + @ 7 r> - 4* rshift 0f and ;
+: !nibble ( #nibb n )
+ swap 8 /mod swap >r cells fbuff + ( n addr r: n-th )
+ f0000000 r@ 4* rshift -1 xor ( n addr mask r: n-th )
+ over @ and ( n addr ncont R: n-th )
+ rot 7 r> - 4* lshift or swap ! ;
+
+decimal
+
+: @exp 0 5 1 do 10 * i @nibble + loop @esign ?negate 1+ ;
+: @dig 5 + @nibble [char] 0 + ;
+
+code !flpd \ ( addr -- )
+ popf0
+ packed f0 top 3 cells ia stf double
+ top sp pop c;
+\ a packed decimal is read at addr and written to the floating stack
+code @flpd ( addr -- )
+ packed f0 top 3 cells ia ldf double
+ pushf0
+ top sp pop c;
+
+: fp-error
+ @fs 0 !fs
+ dup 2 and if -42 throw then
+ dup 13 and if -43 throw then
+ 16 and if -41 throw then abort ;
+
+arm-assembler definitions
+: c;fl \ ends a floating point code definitions with checking for errors
+ r0 rfs r0 r0 h# 0f # s and eq next ip ['] fp-error >body adr c; ;
+
+forth definitions
+: (cold-hook 0 !fs (cold-hook ; ' (cold-hook is cold-hook
+
+\ often used floating high precision constants
+code -.5E0 f0 #0.5 mnf pushf0 c;
+code -1E0 f0 #1.0 mnf pushf0 c;
+code -2E0 f0 #2.0 mnf pushf0 c;
+code -3E0 f0 #3.0 mnf pushf0 c;
+code -4E0 f0 #4.0 mnf pushf0 c;
+code -5E0 f0 #5.0 mnf pushf0 c;
+code -1E1 f0 #10.0 mnf pushf0 c;
+code 0E0 f0 #0.0 mvf pushf0 c;
+code .5E0 f0 #0.5 mvf pushf0 c;
+code 1E0 f0 #1.0 mvf pushf0 c;
+code 2E0 f0 #2.0 mvf pushf0 c;
+code 3E0 f0 #3.0 mvf pushf0 c;
+code 4E0 f0 #4.0 mvf pushf0 c;
+code 5E0 f0 #5.0 mvf pushf0 c;
+code 1E1 f0 #10.0 mvf pushf0 c;
+
+code f+ ( f1 f2 -- f3 ) popf0 popf1 f0 f1 f0 adf pushf0 c;fl
+code f- ( f1 f2 -- f3 ) popf0 popf1 f0 f1 f0 suf pushf0 c;fl
+code f* ( f1 f2 -- f3 ) popf0 popf1 f0 f1 f0 muf pushf0 c;fl
+code f/ ( f1 f2 -- f3 ) popf0 popf1 f0 f1 f0 dvf pushf0 c;fl
+code f** ( f1 f2 -- f3 ) popf0 popf1 f0 f1 f0 pow pushf0 c;fl
+code fmod ( f1 f2 -- f3 ) popf0 popf1 f0 f1 f0 rmf pushf0 c;fl
+code fsin ( f1 -- f2 ) popf0 f0 f0 sin pushf0 c;fl
+code fasin ( f1 -- f2 ) popf0 f0 f0 asn pushf0 c;fl
+code fcos ( f1 -- f2 ) popf0 f0 f0 cos pushf0 c;fl
+code fsincos ( f1 -- f2 f3 ) popf0 f1 f0 sin f2 f0 cos pushf0 pushf1 c;fl
+code facos ( f1 -- f2 ) popf0 f0 f0 acs pushf0 c;fl
+code ftan ( f1 -- f2 ) popf0 f0 f0 tan pushf0 c;fl
+code fatan ( f1 -- f2 ) popf0 f0 f0 atn pushf0 c;fl
+code fln ( f1 -- f2 ) popf0 f0 f0 lgn pushf0 c;fl
+code flnp1 ( f1 -- f2 ) popf0 f0 f0 #1.0 adf f0 f0 lgn pushf0 c;fl
+code flog ( f1 -- f2 ) popf0 f0 f0 log pushf0 c;fl
+code falog ( f1 -- f2 ) popf0 f0 #10.0 f0 pow pushf0 c;fl
+code fsqrt ( f1 -- f2 ) popf0 f0 f0 sqt pushf0 c;fl
+code fexp ( f1 -- f2 ) popf0 f0 f0 exp pushf0 c;fl
+code fexpm1 ( f1 -- f2 ) popf0 f0 f0 exp f0 f0 #1.0 suf pushf0 c;fl
+code fabs ( f1 -- absf1 ) popf0 f0 f0 abs pushf0 c;fl
+code fnegate ( f1 -- -f1 ) popf0 f0 f0 mnf pushf0 c;fl
+code floor ( f1 -- f2 ) popf0 -infinity f0 f0 rnd nearest pushf0 c;fl
+code fround ( f1 -- f2 ) popf0 f0 f0 rnd pushf0 c;fl
+code fhyp ( f1 -- 1/f1) popf0 f0 f0 #1.0 rdf pushf0 c;fl
+code sf@ ( sf-addr ) ( f: --sf )
+ single f0 top popf
+ double pushf0
+ top sp pop c;fl
+code sf!
+ double popf0
+ single f0 top pushf
+ double top sp pop c;fl
+
+: facosh ( f1 -- f2 ) fhyp facos ;
+: fasinh ( f1 -- f2 ) fhyp fasin ;
+: fatan2 ( f1 f2 -- f3 ) f/ fatan ;
+: fatanh ( f1 -- f2 ) fhyp fatan ;
+: fsinh ( f1 -- f2 ) fsin fhyp ;
+: ftanh ( f1 -- f2 ) ftan fhyp ;
+
+
+code f< ( f1 f2 -- | f )
+ top sp push popf1 popf0
+ f0 f1 cmfe
+ top -1 # lt mov top 0 # ge mov c;fl
+code f> ( f1 f2 -- | f )
+ top sp push popf1 popf0
+ f0 f1 cmfe
+ top -1 # gt mov top 0 # le mov c;fl
+code f= ( f1 f2 -- | f)
+ top sp push popf1 popf0
+ f0 f1 cmf
+ top -1 # eq mov top 0 # ne mov c;fl
+code f<> ( f1 f2 -- | f)
+ top sp push popf1 popf0
+ f0 f1 cmf
+ top -1 # ne mov top 0 # eq mov c;fl
+code f0= top sp push popf0
+ f0 #0.0 cmfe
+ top -1 # eq mov top 0 # ne mov c;fl
+code f0< top sp push popf0
+ f0 #0.0 cmfe
+ top -1 # lt mov top 0 # ge mov c;fl
+code f0> top sp push popf0
+ f0 #0.0 cmfe
+ top -1 # gt mov top 0 # le mov c;fl
+
+code fdup ( f1 -- f1 f1 )
+ r2 'user fp ldr
+ r0 r1 2 r2 ia ldm
+ r0 r1 2 r2 db! stm
+ r2 'user fp str c;
+code fdrop ( f1 -- )
+ r0 'user fp ldr
+ r0 2 cells incr
+ r0 'user fp str c;
+code fswap ( f1 f2 -- f2 f1 )
+ r4 'user fp ldr
+ r0 r1 r2 r3 4 r4 ia! ldm
+ r0 r1 2 r4 db! stm
+ r2 r3 2 r4 db! stm c;
+code frot ( f1 f2 f3 -- f2 f3 f1 )
+ r6 'user fp ldr
+ r0 r1 r2 r3 r4 r5 6 r6 ia! ldm
+ r2 r3 2 r6 db! stm
+ r4 r5 2 r6 db! stm
+ r0 r1 2 r6 db! stm c;
+code f-rot ( f1 f2 f3 -- f3 f1 f2 )
+ r6 'user fp ldr
+ r0 r1 r2 r3 r4 r5 6 r6 ia! ldm
+ r4 r5 2 r6 db! stm
+ r0 r1 r2 r3 4 r6 db! stm c;
+code f2dup ( f1 f2 -- f1 f2 f1 f2 )
+ r6 'user fp ldr
+ r0 r1 r2 r3 4 r6 ia ldm
+ r0 r1 r2 r3 4 r6 db! stm
+ r6 'user fp str c;
+code fover ( f1 f2 -- f1 f2 f1 )
+ r6 'user fp ldr
+ r2 r6 /float # add
+ r0 r1 2 r2 ia ldm
+ r0 r1 2 r6 db! stm
+ r6 'user fp str c;
+code n>f ( n -- ) \ n is converted to a float
+ f0 top flt
+ pushf0
+ top sp pop c;
+code f>n ( -- n ) \ takes a float and converts it to n
+ popf0
+ top sp push
+ top f0 fix c;
+code fmin popf0 popf1
+ f0 f1 cmfe
+ 0< if pushf0 else pushf1 then c;fl
+code fmax popf0 popf1
+ f0 f1 cmfe
+ 0> if pushf0 else pushf1 then c;fl
+
+code f~ ( f: f1 f2 f3 -- ) ( -- flag )
+ popf2 popf1 popf0
+ top sp push
+ top 0 # mov
+ f2 #0.0 cmfe
+gt if f3 f0 f1 suf
+ f3 f3 abs
+ f3 f2 cmfe
+ top -1 # lt mov
+ else f2 #0.0 cmf
+ eq if f0 f2 cmf
+ top -1 # eq mov
+ else f3 f0 abs
+ f4 f1 abs
+ f3 f3 f4 adf
+ f3 f3 f2 muf
+ f0 f0 f1 suf
+ f0 f0 abs
+ f0 f3 cmfe
+ top -1 # lt mov
+ then
+ then c;fl
+
+: d>f ( d -- ) ( f: -- f-d )
+ dup 0< >r dabs ?dup
+ if n>f [ 2E0 32 n>f f** ] fliteral f* else 0E0 then
+ dup h# 7fffffff and n>f f+
+ h# 80000000 and if [ 2E0 31 n>f f** ] fliteral f+ then
+ r> if fnegate then ;
+: f>d 0 !fs fdup f>n @fs
+ if drop 0 !fs
+ fdup f0< >r fabs fdup [ 2E0 32 n>f f** fdup ]
+ fliteral fmod f>n fliteral f/ f>n r> ?dnegate
+ else fdrop s>d
+ then ;
+: fdepth fp0 @ fp@ - 3 rshift ;
+
+: represent \ ( c-addr cnt -- exponent sign ok? )
+ 2dup [char] 0 fill
+ 19 min fbuff !flpd
+ @fs b# 1101 and if drop 0 false exit then
+ dup 19 < over 19 min @dig [char] 4 > and
+ ( c-addr cnt round )
+ -rot 1- 0 swap
+ do over i @dig swap
+ if 1+ dup [char] 9 >
+ if drop [char] 0 else rot drop 0 -rot then
+ then
+ over i + c!
+ -1 +loop
+ @exp swap
+ rot if [char] 1 swap c! 1+ else drop then
+ @sign true ;
+: >float \ ( addr u -- flag )
+ 0 !fs fbuff 3 cells erase
+ over c@ [char] - = dup !sign if next-char then
+ over c@ [char] + = if next-char then
+ begin over c@ [char] 0 = while next-char repeat
+ over 0 2swap 2dup bounds
+ ( c-addr c-len e-addr e-len to-char from-char )
+ ?do next-char i c@ [char] E <> if 2swap char+ 2swap else leave then
+ loop ( f-addr f-len e-addr e-len )
+ \ now the floating-number string has been split into the digits
+ \ and the exponent part
+ \ first the exponent is calculated
+ over c@ [char] - = dup >r if next-char then
+ over c@ [char] + = if next-char then
+ 0. 2swap >number
+ if r> 3drop 3drop false exit else 2drop r> ?negate then >r
+ \ exponent is left on the return-stack
+ \ skip leading nulls
+ begin over c@ [char] 0 = while next-char repeat
+ \ look for exponent correction
+ 2dup -1 -rot bounds ?do i c@ [char] . = ?leave 1+ loop r> + >r
+ over c@ [char] . = \ skip leading dots or nulls
+ if next-char begin over c@ [char] 0 = while r> 1- >r next-char repeat
+ then
+ r@ 0< !esign r> abs 1 4 do 10 /mod i rot !nibble -1 +loop drop
+ ( f-addr f-len )
+ 5 -rot bounds ( nibble to from )
+ ?do i c@ [char] 0 [char] 9 between if dup i c@ [char] 0 - !nibble 1+ then
+ loop drop
+ fbuff @flpd @fs 0= 0 !fs ;
+
+: fdigit? ( char -- flag )
+ dup [char] 0 [char] 9 between ( char flag )
+ over [char] E = or over [char] . = or
+ over [char] + = or swap [char] - = or ;
+: fnumber? ( string -- string false | f true )
+ true over count bounds ( string true to from )
+ ?do i c@ fdigit? 0= if drop false leave then loop
+ if dup count >float if drop true else false then
+ else false
+ then ;
+: float, ( f -- ) here /float allot f! ;
+
+
+: fvariable create /float allot ;
+: fconstant create float,
+ ;code
+ r7 get-link
+ r0 r1 2 r7 ia ldm
+ r2 'user fp ldr
+ r0 r1 2 r2 db! stm
+ r2 'user fp str c;
+
+3 actions" obj. floatval"
+ action: f@ ;
+ action: f! ;
+ action: ;
+: floatval \ ( F: f1 -- )
+ create here /float allot f!
+ use-actions ;
+
+alias falign align
+alias faligned aligned
+alias df! f!
+alias df@ f@
+alias dfalign align
+alias dfaligned aligned
+alias sfalign align
+alias sfaligned aligned
+alias dfloat+ float+
+alias dfloats floats
+alias sfloat+ cell+
+alias sfloats cells
+
+5 constant precision
+: set-precision ( n -- )
+ 1 max 250 min is precision ;
+: fs. ( f: r -- )
+ astring dup precision represent ( buffer exponent sign ok? )
+ 0= if fp-error then
+ if ." -" then >r dup c@ emit ." ." char+ precision 1- type
+ ." E" r> 1- .d ;
+: fe. ( f: r -- )
+ astring dup precision represent ( buffer exponent sign ok? )
+ 0= if fp-error then
+ if ." -" then 1+ >r
+ dup r@ 1+ 3 mod 1+ dup >r type ." ." r@ + precision r> - type
+ ." E" r> 1+ 3 / 1- 3 * .d ;
+: f. ( f: r -- )
+ astring dup precision represent ( buffer exponent sign ok? )
+ 0= if fp-error then
+ if ." -" then dup 0<=
+ if ." 0." abs 0 ?do ." 0" loop precision type
+ else 2dup type ." ." tuck + swap precision - dup 0< ( addr cnt f )
+ if abs type else 2drop ." 0" then
+ then ;
+: .fs ( -- ) \ displays floating stack
+ fp0 @
+ begin /float - dup fp@ >=
+ while dup f@ fs.
+ repeat drop ;
+
+: floats-on ['] fnumber? is fliteral? ;
+: floats-off ['] false is fliteral? ;
+
+floats-on
+environment: floating true ;
+environment: floating-ext true ;
+environment: floating-stack [ fs-size /float / ] literal ;
+environment: max-float 1.79769313486231571E+308 ;
+3.1415926535897932384E0 fconstant PI
+floats-off
+
+
+\ floating point decompiler support
+[ifdef] see
+ only forth also hidden also definitions
+ : .finline (s ip -- ip' ) cell+ dup f@ fs. cell+ cell+ ;
+ : skip-finline (s ip -- ip' ) cell+ float+ ;
+ ' (flit) ' .finline ' skip-finline install-decomp
+[then]
+
+only forth also definitions
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2008 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/float.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/forthint.fth
===================================================================
--- cpu/arm/forthint.fth (rev 0)
+++ cpu/arm/forthint.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,176 @@
+purpose: Low-level handler for alarm interrupt
+\ See license at end of file
+
+headerless
+
+\ Interfaces to system-dependent routines
+defer set-tick-limit ( #msecs -- ) \ Setup tick interrupt source
+defer init-dispatcher ( -- )
+defer dispatch-interrupt ' noop to dispatch-interrupt
+
+0 value intsave
+h# 1300 constant /intstack
+
+\ The interrupt save/stack area is laid out as follows:
+\ 0000 - register save area (size h#44)
+\ 0044 - data stack area (size h#1100-h#44)
+\ 1100 - return stack area (size h#200)
+\ 1300 - <end>
+\
+\ The register save area, which is exported to the client program via the
+\ "tick" callback, contains the following registers, all from the interrupted
+\ context:
+\ 00 - psr
+\ 04 - r0
+\ 08 - r1
+\ ...
+\ 38 - r13 (sp)
+\ 3c - r14 (lr)
+\ 40 - r15 (pc)
+\
+\ When the interrupt handler returns, the complete context is restored from
+\ the save area. The client program can cause a context switch by modifying
+\ these saved valued.
+
+hex
+
+: ?call-os ( -- ) intsave " tick" ($callback1) ;
+
+code interrupt-return ( -- )
+
+ \ At the first indication of a keyboard abort, we branch to the
+ \ Forth entry trap handler. We do the actual branch after we have
+ \ restored all the state, so it appears as if Forth were entered
+ \ directly from the program that was running, rather than through
+ \ the interrupt handler.
+
+ mov r3,#0 \ Clear derived abort flag
+ ldr r5,'user aborted? \ Abort flag
+
+ cmp r5,#1
+ = if
+ \ Don't abort in the middle of the terminal emulator, because
+ \ it's not reentrant.
+
+ ldr r4,'user terminal-locked?
+ cmp r4,#0
+
+ \ Increment the abort flag past 1 so that we won't see it again
+ \ until the interpreter has seen and cleared it.
+ inceq r5,#1
+ streq r5,'user aborted?
+ mvneq r3,#0 \ Set derived abort flag
+ then
+
+ mov r13,r3 \ Put derived flag in a safe place
+
+ ldr r0,'user intsave \ Address of interrupt save area
+
+ ldr r1,[r0] \ Saved SPSR from offset 0
+ msr spsr,r1 \ Restore it
+
+ mrs r2,cpsr \ Remember the current mode
+ tst r1,#0xf \ Check for user mode
+ orreq r1,r1,#0xf \ Set system mode if mode was user
+ orr r1,r1,#0x80 \ Disable interrupts
+ msr cpsr,r1 \ Sneak into the other mode
+
+ ldr r13,[r0,#56] \ Restore old SP
+ ldr r14,[r0,#60] \ Restore old LR
+ msr cpsr,r2 \ Return to the interrupt mode
+
+ ldr r14,[r0,#64] \ Restore PC to LR
+
+ ldmib r0,{r0,r1,r2,r3,r4,r5,r6,r7,r8,r9,r10,r11,r12}
+
+ \ Now the registers are back to the state that existed upon entry to
+ \ the interrupt handler. We can use only r13 in the following code.
+
+ cmp r13,#0 \ Test abort flag
+ moveqs pc,r14 \ Return from interrupt
+
+ adr r13,'body main-task \ Get user pointer address
+ ldr r13,[r13] \ Get user pointer
+ ldr r13,[r13,`'user# cpu-state`] \ State save address
+
+ stmia r13,{r0,r1,r2,r3,r4,r5,r6,r7,r8,r9,r10,r11,r12}
+
+ mov r0,r13 \ Move cpu-state pointer into r0
+ mvn r4,#0 \ Set r4 to -1 to indicate a user abort
+ b 'body save-common
+end-code
+
+: interrupt-handler dispatch-interrupt interrupt-return ;
+
+label interrupt-preamble
+\ here also hidden hwbp previous
+ adr r13,'body main-task \ Get user pointer address
+ ldr r13,[r13] \ Get user pointer
+ ldr r13,[r13,`'user# intsave`] \ Address of interrupt save area
+
+ stmib r13,{r0,r1,r2,r3,r4,r5,r6,r7,r8,r9,r10,r11,r12}
+ mov r0,r13 \ Switch to r0 for the save pointer
+
+ mrs r1,spsr
+ str r1,[r0] \ Save SPSR at offset 0
+ dec r14,#4 \ Account for pipeline
+ str r14,[r0,#64] \ Save PC at offset 64
+
+ \ Sneak into the old mode to pick up its r13 and r14
+ mrs r2,cpsr \ Remember the current mode
+ tst r1,#0xf \ Check for user mode
+ orreq r1,r1,#0xf \ Set system mode if mode was user
+ orr r1,r1,#0x80 \ Disable interrupts
+ msr cpsr,r1 \ Get into the old mode
+
+ str r13,[r0,#56] \ Save old SP
+ str r14,[r0,#60] \ Save old LR
+ msr cpsr,r2 \ Return to the interrupt mode
+
+ \ Set up Forth stacks
+ add rp,r0,`/intstack #` \ Return stack pointer
+ sub sp,rp,#0x204 \ Data stack pointer (w/top of stack)
+
+ adr up,'body main-task \ Get user pointer address
+ ldr up,[up] \ Get user pointer
+
+ adr ip,'body interrupt-handler
+c;
+
+: install-alarm ( -- )
+ /intstack alloc-mem to intsave
+ intsave /intstack erase \ Paranoia
+ disable-interrupts
+ [ also hidden ]
+ interrupt-preamble 6 install-handler
+ init-dispatcher
+ [ previous ]
+ d# 10 set-tick-limit
+ enable-interrupts \ Turn interrupts on
+;
+
+headers
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1997 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/forthint.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/ftrace.fth
===================================================================
--- cpu/arm/ftrace.fth (rev 0)
+++ cpu/arm/ftrace.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,33 @@
+purpose: Display a Forth stack backtrace
+\ See license at end of file
+
+only forth also hidden also forth definitions
+: ftrace ( -- ) \ Forth stack
+ ip >saved .traceline
+ rp >saved rssave-end swap (rstrace
+;
+only forth also definitions
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1997 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/ftrace.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/getms.fth
===================================================================
--- cpu/arm/getms.fth (rev 0)
+++ cpu/arm/getms.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,77 @@
+purpose: Interval timing functions
+\ See license at end of file
+
+headerless
+
+0 value tick-msecs
+: (get-msecs) ( -- n ) tick-msecs ;
+' (get-msecs) to get-msecs
+
+d# 10 value ms/tick
+d# 78,764 constant ms-factor
+0 value us-factor
+
+code spins ( count -- )
+ cmp tos,#0
+ <> if
+ begin
+ subs tos,tos,#1
+ 0= until
+ then
+ pop tos,sp
+c;
+: 1ms ( -- ) ms-factor spins ;
+
+: us ( #microseconds -- ) us-factor * spins ;
+
+: (ms) ( #ms -- )
+ dup ms/tick 3 * u> interrupts-enabled? and if ( #ms )
+ \ For relatively long durations, we use the ticker because it is
+ \ presumed to be reasonably accurate over the long run. However,
+ \ if interrupts are not enabled, we can't use the ticker because
+ \ it won't be ticking.
+
+ get-msecs + ( target )
+
+ \ We use "- 0<" instead of "<" so that the right thing will happen
+ \ when the tick count wraps around.
+ \ We use "0<" instead of "0<=" so that we are sure to wait at least
+ \ the requested time; otherwise we might not wait long enough if the
+ \ first call to get-msecs were to occur just before the timer ticked.
+ begin dup get-msecs - 0<= until \ Loop until target time reached
+
+ drop ( )
+ else ( #ms )
+ \ For relatively short durations, we use a timing loop because
+ \ the ticker probably has rather coarse granularity.
+
+ 0 ?do ms-factor spins loop
+ then
+;
+' (ms) to ms
+
+headers
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1997 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/getms.fth
___________________________________________________________________
Added: svn:executable
+ *
Property changes on: cpu/arm/inflate
___________________________________________________________________
Added: svn:executable
+ *
Added: svn:mime-type
+ application/octet-stream
Added: cpu/arm/inflater.fth
===================================================================
--- cpu/arm/inflater.fth (rev 0)
+++ cpu/arm/inflater.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,35 @@
+purpose: Inflater in the dictionary
+\ See license at end of file
+
+headerless
+create (inflater) " ${BP}/cpu/arm/inflate" $file,
+
+: (got-inflater) (inflater) 0 to inflater ;
+' (got-inflater) to get-inflater
+
+' noop to release-inflater
+headers
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1997 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/inflater.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/initpgm.fth
===================================================================
--- cpu/arm/initpgm.fth (rev 0)
+++ cpu/arm/initpgm.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,43 @@
+purpose: Generic tools for load image handlers
+\ See license at end of file
+
+: (init-program) ( pc sp -- )
+ clear-save-area state-valid on
+ \ PowerPC calling conventions store the link register at SP+8,
+ \ so we start with r1 a little below the top of the allocated region
+ to sp to pc
+ cif-handler to r0
+
+ h# 53 to psr \ IRQ enabled, FIQ disabled, SVC_32 mode
+
+ restartable? on
+ true to already-go?
+;
+
+: +base ( n -- adr ) load-base + ;
+
+headers
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1995 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/initpgm.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/kerncode.fth
===================================================================
--- cpu/arm/kerncode.fth (rev 0)
+++ cpu/arm/kerncode.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,1224 @@
+purpose: Kernel Primitives for ARM-Risc Processors ARM2 ARM250 ARM3 ARM4
+\ See license at end of file
+
+\ Allocate and clear the initial user area image
+mlabel init-user-area setup-user-area
+
+\ We create the shared code for the "next" routine so that:
+\ a) It will be in RAM for speed (ROM is often slow)
+\ b) We can use the user pointer as its base address, for quick jumping
+
+also forth
+compilation-base here-t \ Save meta dictionary pointer
+\ Use the first version if the user area is separate from the dictionary
+\ 0 dp-t ! userarea-t is compilation-base \ Point it to user area
+userarea-t dp-t ! \ Point it to user area
+previous
+
+code-field: (next) \ Shared code for next; will be copied into user area
+\ also meta assembler
+ ldr pc,[ip],/token
+end-code
+\ previous
+
+also forth
+dp-t ! is compilation-base previous \ Restore meta dict. pointer
+
+d# 32 equ #user-init \ Leaves space for the shared "next"
+
+hex meta assembler definitions
+\ New: the following 3 definitions aren't in this file
+
+\ The first version is for in-line NEXT
+\ :-h next ldr pc,[ip],/token ;-h
+:-h next " mov pc,up" evaluate ;-h
+:-h c; next end-code ;-h
+caps on
+\ also register-names definitions
+\ :-h base r7 ;-h
+\ previous
+
+\ Run-time actions for defining words:
+\ In the Acorn-ARM2/250/3 implementation all words but code definitions are
+\ called by a branch+link instruction. It branches to a relative-inline-
+\ address and leaves the old pc/pcr in the link register r14.
+\ The pfa of the word is just after the branch+link instruction.
+\ bic r0,link,#0xfc000003 or using the lnk macro
+\ lnk r0
+\ Both instructions read the pfa to r0
+
+meta definitions
+code-field: douser
+ psh tos,sp
+ lnk r0
+ ldr r0,[r0]
+ add tos,r0,up
+c;
+code-field: dodoes
+ psh ip,rp
+ lnk ip
+c;
+code-field: dovalue
+ psh tos,sp
+ lnk r0
+ ldr r0,[r0]
+ ldr tos,[up,r0]
+c;
+code-field: docolon
+ psh ip,rp
+ lnk ip
+c;
+code-field: doconstant
+ psh tos,sp
+ lnk r0
+ ldr tos,[r0]
+c;
+code-field: dodefer
+ lnk r0
+ ldr r0,[r0]
+ ldr pc,[r0,up]
+end-code
+code-field: do2constant
+ lnk r0
+
+ ldmia r0,{r1,r2}
+ stmdb sp!,{r1,tos}
+ mov tos,r2
+c;
+code-field: docreate
+ psh tos,sp
+ lnk tos
+c;
+
+code-field: dovariable
+ psh tos,sp
+ lnk tos
+c;
+
+\ New: dopointer (identical to doconstant)
+\ New: dobuffer (identical to doconstant)
+
+:-h compvoc compile-t <vocabulary> ;-h
+code-field: dovocabulary
+ ldr pc,[pc,#-4]
+end-code
+compvoc \ cfa of vocabulary is compiled here
+
+\ New: :-h syscall:
+
+\ Meta compiler words to compile code fields for child words
+:-h place-cf-t \ ( adr -- ) compile a branch+link to adr
+ here-t - 2/ 2/ 2- 00ffffff and eb000000 or l,-t
+;-h
+
+\ psh tos,sp bic tos,lk,#0xfc00.0003
+\ :-h push-pfa ( -- ) e52da004 , e3cea3ff , ;-h
+\ psh tos,sp mov tos,lk
+:-h push-pfa ( -- ) e52da004 , e1a0a00e , ;-h
+:-h code-cf ( -- ) ;-h
+:-h startdoes ( -- ) push-pfa
+ dodoes place-cf-t ;-h
+:-h start;code ( -- ) ;-h \ ???
+:-h colon-cf ( -- ) docolon place-cf-t ;-h
+:-h constant-cf ( -- ) doconstant place-cf-t ;-h
+\ New: :-h buffer-cf ( -- ) dobuffer place-cf-t ;-h
+\ New: :-h pointer-cf ( -- ) dopointer place-cf-t ;-h
+:-h create-cf ( -- ) docreate place-cf-t ;-h
+:-h variable-cf ( -- ) dovariable place-cf-t ;-h
+:-h user-cf ( -- ) douser place-cf-t ;-h
+:-h value-cf ( -- ) dovalue place-cf-t ;-h
+:-h defer-cf ( -- ) dodefer place-cf-t ;-h
+:-h 2constant-cf ( -- ) do2constant place-cf-t ;-h
+:-h vocabulary-cf ( -- ) dovocabulary place-cf-t ;-h
+
+meta definitions
+
+code (lit) ( -- lit )
+ psh tos,sp
+ ldr tos,[ip],1cell
+c;
+code (dlit) ( -- d )
+ ldmia ip!,{r0,r1}
+ stmdb sp!,{r1,tos}
+ mov tos,r0
+c;
+code execute ( cfa -- )
+ mov r0,tos
+ pop tos,sp
+ mov pc,r0
+end-code
+code ?execute ( cfa|0 -- )
+ movs r0,tos
+ pop tos,sp
+ movne pc,r0
+c;
+code @execute ( adr -- )
+ ldr r0,[tos]
+ pop tos,sp
+ mov pc,r0
+end-code
+
+\ Run-time actions for compiling words
+
+code branch ( -- )
+\rel ldr r0,[ip]
+\rel add ip,ip,r0
+\abs ldr ip,[ip]
+c;
+
+code ?branch ( flag -- )
+ cmp tos,#0
+ pop tos,sp
+ addne ip,ip,1cell
+\rel ldreq r0,[ip]
+\rel addeq ip,ip,r0
+\abs ldreq ip,[ip]
+c;
+
+code ?0=branch ( flag -- )
+ cmp tos,#0
+ pop tos,sp
+ inceq ip,1cell
+\rel ldrne r0,[ip]
+\rel addne ip,ip,r0
+\abs ldrne ip,[ip]
+c;
+
+
+code (loop) ( -- )
+ ldr r0,[rp]
+ incs r0,1
+ strvc r0,[rp]
+\rel ldrvc r0,[ip]
+\rel addvc ip,ip,r0
+\abs ldrvc ip,[ip]
+ ldrvc pc,[ip],1cell
+ inc rp,3cells
+ inc ip,1cell
+c;
+
+code (+loop) ( n -- )
+ ldr r0,[rp]
+ adds r0,r0,tos
+ strvc r0,[rp]
+ pop tos,sp
+\rel ldrvc r0,[ip]
+\rel addvc ip,ip,r0
+\abs ldrvc ip,[ip]
+ ldrvc pc,[ip],1cell
+ inc rp,3cells
+ inc ip,1cell
+c;
+
+code (do) ( l i -- )
+ mov r0,tos
+ ldmia sp!,{r1,tos} ( r: loop-end-offset l+0x8000 i-l-0x8000 )
+ psh ip,rp \ save the do offset address
+ inc ip,1cell
+ inc r1,#0x80000000
+ sub r0,r0,r1
+ stmdb rp!,{r0,r1}
+c;
+
+code (?do) ( l i -- )
+ mov r0,tos
+ ldmia sp!,{r1,tos}
+ cmp r1,r0
+\rel ldreq r0,[ip]
+\rel addeq ip,ip,r0
+\abs ldreq ip,[ip]
+ ldreq pc,[ip],1cell
+ ( r: loop-end-offset l+0x8000 i-l-0x8000 )
+ psh ip,rp \ save the do offset address
+ inc ip,1cell
+ inc r1,#0x80000000
+ sub r0,r0,r1
+ stmdb rp!,{r0,r1}
+c;
+
+code i ( -- n )
+ psh tos,sp
+ ldmia rp,{r0,r1}
+ add tos,r1,r0
+c;
+code ilimit ( -- n )
+ psh tos,sp
+ ldr tos,[rp],1cell
+ inc tos,#0x80000000
+c;
+code j ( -- n )
+ psh tos,sp
+ add r2,rp,3cells
+ ldmia r2,{r0,r1}
+ add tos,r1,r0
+c;
+code jlimit ( -- n )
+ psh tos,sp
+ ldr tos,[rp],4cells
+ inc tos,#0x80000000
+c;
+
+code (leave) ( -- )
+ inc rp,2cells \ get rid of the loop indices
+ ldr ip,[rp],1cell
+\rel ldr r0,[ip] \ branch
+\rel add ip,ip,r0
+\abs ldr ip,[ip]
+c;
+
+code (?leave) ( f -- )
+ cmp tos,#0
+ pop tos,sp
+ ldreq pc,[ip],1cell
+ inc rp,2cells \ get rid of the loop indices
+ ldr ip,[rp],1cell
+\rel ldr r0,[ip] \ branch
+\rel add ip,ip,r0
+\abs ldr ip,[ip]
+c;
+
+code unloop ( -- ) inc rp,3cells c; \ Discard the loop indices
+
+\ Run time code for the case statement
+code (of) ( selector test -- [ selector ] )
+ mov r0,tos
+ pop tos,sp
+ cmp tos,r0
+\rel ldrne r0,[ip]
+\rel addne ip,ip,r0
+\abs ldrne ip,[ip]
+ nxtne
+ pop tos,sp
+ inc ip,1cell
+c;
+
+\ (endof) is the same as branch, and (endcase) is the same as drop,
+\ but redefining them this way makes the decompiler much easier.
+code (endof) ( -- )
+\rel ldr r0,[ip]
+\rel add ip,ip,r0
+\abs ldr ip,[ip]
+c;
+
+code (endcase) ( n -- ) pop tos,sp c;
+
+code digit ( char base -- digit trueļæ½| char false )
+ mov r0,tos \ r0 base
+ ldr r1,[sp] \ r1 char
+ and r1,r1,#0xff
+ cmp r1,#0x41 \ ascii A
+ >= if
+ cmp r1,#0x5b \ ascii [
+ inclt r1,#0x20
+ then
+ mov tos,#0 \ tos false
+ decs r1,#0x30
+ nxtlt
+ cmp r1,#10
+ >= if
+ cmp r1,#0x31
+ nxtlt
+ dec r1,#0x27
+ then
+ cmp r1,r0
+ nxtge
+ str r1,[sp]
+ mvn tos,#0 \ tos true
+c;
+
+code cmove ( from to cnt -- )
+ movs r0,tos \ r0 cnt
+ ldmia sp!,{r1,r2,tos}
+ nxteq
+[ifndef] fixme
+ cmp r1,r2
+ nxteq
+[then]
+ begin
+ ldrb r3,[r2],#1
+ strb r3,[r1],#1
+ decs r0,1
+ 0= until
+c;
+code cmove> ( from to cnt -- )
+ movs r0,tos \ r0 cnt
+ ldmia sp!,{r1,r2,tos}
+ nxteq
+[ifndef] fixme
+ cmp r1,r2
+ nxteq
+[then]
+ begin
+ decs r0,1
+ ldrb r3,[r2,r0]
+ strb r3,[r1,r0]
+ 0= until
+c;
+[ifdef] use-slow-move
+: move ( src dst len -- )
+ >r 2dup u> if r> cmove else r> cmove> then
+;
+[else]
+code move ( src dst cnt -- )
+ movs r0,tos
+ ldmia sp!,{r1,r2,tos}
+ nxteq
+ cmp r1,r2
+ nxteq
+ \ r0:cnt r1:dst r2:src
+ < if \ copy bytes until: src is aligned or cnt=0
+ cmp r0,#4
+ >= if
+ begin
+ ands r3,r2,#3
+ ldrneb r3,[r2],#1
+ strneb r3,[r1],#1
+ decne r0,1
+ 0= until \ copy until source is word-aligned
+ ands r3,r1,#3
+ 0= if \ longword optimizing is possible now
+
+ begin
+ decs r0,4cells
+ ldmgeia r2!,{r3,r4,r5,r6}
+ stmgeia r1!,{r3,r4,r5,r6}
+ < until
+ inc r0,4cells
+
+ begin
+ decs r0,1cell
+ ldrge r3,[r2],1cell
+ strge r3,[r1],1cell
+ < until
+ inc r0,1cell
+ then
+ then
+ begin
+ decs r0,1
+ ldrgeb r3,[r2],#1
+ strgeb r3,[r1],#1
+ 0<= until
+ else
+ add r1,r1,r0
+ add r2,r2,r0
+ cmp r0,#4
+ >= if
+ begin
+ ands r3,r2,#3
+ ldrneb r3,[r2,#-1]!
+ strneb r3,[r1,#-1]!
+ decne r0,1
+ 0= until \ copy until source is word-aligned
+ ands r3,r1,#3
+ 0= if \ longword optimizing is possible now
+
+ begin
+ decs r0,4cells
+ ldmgedb r2!,{r3,r4,r5,r6}
+ stmgedb r1!,{r3,r4,r5,r6}
+ < until
+ inc r0,4cells
+
+ begin
+ decs r0,1cell
+ ldrge r3,[r2,~1cell]!
+ strge r3,[r1,~1cell]!
+ < until
+ inc r0,1cell
+
+ then
+ then
+ begin
+ decs r0,1
+ ldrgeb r3,[r2,#-1]!
+ strgeb r3,[r1,#-1]!
+ <= until
+ then
+c;
+[then]
+
+code noop ( -- ) c;
+
+code and ( n1 n2 -- n3 ) pop r0,sp and tos,tos,r0 c;
+code or ( n1 n2 -- n3 ) pop r0,sp orr tos,tos,r0 c;
+code xor ( n1 n2 -- n3 ) pop r0,sp eor tos,tos,r0 c;
+[ifdef] fixme
+code not ( n1 -- n2 ) mvn tos,tos c;
+code invert ( n1 -- n2 ) mvn tos,tos c;
+
+code lshift ( n1 cnt -- n2 ) pop r0,sp mov tos,r0,lsl tos c;
+code rshift ( n1 cnt -- n2 ) pop r0,sp mov tos,r0,lsr tos c;
+code << ( n1 cnt -- n2 ) pop r0,sp mov tos,r0,lsl tos c;
+code >> ( n1 cnt -- n2 ) pop r0,sp mov tos,r0,lsr tos c;
+code >>a ( n1 cnt -- n2 ) pop r0,sp mov tos,r0,asr tos c;
+code + ( n1 n2 -- n3 ) pop r0,sp add tos,tos,r0 c;
+code - ( n1 n2 -- n3 ) pop r0,sp rsb tos,tos,r0 c;
+[else]
+code + ( n1 n2 -- n3 ) pop r0,sp add tos,tos,r0 c;
+code - ( n1 n2 -- n3 ) pop r0,sp rsb tos,tos,r0 c;
+code not ( n1 -- n2 ) mvn tos,tos c;
+code invert ( n1 -- n2 ) mvn tos,tos c;
+
+code lshift ( n1 cnt -- n2 ) pop r0,sp mov tos,r0,lsl tos c;
+code rshift ( n1 cnt -- n2 ) pop r0,sp mov tos,r0,lsr tos c;
+code << ( n1 cnt -- n2 ) pop r0,sp mov tos,r0,lsl tos c;
+code >> ( n1 cnt -- n2 ) pop r0,sp mov tos,r0,lsr tos c;
+code >>a ( n1 cnt -- n2 ) pop r0,sp mov tos,r0,asr tos c;
+[then]
+
+code negate ( n -- -n ) rsb tos,tos,#0 c;
+
+code ?negate ( n f -- n | -n ) cmp tos,#0 pop tos,sp rsblt tos,tos,#0 c;
+
+code abs ( n -- [n] ) cmp tos,#0 rsbmi tos,tos,#0 c;
+
+code min ( n1 n2 -- n1|n2 ) pop r0,sp cmp tos,r0 movgt tos,r0 c;
+code umin ( u1 u2 -- u1|u2 ) pop r0,sp cmp tos,r0 movcs tos,r0 c;
+code max ( n1 n2 -- n1|n2 ) pop r0,sp cmp r0,tos movgt tos,r0 c;
+code umax ( u1 u2 -- u1|u2 ) pop r0,sp cmp r0,tos movcs tos,r0 c;
+
+code up@ ( -- adr ) psh tos,sp mov tos,up c;
+code sp@ ( -- adr ) psh tos,sp mov tos,sp c;
+code rp@ ( -- adr ) psh tos,sp mov tos,rp c;
+code up! ( adr -- ) mov up,tos pop tos,sp c;
+code sp! ( adr -- ) mov sp,tos pop tos,sp c;
+code rp! ( adr -- ) mov rp,tos pop tos,sp c;
+
+code >r ( n -- ) psh tos,rp pop tos,sp c;
+code r> ( -- n ) psh tos,sp pop tos,rp c;
+code r@ ( -- n ) psh tos,sp ldr tos,[rp] c;
+
+code 2>r ( n1 n2 -- ) mov r0,tos ldmia sp!,{r1,tos} stmdb rp!,{r0,r1} c;
+code 2r> ( -- n1 n2 ) ldmia rp!,{r0,r1} stmdb sp!,{r1,tos} mov tos,r0 c;
+code 2r@ ( -- n1 n2 ) ldmia rp,{r0,r1} stmdb sp!,{r1,tos} mov tos,r0 c;
+
+code >ip ( n -- ) psh tos,rp pop tos,sp c;
+code ip> ( -- n ) psh tos,sp pop tos,rp c;
+code ip@ ( -- n ) psh tos,sp ldr tos,[rp] c;
+
+: ip>token ( ip -- token-adr ) /token - ;
+
+code exit ( -- ) ldr ip,[rp],1cell c;
+code unnest ( -- ) ldr ip,[rp],1cell c;
+
+code ?exit ( flag -- ) cmp tos,#0 pop tos,sp ldrne ip,[rp],1cell c;
+
+code tuck ( n1 n2 -- n2 n1 n2 ) pop r0,sp stmdb sp!,{r0,tos} c;
+
+code nip ( n1 n2 -- n2 ) inc sp,1cell c;
+
+[ifdef] notdef
+code lwsplit ( n -- wlow whigh )
+\ mov r0,#0xffff
+ mov r0,#0xff
+ orr r0,r0,#0xff00
+ and r1,tos,r0
+ psh r1,sp
+ mov tos,tos,lsr #0x10
+c;
+code wljoin ( w.low w.high -- n )
+ pop r0,sp
+ orr tos,r0,tos,lsl #0x10
+c;
+[then]
+code wflip ( n1 -- n2 ) mov tos,tos,ror #0x10 c;
+code flip ( w1 -- w2 )
+ mov r0,tos,lsr #8
+ and r1,tos,#0xff
+ orr tos,r0,r1,lsl #8
+c;
+
+code 0= ( n -- f ) subs tos,tos,#1 sbc tos,tos,tos c;
+code 0<> ( n -- f ) cmp tos,#0 mvnne tos,#0 c;
+code 0< ( n -- f ) mov tos,tos,asr #0 c;
+code 0>= ( n -- f ) mvn tos,tos,asr #0 c;
+code 0> ( n -- f ) bics tos,tos,tos,asr #0 mvnne tos,#0 c;
+code 0<= ( n -- f ) cmp tos,#0 mvnle tos,#0 movgt tos,#0 c;
+
+code > ( n1 n2 -- f ) pop r0,sp cmp r0,tos mvngt tos,#0 movle tos,#0 c;
+code < ( n1 n2 -- f ) pop r0,sp cmp r0,tos mvnlt tos,#0 movge tos,#0 c;
+code = ( n1 n2 -- f ) pop r0,sp cmp r0,tos mvneq tos,#0 movne tos,#0 c;
+[ifdef] fixme
+code <> ( n1 n2 -- f ) pop r0,sp subs tos,r0,tos mvnne tos,#0 c;
+code u> ( u1 u2 -- f ) pop r0,sp subs tos,tos,r0 sbc tos,tos,tos c;
+code u<= ( u1 u2 -- f ) pop r0,sp cmp r0,tos mvnls tos,#0 movhi tos,#0 c;
+code u< ( u1 u2 -- f ) pop r0,sp subs tos,r0,tos sbc tos,tos,tos c;
+code u>= ( u1 u2 -- f ) pop r0,sp cmp r0,tos mvncs tos,#0 movcc tos,#0 c;
+code >= ( n1 n2 -- f ) pop r0,sp cmp r0,tos mvnge tos,#0 movlt tos,#0 c;
+code <= ( n1 n2 -- f ) pop r0,sp cmp r0,tos mvnle tos,#0 movgt tos,#0 c;
+[else]
+code u<= ( u1 u2 -- f ) pop r0,sp cmp r0,tos mvnls tos,#0 movhi tos,#0 c;
+code u>= ( u1 u2 -- f ) pop r0,sp cmp r0,tos mvncs tos,#0 movcc tos,#0 c;
+code >= ( n1 n2 -- f ) pop r0,sp cmp r0,tos mvnge tos,#0 movlt tos,#0 c;
+code <= ( n1 n2 -- f ) pop r0,sp cmp r0,tos mvnle tos,#0 movgt tos,#0 c;
+code <> ( n1 n2 -- f ) pop r0,sp subs tos,r0,tos mvnne tos,#0 c;
+code u> ( u1 u2 -- f ) pop r0,sp subs tos,tos,r0 sbc tos,tos,tos c;
+code u< ( u1 u2 -- f ) pop r0,sp subs tos,r0,tos sbc tos,tos,tos c;
+[then]
+
+code drop ( n1 n2 -- n1 ) pop tos,sp c;
+code dup ( n1 -- n1 n1 ) psh tos,sp c;
+\ code ?dup ( n1 -- 0 | n1 n1 ) cmp tos,#0 pshne tos,sp c;
+code over ( n1 n2 -- n1 n2 n1 ) psh tos,sp ldr tos,[sp,1cell] c;
+code swap ( n1 n2 -- n2 n1 ) ldr r0,[sp] str tos,[sp] mov tos,r0 c;
+code rot ( n1 n2 n3 -- n2 n3 n1 )
+ mov r0,tos
+ ldmia sp!,{r1,tos}
+ stmdb sp!,{r0,r1}
+c;
+code -rot ( n1 n2 n3 -- n3 n1 n2 )
+ ldmia sp!,{r1,r2}
+ stmdb sp!,{r2,tos}
+ mov tos,r1
+c;
+code 2drop ( n1 n2 -- ) inc sp,1cell pop tos,sp c;
+code 3drop ( n1 n2 n3 -- ) inc sp,2cells pop tos,sp c;
+code 4drop ( n1 n2 n3 n4 -- ) inc sp,3cells pop tos,sp c;
+code 5drop ( n1 n2 n3 n4 n5 -- ) inc sp,4cells pop tos,sp c;
+code 2dup ( n1 n2 -- n1 n2 n1 n2 ) ldr r0,[sp] stmdb sp!,{r0,tos} c;
+code 2over ( n1 n2 n3 n4 -- n1 n2 n3 n4 n1 n2 )
+ ldr r0,[sp,2cells]
+ stmdb sp!,{r0,tos}
+ ldr tos,[sp,3cells]
+c;
+code 2swap ( n1 n2 n3 n4 -- n3 n4 n1 n2 )
+ mov r0,tos
+ ldmia sp!,{r1,r2,r3}
+ stmdb sp!,{r0,r1}
+ psh r3,sp
+ mov tos,r2
+c;
+code 3dup ( n1 n2 n3 -- n1 n2 n3 n1 n2 n3 )
+ ldmia sp,{r0,r1}
+ stmdb sp!,{r0,r1,tos}
+c;
+code pick ( nm ... n1 n0 k -- nm ... n1 n0 nk ) ldr tos,[sp,tos,lsl #2] c;
+
+\ code roll ( n -- )
+\ add r1,sp,tos,lsl #2
+\ ldr tos,r1,1cell da
+\ begin
+\ ldria r0,r1,1cell
+\ str r0,[r1],-2cells
+\ cmp r1,sp
+\ < until
+\ inc sp,1cell
+\ c;
+
+\ code between ( n min max -- flag )
+\ mov r1,tos
+\ ldmia sp!,{r0,r2}
+\ mov tos,#0
+\ cmp r2,r0
+\ ldrlt pc,[ip],1cell
+\ cmp r2,r1
+\ mvnle tos,#0
+\ c;
+
+code 1+ ( n -- n+1 ) inc tos,1 c;
+code 2+ ( n -- n+2 ) inc tos,2 c;
+code 1- ( n -- n-1 ) dec tos,1 c;
+code 2- ( n -- n-2 ) dec tos,2 c;
+code 2/ ( n -- n/2 ) mov tos,tos,asr #1 c;
+code u2/ ( u -- u/2 ) mov tos,tos,lsr #1 c;
+code 2* ( n -- 2n ) mov tos,tos,lsl #1 c;
+code 4* ( n -- 4n ) mov tos,tos,lsl #2 c;
+code 8* ( n -- 8n ) mov tos,tos,lsl #3 c;
+
+code on ( adr -- ) mvn r0,#0 str r0,[tos] pop tos,sp c;
+code off ( adr -- ) mov r0,#0 str r0,[tos] pop tos,sp c;
+code +! ( n adr -- )
+ mov r0,tos
+ ldmia sp!,{r1,tos}
+ ldr r2,[r0]
+ add r2,r2,r1
+ str r2,[r0]
+c;
+
+code l@ ( adr -- n ) ldr tos,[tos] c;
+[ifdef] arm4
+\ Halfword access
+code w! ( w adr -- )
+ pop r0,sp
+ h# e1ca00b0 asm, \ strh r0,tos
+ pop tos,sp
+c;
+code w@ ( adr -- w )
+ h# e1daa0b0 asm, \ ldrh tos,tos
+c;
+code <w@ ( adr -- w )
+ h# e1daa0f0 asm, \ ldrsh tos,tos
+c;
+
+\ code w@ ( adr -- n ) ldrh tos,[tos] c;
+\ code <w@ ( adr -- n ) ldrsh tos,[tos] c;
+\ code w! ( n adr -- )
+\ pop r0,sp
+\ strh r0,[tos]
+\ pop tos,sp
+\ c;
+[else]
+code w@ ( adr -- n ) ldr tos,[tos] c;
+code <w@ ( adr -- n ) ldr tos,[tos] c;
+code w! ( n adr -- ) pop r0,sp str r0,[tos] pop tos,sp c;
+[then]
+code l! ( n adr -- ) pop r0,sp str r0,[tos] pop tos,sp c;
+code @ ( adr -- n ) ldr tos,[tos] c;
+
+code unaligned-@ ( adr -- n )
+ bic r1,tos,#3
+ ldmia r1,{r2,r3}
+ and r1,tos,#3
+ movs r1,r1,lsl #3
+ movne r2,r2,lsr r1
+ rsbne r1,r1,#0x20
+ orrne r2,r2,r3,lsl r1
+ mov tos,r2
+c;
+code c@ ( adr -- char ) ldrb tos,[tos] c;
+code ! ( n adr -- ) pop r0,sp str r0,[tos] pop tos,sp c;
+code unaligned-! ( n adr -- )
+ mov r5,tos \ r5: adr
+ ldmia sp!,{r4,tos}
+ strb r4,[r5],#1
+ mov r4,r4,ror #8
+ strb r4,[r5],#1
+ mov r4,r4,ror #8
+ strb r4,[r5],#1
+ mov r4,r4,ror #8
+ strb r4,[r5],#1
+c;
+
+code unaligned-w@ ( adr -- w )
+ ldrb r0,[tos]
+ ldrb tos,[tos,#1]
+
+ orr tos,r0,tos,lsl #8
+c;
+code unaligned-w! ( w adr -- )
+ pop r0,sp
+ strb r0,[tos]
+ mov r0,r0,ror #8
+ strb r0,[tos,#1]
+
+ pop tos,sp
+c;
+: unaligned-l@ ( adr -- l ) unaligned-@ ;
+: unaligned-l! ( l adr -- ) unaligned-! ;
+: unaligned-d! ( d adr -- ) tuck na1+ unaligned-! unaligned-! ;
+: d@ ( adr -- d ) dup @ swap na1+ @ ;
+
+code c! ( char adr -- ) pop r0,sp strb r0,[tos] pop tos,sp c;
+code 2@ ( adr -- n-high n-low )
+ ldr r0,[tos,1cell]
+ psh r0,sp
+ ldr tos,[tos]
+c;
+code 2! ( n-high n-low adr -- )
+ ldmia sp!,{r0,r1}
+ stmia tos,{r0,r1}
+ pop tos,sp
+c;
+
+code d+ ( d1 d2 -- d1+d2 )
+ ldmia sp!,{r0,r1,r2} \ tos r0 r1 r2
+ adds r0,r0,r2
+ adc tos,tos,r1
+ psh r0,sp
+c;
+
+code d- ( d1 d2 -- d1-d2 )
+ ldmia sp!,{r0,r1,r2} \ tos r0 r1 r2
+ subs r2,r2,r0
+ sbc r1,r1,tos
+ psh r2,sp
+ mov tos,r1
+c;
+code d< ( d1 d2 -- f )
+ ldmia sp!,{r0,r1,r2} \ tos r0 r1 r2
+ subs r2,r2,r0
+ sbcs tos,r1,tos
+ mov tos,tos,asr #0
+c;
+code d> ( d1 d2 -- f )
+ ldmia sp!,{r0,r1,r2} \ tos r0 r1 r2
+ subs r0,r0,r2
+ sbcs tos,tos,r1
+ mov tos,tos,asr #0
+c;
+code du< ( d1 d2 -- f )
+ ldmia sp!,{r0,r1,r2} \ tos r0 r1 r2
+ subs r2,r2,r0
+ sbcs r1,r1,tos
+ sbc tos,tos,tos
+c;
+
+code s>d ( n -- d )
+ psh tos,sp
+ mov tos,tos,asr #0
+c;
+code dnegate ( d -- -d )
+ pop r0,sp
+ rsbs r0,r0,#0
+ rsc tos,tos,#0
+ psh r0,sp
+c;
+code ?dnegate ( d flag -- d )
+ cmp tos,#0
+ pop tos,sp
+ < if
+ pop r0,sp
+ rsbs r0,r0,#0
+ rsc tos,tos,#0
+ psh r0,sp
+ then
+c;
+
+code dabs ( d -- d )
+ cmp tos,#0
+ < if
+ pop r0,sp
+ rsbs r0,r0,#0
+ rsc tos,tos,#0
+ psh r0,sp
+ then
+c;
+code d0= ( d -- f )
+ pop r0,sp
+ orrs r0,r0,tos
+ mvneq tos,#0
+ movne tos,#0
+c;
+code d0< ( d -- f )
+ inc sp,1cell
+ mov tos,tos,asr #0
+c;
+code d2* ( d1 -- d2 )
+ pop r0,sp
+ mov tos,tos,lsl #1
+ orr tos,tos,r0,lsr #31
+ mov r0,r0,lsl #1
+ psh r0,sp
+c;
+code d2/ ( s1 -- d2 )
+ pop r0,sp
+ movs tos,tos,lsr #1
+ mov r0,r0,ror #0
+ psh r0,sp
+c;
+: d= ( d1 d2 -- flag ) d- d0= ;
+: d<> ( d1 d2 -- flag ) d= 0= ;
+
+: (d.) ( d -- adr len ) tuck dabs <# #s rot sign #> ;
+: (ud.) ( ud -- adr len ) <# #s rot #> ;
+
+: d. ( d -- ) (d.) type space ;
+: ud. ( ud -- ) (ud.) type space ;
+: ud.r ( ud n -- ) >r (ud.) r> over - spaces type ;
+
+: dmax ( xd1 xd2 -- ) 2over 2over d< if 2swap then 2drop ;
+: dmin ( xd1 xd2 -- ) 2over 2over d< 0= if 2swap then 2drop ;
+
+code fill ( adr cnt char -- )
+ orr r2,tos,tos,lsl #8
+ ldmia sp!,{r0,r1,tos} \ r0-cnt r1-adr r2-data
+ cmp r0,#4
+ > if
+ orr r2,r2,r2,lsl #0x10 \ Propagate character into high halfword
+ begin \ Fill initial unaligned part
+ ands r3,r1,#3
+ decne r0,1
+ strneb r2,[r1],#1
+ 0= until
+ decs r0,4
+ begin
+ strge r2,[r1],#4
+ decges r0,4
+ < until
+ inc r0,4
+ then
+ begin
+ decs r0,1
+ strgeb r2,[r1],#1
+ < until
+c;
+
+code wfill ( adr cnt w -- )
+ mov r2,tos
+ ldmia sp!,{r0,r1,tos} \ r0-cnt r1-adr r2-data
+ begin
+ decs r0,2
+ strgeh r2,[r1],#2
+ < until
+c;
+
+code lfill ( adr cnt l -- )
+ mov r2,tos
+ ldmia sp!,{r0,r1,tos} \ r0-cnt r1-adr r2-data
+ begin
+ decs r0,4
+ strge r2,[r1],#4
+ < until
+c;
+
+\ code /link ( -- /link ) psh tos,sp mov tos,/link c;
+
+code /char ( -- 1 ) psh tos,sp mov tos,#1 c;
+code /cell ( -- 4 ) psh tos,sp mov tos,1cell c;
+
+code chars ( n1 -- n1 ) c;
+code cells ( n -- 4n ) mov tos,tos,lsl #2 c;
+code char+ ( adr -- adr1 ) inc tos,#1 c;
+code cell+ ( adr -- adr1 ) inc tos,1cell c;
+code chars+ ( adr index -- adr1 ) pop r0,sp add tos,r0,tos c;
+code cells+ ( adr index -- adr1 ) pop r0,sp add tos,r0,tos,lsl #2 c;
+
+code next-char ( addr u -- addr-char u+char )
+ dec tos,1
+ pop r0,sp
+ inc r0,1
+ psh r0,sp
+c;
+
+code n->l ( n.unsigned -- l ) c;
+code ca+ ( adr index -- adr1 ) pop r0,sp add tos,r0,tos c;
+code wa+ ( adr index -- adr1 ) pop r0,sp add tos,r0,tos,lsl #1 c;
+code la+ ( adr index -- adr1 ) pop r0,sp add tos,r0,tos,lsl #2 c;
+code na+ ( adr index -- adr1 ) pop r0,sp add tos,r0,tos,lsl #2 c;
+code ta+ ( adr index -- adr1 ) pop r0,sp add tos,r0,tos,lsl #2 c;
+
+code ca1+ ( adr -- adr1 ) inc tos,1 c;
+code wa1+ ( adr -- adr1 ) inc tos,2 c;
+code la1+ ( adr -- adr1 ) inc tos,1cell c;
+code na1+ ( adr -- adr1 ) inc tos,1cell c;
+code ta1+ ( adr -- adr1 ) inc tos,1cell c;
+
+code /c ( -- 1 ) psh tos,sp mov tos,#1 c;
+code /w ( -- 4 ) psh tos,sp mov tos,#2 c;
+code /l ( -- 4 ) psh tos,sp mov tos,#4 c;
+code /n ( -- 4 ) psh tos,sp mov tos,1cell c;
+
+code /c* ( n1 -- n1 ) c;
+code /w* ( n1 -- n2 ) mov tos,tos,lsl #1 c;
+code /l* ( n1 -- n2 ) mov tos,tos,lsl #2 c;
+code /n* ( n1 -- n2 ) mov tos,tos,lsl #2 c;
+
+8 equ nvocs \ Number of slots in the search order
+
+code upc ( char -- upper-case-char )
+ and tos,tos,#0xff
+ cmp tos,#0x61 \ ascii a
+ nxtlt
+ cmp tos,#0x7b \ ascii {
+ declt tos,#0x20
+c;
+code lcc ( char -- lower-case-char )
+ and tos,tos,#0xff
+ cmp tos,#0x41 \ ascii A
+ nxtlt
+ cmp tos,#0x5b \ ascii [
+ inclt tos,#0x20
+c;
+code comp ( adr1 adr2 len -- -1 | 0 | 1 )
+ inc tos,1 \ tos length
+ ldmia sp!,{r0,r1}
+ begin
+ decs tos,#1
+ 0<> while
+ ldrb r2,[r0],#1
+ ldrb r3,[r1],#1
+ cmp r2,r3
+[ifdef] fixme
+0<> if
+ movgt tos,#1
+ mvnlt tos,#0
+ nxtne
+then
+[else]
+ movgt tos,#1
+ mvnlt tos,#0
+ nxtne
+[then]
+ repeat
+ mov tos,#0
+c;
+code caps-comp ( adr1 adr2 len -- -1 | 0 | 1 )
+ add tos,tos,#1 \ tos length
+ ldmia sp!,{r0,r1}
+ begin
+ decs tos,1
+ 0<> while
+ mov r2,#0
+ ldrb r2,[r0],#1
+ cmp r2,#0x41 \ ascii A
+ > if
+ cmp r2,#0x5b \ ascii [
+ inclt r2,#0x20
+ then
+ mov r3,#0
+ ldrb r3,[r1],#1
+ cmp r3,#0x41 \ ascii A
+ > if
+ cmp r3,#0x5b \ ascii [
+ inclt r3,#0x20
+ then
+ cmp r2,r3
+[ifdef] fixme
+0<> if
+ movgt tos,#1
+ mvnlt tos,#0
+ nxtne
+then
+[else]
+ movgt tos,#1
+ mvnlt tos,#0
+ nxtne
+[then]
+ repeat
+ mov tos,#0
+c;
+code pack ( str-adr len to -- to )
+ mov r0,tos \ to
+ ldmia sp!,{r1,r2}
+ ands r1,r1,#0xff \ set length flag
+ strb r1,[r0],#1
+ 0<> if
+ begin
+ ldrb r3,[r2],#1
+ strb r3,[r0],#1
+ decs r1,#1
+ 0= until
+ then
+ mov r1,#0
+ strb r1,[r0],#1
+c;
+
+code (') ( -- n ) psh tos,sp ldr tos,[ip],1cell c;
+
+\ Modifies caller's ip to skip over an in-line string
+code skipstr ( -- adr len)
+ psh tos,sp
+ ldr r0,[rp]
+ ldrb tos,[r0],#1
+ psh r0,sp
+ add r0,r0,tos
+ inc r0,1cell
+ bic r0,r0,#3
+ str r0,[rp]
+c;
+code (") ( -- adr len)
+ psh tos,sp
+ ldrb tos,[ip],#1
+ psh ip,sp
+ add ip,ip,tos
+ inc ip,#4
+ bic ip,ip,#3
+c;
+code traverse ( adr direction -- adr' )
+ mov r0,tos \ direction r0
+ pop tos,sp \ adr -> tos
+ add tos,tos,r0
+ begin
+ ldrb r1,[tos]
+ and r1,r1,#0x80
+ 0= while
+ add tos,tos,r0
+ repeat
+c;
+code count ( adr -- adr1 cnt )
+ mov r0,tos
+ ldrb tos,[r0],#1
+ psh r0,sp
+c;
+
+: instruction! ( n adr -- ) tuck l! /cell sync-cache ;
+
+\ a colon-magic doesn't exist in this ARM version
+: place-cf ( adr -- )
+ acf-align
+ here - 2/ 2/ 2- 00ffffff and eb000000 or
+ here /cell allot instruction!
+;
+\ place a branch+link to target at adr
+: put-cf ( target adr -- )
+ dup >r - 2/ 2/ 2- 00ffffff and eb000000 or
+ r> instruction!
+;
+
+: instruction, ( n -- ) here /cell allot instruction! ;
+: push-pfa ( -- adr )
+ e52da004 instruction, \ psh tos,sp
+\ e3cea3ff instruction, \ bic tos,lk,#0xfc00.0003
+ e1a0a00e instruction, \ mov tos,lk
+;
+
+: origin- ( adr -- offset ) origin - ;
+: origin+ ( offset -- adr ) origin + ;
+
+: code-cf ( -- ) acf-align ;
+: code? ( acf -- f ) \ True if the acf is for a code word
+ @ h# ff000000 and h# eb000000 <>
+;
+: >code ( acf-of-code-word -- address-of-start-of-machine-code ) ;
+
+\ Ip is assumed to point to (;code . flag is true if
+\ the code at ip is a does> clause as opposed to a ;code clause.
+
+: colon-cf ( -- ) docolon origin+ place-cf ;
+: colon-cf? ( adr -- flag ) word-type docolon origin + = ;
+: docolon ( -- adr ) docolon origin+ ;
+: create-cf ( -- ) docreate origin+ place-cf ;
+: variable-cf ( -- ) dovariable origin+ place-cf ;
+: user-cf ( -- ) douser origin+ place-cf ;
+: value-cf ( -- ) dovalue origin+ place-cf ;
+: constant-cf ( -- ) doconstant origin+ place-cf ;
+: defer-cf ( -- ) dodefer origin+ place-cf ;
+: 2constant-cf ( -- ) do2constant origin+ place-cf ;
+: place-does ( -- ) push-pfa dodoesaddr token@ place-cf ;
+
+: does-ip? ( ip -- ip' flag )
+ dup token@ ['] (does>) = if 4 na+ true else na1+ false then
+;
+
+: place-;code ( -- ) ;
+
+\ next is redefined in cpu/arm/code.fth so that it can be conditional
+\ Version for next in user area
+: next ( -- ) h# e1a0f009 instruction, ;
+\ Version for in-line next
+\ : next ( -- ) h# e498f004 instruction, ;
+
+\ New: : pointer-cf ( -- ) dopointer literal origin+ place-cf ;
+\ New: : buffer-cf ( -- ) dobuffer literal origin+ place-cf ;
+
+\ uses sets the code field of the indicated word so that
+\ it will execute the code at action-clause-adr
+: uses ( action-clause-adr xt -- ) put-cf ;
+
+\ used sets the code field of the most-recently-defined word so that
+\ it executes the code at action-clause-adr
+: used ( action-clause-adr -- ) lastacf uses ;
+
+\ operators using addresses, links and tokens
+/a-t constant /a
+: a@ ( adr -- adr ) l@ ;
+: a! ( adr adr -- ) set-relocation-bit l! ;
+: a, ( adr -- ) here /a allot a! ;
+\ : link@ ( adr -- adr ) @ ;
+\ : link! ( adr adr -- ) a! ;
+\ : link, ( adr -- ) a, ;
+\ : link-here ( adr -- ) align here over @ link, swap ! ;
+
+/n-t constant /branch
+
+\rel : branch, ( offset -- ) , ;
+\rel : branch! ( offset where -- ) ! ;
+\rel : branch@ ( where -- offset ) @ ;
+\rel : >target ( ip -- target ) ta1+ dup branch@ + ( h# ffffc and ) ;
+\abs : branch, ( offset -- ) here + a, ;
+\abs : branch! ( offset where -- ) swap over + swap a! ;
+\abs : branch@ ( where -- offset ) @ ;
+\abs : >target ( ip -- target ) ta1+ branch@ ;
+
+/token constant /token
+: token@ ( adr -- cfa ) l@ ;
+: token! ( cfa adr -- ) set-relocation-bit l! ;
+: token, ( cfa -- ) here /token allot token! ;
+
+\ XXX this is a kludgy way to make a relocated constant
+origin-t constant origin /n negate allot-t origin-t token,-t
+
+: null ( -- token ) origin ;
+: !null-link ( adr -- ) null swap link! ;
+: !null-token ( adr -- ) null swap token! ;
+: non-null? ( link -- false | link true )
+ dup origin = if drop false else true then
+;
+: get-token? ( adr -- false | acf true ) token@ non-null? ;
+: another-link? ( adr -- false | link true ) link@ non-null? ;
+
+\ The "word type" is a number which distinguishes one type of word
+\ from another. This is highly implementation-dependent.
+\ For the ARM Implementation, this always returns the adress of the
+\ code sequence for that word.
+
+code >body ( cfa -- pfa )
+ ldr r0,[tos]
+ and r0,r0,#0xff000000
+ cmp r0,#0xeb000000
+ inceq tos,1cell
+c;
+code body> ( pfa -- cfa )
+ ldr r0,[tos,~/token]
+ and r0,r0,#0xff000000
+ cmp r0,#0xeb000000
+ deceq tos,1cell
+c;
+code word-type ( cfa -- word-type )
+ ldr r0,[tos]
+ and r1,r0,#0xff000000
+ cmp r1,#0xeb000000
+ moveq r0,r0,lsl #8
+ moveq r0,r0,asr #6
+ inceq r0,8
+ addeq tos,tos,r0
+\ bic tos,tos,#0xfc000003
+c;
+
+4 constant /user#
+
+\ Move to a machine alignment boundary. All ARM-Processors need
+\ 32-bit alignment
+: aligned ( adr -- adr' ) /n round-up ;
+: acf-aligned ( adr -- adr' ) aligned ;
+: acf-align ( adr -- adr' )
+ begin here #acf-align 1- and while 0 c, repeat
+ here 'lastacf token!
+;
+
+only forth also labels also meta
+also arm-assembler helpers also arm-assembler definitions
+:-h 'body ( "name" -- variable-apf adt-immed )
+ [ also meta ]-h ' ( acf-of-user-variable ) >body-t
+ [ previous ]-h adt-immed
+;-h
+:-h 'code ( "name" -- code-word-acf adt-immed )
+ [ also meta ]-h ' ( acf-of-user-variable )
+ [ previous ]-h adt-immed
+;-h
+:-h 'user# ( "name" -- user# adt-immed )
+ [ also meta ]-h ' ( acf-of-user-variable ) >body-t @-t
+ [ previous ]-h adt-immed
+;-h
+:-h 'user ( "name" -- )
+\ [ also register-names ] up [ previous ] drop ( reg# )
+ up drop ( reg# )
+ d# 16 lshift iop
+ 'user# ( value adt-immed )
+ drop d# 12 ?#bits iop
+;
+only forth also labels also meta also definitions
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1997 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/kerncode.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/kernel.bth
===================================================================
--- cpu/arm/kernel.bth (rev 0)
+++ cpu/arm/kernel.bth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,151 @@
+purpose: Load file for ARM Forth kernel
+\ See license at end of file
+
+command: &builder &this
+build-now
+
+\ z only forth also definitions decimal
+\ z warning on
+
+\ ' $report-name is include-hook
+ ' noop is include-hook
+\ ' noop is include-exit-hook
+
+\ Don't accept ',' as numeric punctuation because doing so makes
+\ the forward referencing mechanism think that "c," is a number!
+ascii . ascii , npatch numdelim?
+
+warning off \ Turn OFF the warning messages
+
+\ Configure for relative branch targets. Absolute branch targets
+\ do not work correctly with FCode because of the way that FCode
+\ backward branch resolution works.
+: \rel ( -- ) ; immediate
+: \abs ( -- ) [compile] \ ; immediate
+create arm4
+
+alias constant-h constant
+
+fload ${BP}/forth/kernel/conft32.fth
+fload ${BP}/forth/kernel/meta1.fth
+
+
+[ifndef] arm-assembler \ Make sure we have the ARM assembler
+order cr
+only forth also definitions
+
+fload ${BP}/forth/lib/bitops.fth
+\needs set-relocation-bit defer set-relocation-bit \ keep init-assem happy
+
+\ only forth also meta also definitions
+
+fload ${BP}/cpu/arm/assem.fth
+fload ${BP}/cpu/arm/code.fth
+
+[then]
+only forth also meta also definitions
+: sx .s cr ;
+
+only forth also meta definitions
+: assembler ( -- ) arm-assembler ;
+
+only forth also meta also assembler definitions
+\needs L: fload ${BP}/forth/lib/loclabel.fth
+init-labels
+
+only forth also definitions
+\needs bitset fload ${BP}/forth/lib/bitops.fth
+
+fload ${BP}/forth/kernel/nswapmap.fth \ Null swap map
+\ : : : lastacf .name cr ;
+fload ${BP}/cpu/arm/target.fth
+fload ${BP}/forth/kernel/forward.fth
+fload ${BP}/cpu/ppc/fixvoc.fth
+fload ${BP}/forth/kernel/metacompile.fth
+
+fload ${BP}/cpu/arm/metarel.fth
+
+only forth meta also forth also definitions
+
+' meta-set-relocation-bit is set-relocation-bit-t
+' meta-init-relocation is init-relocation-t
+\ protocol? on
+
+only forth also definitions decimal
+
+warning on
+fload ${BP}/cpu/arm/metainit.fth
+
+" kernel.tag" r/w create-file drop meta-tag-file !
+
+always-headers
+
+\ Comment out the following line(s) when debugging
+-1 threshold ! \ Turn OFF ALL debugging messages
+warning-t off \ Turn OFF target warning messages
+
+\ Uncomment the following line(s) for more debug output
+\ show? on 1 granularity ! 1 threshold !
+\ warning-t on
+
+fload ${BP}/cpu/arm/kerncode.fth
+fload ${BP}/cpu/arm/extra.fth
+
+fload ${BP}/forth/kernel/uservars.fth
+fload ${BP}/cpu/arm/muldiv.fth \ Uses "defer"; must be after uservars
+fload ${BP}/cpu/arm/dodoesad.fth
+fload ${BP}/cpu/arm/version.fth
+
+fload ${BP}/forth/kernel/double.fth \ ???
+fload ${BP}/forth/kernel/scan.fth
+
+fload ${BP}/cpu/arm/bitops.fth
+fload ${BP}/cpu/arm/kernrel.fth
+
+fload ${BP}/forth/lib/struct.fth
+
+fload ${BP}/forth/kernel/kernel.fth
+
+fload ${BP}/forth/kernel/sysio.fth
+fload ${BP}/forth/lib/dumballo.fth
+fload ${BP}/cpu/arm/sys.fth
+
+\ fload ${BP}/forth/kernel/nswapmap.fth \ Null swap map
+
+\ fload ${BP}/cpu/arm/field.fth
+fload ${BP}/cpu/arm/filecode.fth
+
+fload ${BP}/cpu/arm/boot.fth
+fload ${BP}/forth/kernel/init.fth
+fload ${BP}/cpu/arm/finish.fth
+
+fload ${BP}/cpu/arm/savemeta.fth
+
+\Tags close-tag-file
+\NotTags .( --- Saving ) " kernel.dic" type .( ---)
+" kernel.dic" $save-meta cr
+cr
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2008 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/kernel.bth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/kernfloat.fth
===================================================================
--- cpu/arm/kernfloat.fth (rev 0)
+++ cpu/arm/kernfloat.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,63 @@
+purpose: Kernel-level floating point words
+\ See license at end of file
+
+\ Contributed by Hanno Schwalm
+
+code fp@ ( -- adr )
+ top sp push
+ top 'user fp ldr c;
+
+code fp! ( a_adr -- )
+ top 'user fp str
+ top sp pop c;
+code (flit) ( -- )
+ r0 r1 2 ip ia! ldm
+ r2 'user fp ldr
+ r0 r1 2 r2 db! stm
+ r2 'user fp str c;
+code f@ ( adr -- ) ( -- f1 )
+ r0 r1 2 top ia ldm
+ r2 'user fp ldr
+ r0 r1 2 r2 db! stm
+ r2 'user fp str
+ top sp pop c;
+code f! ( adr -- ) ( f1 -- )
+ r2 'user fp ldr
+ r0 r1 2 r2 ia! ldm
+ r2 'user fp str
+ r0 r1 2 top ia stm
+ top sp pop c;
+
+code /float ( -- 8)
+ top sp push top 8 # mov c;
+code floats ( n -- 8n )
+ top top 3 #asl mov c;
+code float+ ( adr -- adr1 )
+ top 8 incr c;
+code floats+ ( a_adr index -- a_adr1 )
+ r0 sp pop
+ top r0 top 3 #asl add c;
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2008 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/kernfloat.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/kernrel.fth
===================================================================
--- cpu/arm/kernrel.fth (rev 0)
+++ cpu/arm/kernrel.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,81 @@
+purpose: Maintains a bitmap identifying longwords that need to be relocated
+\ See license at end of file
+
+\ h# 8.0000 equ max-image
+h# 8.0000 constant max-image
+
+0 value relocation-map
+
+\ The relocation map has one bit for every 32-bit word, since we assume
+\ that relocated longwords must start on a 32-bit boundary
+
+\ If the address is within the new part of the dictionary (between
+\ relocation-base and relocation-base + max-image), set the corresponding
+\ bit in relocation-map. If the address is within the user area,
+\ (between up@ and up@ + #user), set the corresponding bit in
+\ user-relocation-map
+
+: >relbit ( adr -- bit# array ) origin - /l / relocation-map ;
+
+\ This has to be deferred so it can be turned off until the relocation
+\ table has been initialized.
+
+defer set-relocation-bit ' noop is set-relocation-bit
+defer clear-relocation-bits ' 2drop is clear-relocation-bits
+: (set-relocation-bit ( adr -- adr )
+ dup origin dup max-image + within if ( adr )
+ dup >relbit bitset
+ then
+;
+: (clear-relocation-bits ( adr len -- )
+ bounds ?do i >relbit bitclear /n +loop
+;
+
+: relocation-on ( -- )
+ ['] (set-relocation-bit ['] set-relocation-bit (is
+ ['] (clear-relocation-bits ['] clear-relocation-bits (is
+;
+: relocation-off ( -- )
+ ['] noop ['] set-relocation-bit (is
+ ['] 2drop ['] clear-relocation-bits (is
+;
+
+: init-relocation ( -- ) \ Allocate relocation map
+ max-image d# 32 / ( #map-bytes )
+ dup alloc-mem ( #map-bytes adr )
+ is relocation-map ( #map-bytes )
+ relocation-map swap erase
+ here relocation-map
+ origin h# 10 + l@ h# 1f + 5 rshift move
+
+ \ Now that the table is set up, set-relocation-bit may be turned on
+ relocation-on
+;
+
+: set-swap-bit ( addr -- ) drop ;
+: note-string ( adr len -- adr len ) ;
+decimal
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1997 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/kernrel.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/loadmach.fth
===================================================================
--- cpu/arm/loadmach.fth (rev 0)
+++ cpu/arm/loadmach.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,68 @@
+purpose: Load file for machine-dependent Forth tools
+\ See license at end of file
+
+assembler? [if]
+fload ${BP}/cpu/arm/assem.fth
+fload ${BP}/cpu/arm/code.fth
+fload ${BP}/forth/lib/loclabel.fth
+[else]
+transient fload ${BP}/cpu/arm/assem.fth resident
+fload ${BP}/cpu/arm/code.fth
+transient fload ${BP}/forth/lib/loclabel.fth resident
+[then]
+
+fload ${BP}/cpu/arm/decompm.fth
+
+: be-l, ( l -- ) here 4 note-string allot be-l! ;
+
+\needs $save-forth transient fload ${BP}/cpu/arm/savefort.fth resident
+\ alias $save-forth $save-forth
+
+fload ${BP}/cpu/arm/disassem.fth \ Exports (dis , pc , dis1 , +dis
+fload ${BP}/forth/lib/instdis.fth
+
+fload ${BP}/cpu/arm/objsup.fth
+fload ${BP}/forth/lib/objects.fth
+
+fload ${BP}/cpu/arm/call.fth \ C subroutine calls
+
+fload ${BP}/forth/lib/rstrace.fth
+fload ${BP}/cpu/arm/debugm.fth \ Forth debugger support
+fload ${BP}/forth/lib/debug.fth \ Forth debugger
+
+fload ${BP}/cpu/arm/cpustate.fth
+fload ${BP}/cpu/arm/register.fth
+
+fload ${BP}/forth/lib/savedstk.fth
+fload ${BP}/cpu/arm/ftrace.fth
+fload ${BP}/cpu/arm/ctrace.fth
+
+start-module \ Breakpointing
+fload ${BP}/cpu/arm/cpubpsup.fth \ Breakpoint support
+fload ${BP}/forth/lib/breakpt.fth
+\ fload ${BP}/cpu/arm/catchexc.fth
+end-module
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1994 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/loadmach.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/loadvmem.fth
===================================================================
--- cpu/arm/loadvmem.fth (rev 0)
+++ cpu/arm/loadvmem.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,47 @@
+purpose: Load file for virtual memory node
+\ See license at end of file
+
+headers
+fload ${BP}/ofw/core/allocmor.fth \ S Allow alloc-mem to use more memory
+
+dev /
+new-device
+" mmu" device-name
+fload ${BP}/ofw/core/virtlist.fth \ Virtual memory allocator
+fload ${BP}/ofw/core/maplist.fth \ Manage translation list
+
+fload ${BP}/cpu/arm/mmu.fth
+
+: .t translations translation-node .list ;
+
+' 2drop is ?splice
+
+finish-device
+device-end
+
+: map? ( virtual -- ) " map?" mmu-node @ $call-method ;
+: .t ( -- ) " .t" mmu-node @ $call-method ;
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1997 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/loadvmem.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/memtest.fth
===================================================================
--- cpu/arm/memtest.fth (rev 0)
+++ cpu/arm/memtest.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,112 @@
+purpose: Memory test primitives in assembly language
+\ See license at end of file
+
+headers
+\needs mask nuser mask mask on
+headerless
+
+\ Report the progress through low-level tests
+0 0 2value test-name
+: show-status ( adr len -- ) to test-name ;
+
+code lfill ( adr len l -- )
+ \ tos: pattern
+ ldmia sp!,{r0,r1} \ r0: len, r1: adr
+
+ ahead begin \ Fill
+ str tos,[r0,r1]
+ but then
+ decs r0,1cell
+ 0< until
+
+ pop tos,sp
+c;
+
+code masked-ltest ( adr len l mask -- error? )
+ mov r4,tos \ r4: mask
+ ldmia sp!,{r0,r1,r2} \ r0: l, r1: len, r2: adr
+ and r0,r0,r4 \ Mask l
+ mvn tos,#0 \ tos: failure code (in case of mismatch)
+
+ ahead begin \ Test
+ ldr r3,[r2,r1] \ Get data from memory
+ and r3,r3,r4 \ mask memory data
+ cmp r3,r0 \ Test under mask
+ nxtne \ Exit if mismatch
+ but then
+ decs r1,1cell
+ 0< until
+
+ mov tos,#0
+c;
+
+: mem-bits-test ( membase memsize -- fail-status )
+ " Data bits test" show-status
+ 2dup h# 5a5a5a5a lfill
+ 2dup h# 5a5a5a5a mask @ masked-ltest if 2drop true exit then
+
+ 2dup h# a5a5a5a5 lfill
+ h# a5a5a5a5 mask @ masked-ltest
+;
+
+code afill ( adr len -- )
+ pop r0,sp \ tos: len, r0: adr
+
+ ahead begin \ Fill
+ add r1,r0,tos \ Compute address
+ str r1,[r0,tos] \ Store it at the location
+ but then
+ decs tos,1cell \ Decrement index
+ 0< until
+
+ pop tos,sp
+c;
+
+code masked-atest ( adr len mask -- mismatch? )
+ mov r4,tos \ r4: mask
+ ldmia sp!,{r0,r1} \ r0: len, r1: adr
+ mvn tos,#0 \ tos: failure code (in case of mismatch)
+
+ ahead begin \ Check
+ add r2,r0,r1 \ Compute pattern
+ and r2,r2,r4 \ under mask
+ ldr r3,[r0,r1] \ Get data from memory
+ and r3,r3,r4 \ under mask
+ cmp r3,r2 \ Compare
+ nxtne \ Exit if mismatch
+ but then
+ decs r0,1cell
+ 0< until
+
+ mov tos,#0
+c;
+
+: address=data-test ( membase memsize -- status )
+ " Address=data test" show-status
+
+ 2dup afill mask @ masked-atest
+;
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1997 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/memtest.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/metainit.fth
===================================================================
--- cpu/arm/metainit.fth (rev 0)
+++ cpu/arm/metainit.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,68 @@
+purpose: Metacompiler initialization for kernel compilation
+\ See license at end of file
+
+\ Handle command line
+\ Make interpreter re-entrant - multiple tibs? (pokearound)
+\ Handle end-of-file on input stream
+\ Fix "" to be state smart
+\ Meta compiler source for the Forth 83 kernel.
+\ Debugging aids
+
+hex
+ 0 #words !
+ 800 threshold !
+ 800 granularity !
+warning off
+
+forth definitions
+: ` [compile] "" pad "copy pad ;
+
+variable >cld >cld off \ helps forward referencing cold
+
+metaon meta definitions
+max-kernel 40 + alloc-mem target-image \ Allocate space for the target image
+
+\ org sets the lowest address that is used by Forth kernel.
+\ This is sort of a funny number, being a target token rather
+\ than a real absolute address.
+0.0000 org 0.0000 voc-link-t token-t!
+
+initmeta
+ps-size-t equ ps-size
+rs-size-t equ rs-size
+
+assembler
+\ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+\ !!!!!!!!!!!!!!! the processor starts right here !!!!!!!!!!
+\ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+mlabel cld
+ lnk r6
+ dec r6,#0x10 \ header address in r6
+ 0 asm, \ space for a branch and link, to be patched in later
+meta
+0 a,-t
+h# 10 allot-t \ register saving area, reserved for internals
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1986 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/metainit.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/metarel.fth
===================================================================
--- cpu/arm/metarel.fth (rev 0)
+++ cpu/arm/metarel.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,40 @@
+purpose: Maintain a relocation table
+\ See license at end of file
+
+\needs lbsplit fload ${BP}/fm/lib/split.fth
+
+max-kernel d# 32 / constant /relocation-map \ Number of bytes in bitmap
+create relocation-map /relocation-map allot
+
+\ The relocation map has one bit for every 32-bit word, since we assume
+\ that relocated longwords must start on a 32-bit boundary
+
+: >offset ( adr -- offset ) /l / ;
+: meta-set-relocation-bit ( adr -- adr )
+ dup >offset relocation-map bitset
+;
+: meta-init-relocation ( -- ) relocation-map /relocation-map 0 fill ;
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2008 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/metarel.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/minifth.fth
===================================================================
--- cpu/arm/minifth.fth (rev 0)
+++ cpu/arm/minifth.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,1127 @@
+purpose: Forth-like peek/poke/memory-test monitor using only registers
+\ See license at end of file
+
+\ Requires the following external definitions:
+\ isa-io-pa ( -- n ) \ Returns the base address of IO space
+\ init-serial ( -- ) \ May destroy r0-r3
+\ getchar ( -- r0: char ) \ May destroy r0-r3
+\ putchar ( r0: char -- ) \ May destroy r0-r3
+
+\ The following code must run entirely from registers. The following
+\ register allocation conventions are used:
+\ r0-r3 Argument passing and return, scratch registers for subroutines
+\ r4 Return address for level 1 routines, scratch use for level 2+
+\ r5 Return address for level 2 routines, scratch use for level 3+
+\ r6-r7 Used as needed within higher-level subroutines
+\ r8 Global state flags - bitmasks are:
+\ 1 - spin mode
+\ 2 - quiet mode
+\ 4 - script mode
+\ 8 - no-echo mode
+\ r9 script pointer
+\ r10-r13 4-element stack
+\ r14 Link register for subroutine calls
+\ r15 Program counter
+
+\ Send a space character to the output device.
+label putspace ( -- ) \ Level 0, destroys: r0-r3 (because it calls putchar)
+ mov r0,#0x20
+ b `putchar`
+end-code
+
+\ Send a newline sequence (CR-LF) to the output device.
+label putcr ( -- ) \ Level 1, destroys: r0-r4 (because it calls putchar)
+ mov r4,lr
+ mov r0,#0x0d
+ bl `putchar`
+ mov r0,#0x0a
+ bl `putchar`
+ mov pc,r4
+end-code
+
+\ Send ": " to the output device.
+label putcolon ( -- ) \ Level 1, destroys: r0-r4
+ mov r4,lr
+ mov r0,`char : #`
+ bl `putchar`
+ bl `putspace`
+ mov pc,r4
+end-code
+
+\ Accept input characters, packing up to 8 of them into the register pair
+\ r0,r1. The first character is placed in the least-significant byte of
+\ r1, and for each subsequent character, the contents of r0,r1 are shifted
+\ left by 8 bits to make room for the new character (shifting the most-
+\ significant byte of r1 into the least-significant byte of r0).
+\ A backspace character causes r0,r1 to be shifted right, discarding the
+\ previous character.
+\ The process terminates when a space or carriage return is seen. The
+\ terminating character is not stored in r0,r1. Any unused character
+\ positions in r0,r1 contain binary 0 bytes.
+label getword ( -- r0,r1 ) \ Level 4, destroys r0-r7
+ mov r5,lr
+ mov r6,#0 \ Clear high temporary holding register
+ mov r7,#0 \ Clear low temporary holding register
+
+ begin
+ tst r8,#4 0<> if
+ ldrb r0,[r9],#1
+ \ Translate linefeed to carriage return in script mode
+ cmp r0,#0x0a = if mov r0,#0x0d then
+ else
+ bl `getchar` ( char in r0 )
+ then
+
+ cmp r0,#0x0d = if \ carriage return
+ tst r8,#8 0= if \ Check no-echo flag
+ bl `putcr` \ Echo CR-LF
+ then
+ mov r0,r6 mov r1,r7 \ Return packed word in r0,r1
+ mov pc,r5 \ Return
+ then
+
+ cmp r0,`control h` <> if
+ cmp r0,#0x20 <= if \ white space
+ tst r8,#8 0= if \ Check no-echo flag
+ \ In quiet mode, echo the input character; otherwise echo CR-LF
+ tst r8,#2 0<> if bl `putchar` else bl `putcr` then
+ then
+ mov r0,r6 mov r1,r7 \ Return packed word in r0,r1
+ mov pc,r5 \ Return
+ then
+ then
+
+ mov r4,r0 \ Save character
+ tst r8,#8 0= if \ Check no-echo flag
+ bl `putchar` \ Echo the character
+ then
+
+ cmp r4,`control h` = if
+ \ Double-shift right one byte
+ mov r7,r7,lsr #8
+ orr r7,r7,r6,lsl #24
+ mov r6,r6,lsr #8
+ else
+ \ Double-shift left one byte and merge in the new character
+ mov r6,r6,lsl #8
+ orr r6,r6,r7,lsr #24
+ orr r7,r4,r7,lsl #8
+ then
+ again
+end-code
+
+\ Convert the ASCII hexadecimal characters packed into r0,r1 into a
+\ 32-bit binary number, returning the result in r0 and non-zero in r1
+\ if the operation succeeded.
+\ If the operation failed (because of the presence of non-hex characters),
+\ return 0 in r1, and an undefined value in r0.
+
+\ Level 1, destroys: r0-r4
+label convert-number ( r0,r1: ascii -- r0: binary r1: okay? )
+ mov r4,r0 \ Move high 4 ASCII characters away from r0
+ mov r0,#0 \ Accumulator for output
+
+ mov r3,#8 \ Loop counter - convert 8 nibbles
+ begin
+ \ Shift r4,r1 left one byte, putting result in r2
+ mov r2,r4,lsr #24 \ High byte in r2
+ mov r4,r4,lsl #8 \ Shift high word
+ orr r4,r4,r1,lsr #24 \ Merge from low word to high word
+ mov r1,r1,lsl #8 \ Shift low word
+
+ cmp r2,#0 <> if
+
+ cmp r2,`char 0 #`
+ movlt r1,#0
+ movlt pc,lr \ Exit if < '0'
+
+ cmp r2,`char 9 #` <= if \ Good digit from 0-9
+ sub r2,r2,`char 0 #`
+ else
+ cmp r2,`char A #`
+ movlt r1,#0
+ movlt pc,lr \ Exit if < 'A'
+
+ cmp r2,`char F #` <= if
+ sub r2,r2,`char A d# 10 - #`
+ else
+ cmp r2,`char a #` \ possibly lower case hex digit
+ movlt r1,#0
+ movlt pc,lr \ Exit if < 'a'
+
+ cmp r2,`char f #`
+ movgt r1,#0
+ movgt pc,lr \ Exit if > 'f'
+
+ sub r2,r2,`char a d# 10 - #`
+ then
+ then
+ add r0,r2,r0,lsl #4
+ then
+ decs r3,1
+ = until
+
+ mvn r1,#0
+
+ mov pc,lr
+end-code
+
+\ Display the number in r0 as an 8-digit unsigned hexadecimal number
+label dot ( r0 -- ) \ Level 3, destroys: r0-r6
+ mov r4,lr
+ mov r5,r0
+ mov r6,#8
+ begin
+ mov r5,r5,ror #28
+ and r0,r5,#0xf
+ cmp r0,#10
+ addge r0,r0,`char a d# 10 - #`
+ addlt r0,r0,`char 0 #`
+ bl `putchar`
+ decs r6,1
+ 0= until
+
+ mov r0,#0x20
+ bl `putchar`
+
+ mov pc,r4
+end-code
+
+transient
+\ Macros for managing the mini-stack
+: pop1 ( -- )
+ " mov r10,r11 mov r11,r12 mov r12,r13" evaluate
+;
+: pop2 ( -- )
+ " mov r10,r12 mov r11,r13 mov r12,r13" evaluate
+;
+: pop3 ( -- )
+ " mov r10,r13 mov r11,r13 mov r12,r13" evaluate
+;
+: push1 ( -- )
+ " mov r13,r12 mov r12,r11 mov r11,r10" evaluate
+;
+
+\ Macros to assemble code to begin and end command definitions
+8 buffer: name-buf
+
+\ Start a command definition
+\ false value trace?
+: t: ( "name" -- cond )
+ \ Get a name from the input stream at compile time and pack it
+ \ into a buffer in the same form it will appear in the register
+ \ pair when the mini-interpreter is executed at run-time
+ name-buf 8 erase ( )
+ parse-word ( adr len )
+\ no-page 2dup type space
+ dup 8 - 0 max /string ( adr' len' ) \ Keep last 8
+ 8 min 8 over - name-buf + swap move ( )
+
+\ ['] $do-undefined behavior .name cr
+ \ Assemble code to compare the register-pair contents against the name.
+ name-buf be-l@ " set r2,* cmp r0,r2" evaluate
+ name-buf 4 + be-l@ " set r2,* cmpeq r1,r2 = if" evaluate
+;
+
+
+\ End a command definition by:
+\ a) Assembling code to jump back to the beginning of the loop after the
+\ current definition has executed ("over again")
+\ b) Resolve the "if" (conditional branch) that skips the current definition
+\ if the name the user has entered does not match this definition.
+
+: t; ( loop-begin-adr if-adr --- loop-begin-adr )
+ " over again then" evaluate
+;
+resident
+
+label put-string ( -- )
+ mov r4,lr
+ begin
+ ldrb r0,[r4],#1
+ cmp r0,#0
+ <> while
+ bl `putchar`
+ repeat
+
+ add r4,r4,#3 \ Align to word boundary
+ bic r4,r4,#3
+
+ mov pc,r4
+end-code
+
+\ Some system architectures place the boot ROM at a non-zero physical
+\ address, in which case there must be a special "boot mode" that forces
+\ zero-based addresses to hit the ROM until some action is taken to turn
+\ off that mode. jump-to-rom adds the "real" physical address of the
+\ ROM to the return address so that it returns to the real physical address,
+\ after which it will be safe to turn off boot mode.
+label jump-to-rom
+ bic lr,lr,#0xff000000 \ In case we jump to the start address
+ set r0,`rom-pa #`
+ add pc,lr,r0
+end-code
+
+label minifth ( -- <does not return> ) \ Level 5
+ bl `jump-to-rom` \ Returns at the "real" ROM address
+
+ bl `init-serial`
+
+ bl `put-string`
+ banner$ c$, 4 (align)
+
+ mov r10,#0 mov r11,#0 mov r12,#0 mov r13,#0 \ Init stack
+ mov r8,#0 \ Init loop flag
+
+ begin ( loop-begin-adr )
+ tst r8,#6 0= if \ Display stack if neither silent nor scripting
+ \ mov r0,r13 bl `dot`
+ mov r0,r12 bl `dot`
+ mov r0,r11 bl `dot`
+ mov r0,r10 bl `dot`
+ mov r0,`char o #` bl `putchar`
+ mov r0,`char k #` bl `putchar`
+ bl `putspace`
+ then
+
+ bl `getword` \ Result in r0 and r1
+
+ \ If the word is null (i.e. a bare space or return), do nothing
+ cmp r0,#0 cmpeq r1,#0
+ yet <> until \ Branch back to the "begin" if r0,r1 = 0
+
+ t: showstack ( -- )
+ bic r8,r8,#2
+ t;
+
+ t: quiet ( -- )
+ orr r8,r8,#2
+ t;
+
+ t: clear ( ?? -- )
+ mov r10,#0 mov r11,#0 mov r12,#0 mov r13,#0 \ Init stack
+ t;
+
+ t: @ ( adr -- n )
+ tst r8,#1 <> if
+ begin ldr r0,[r10] again
+ then
+ ldr r10,[r10]
+ t;
+
+ t: ! ( n adr -- )
+ tst r8,#1 <> if
+ begin str r11,[r10] again
+ then
+ str r11,[r10]
+ pop2
+ t;
+
+ t: !@ ( n adr -- n' )
+ tst r8,#1 <> if
+ begin str r11,[r10] ldr r0,[r10] again
+ then
+ str r11,[r10]
+ ldr r10,[r10]
+ mov r11,r12 mov r12,r13
+ t;
+
+ t: @@ ( adr2 adr1 -- n2 n1 )
+ tst r8,#1 <> if
+ begin ldr r0,[r10] ldr r1,[r11] again
+ then
+ ldr r10,[r10]
+ ldr r11,[r11]
+ t;
+
+ t: !! ( n2 adr2 n1 adr1 -- )
+ tst r8,#1 <> if
+ begin str r11,[r10] str r13,[r12] again
+ then
+ str r11,[r10] str r13,[r12]
+ \ There's no reason to fix the stack because the arguments
+ \ filled it up.
+ t;
+
+ t: !!@ ( n1 adr1 n2 adr2 -- n3 )
+ tst r8,#1 <> if
+ begin str r11,[r10] str r13,[r12] ldr r0,[r10] again
+ then
+ str r11,[r10] str r13,[r12] ldr r10,[r10]
+ \ There's no reason to fix the stack because the arguments
+ \ filled it up.
+ t;
+
+ t: l@ ( adr -- l )
+ tst r8,#1 <> if
+ begin ldr r0,[r10] again
+ then
+ ldr r10,[r10]
+ t;
+
+ t: l! ( l adr -- )
+ tst r8,#1 <> if
+ begin str r11,[r10] again
+ then
+ str r11,[r10]
+ pop2
+ t;
+
+ t: l!@ ( n adr -- n' )
+ tst r8,#1 <> if
+ begin str r11,[r10] ldr r0,[r10] again
+ then
+ str r11,[r10]
+ ldr r10,[r10]
+ mov r11,r12 mov r12,r13
+ t;
+
+ t: c@ ( adr -- b )
+ tst r8,#1 <> if
+ begin ldrb r0,[r10] again
+ then
+ ldrb r10,[r10]
+ t;
+
+ t: c! ( b adr -- )
+ tst r8,#1 <> if
+ begin strb r11,[r10] again
+ then
+ strb r11,[r10]
+ pop2
+ t;
+
+ t: c!@ ( b adr -- b' )
+ tst r8,#1 <> if
+ begin strb r11,[r10] ldrb r0,[r10] again
+ then
+ strb r11,[r10]
+ ldrb r10,[r10]
+ mov r11,r12 mov r12,r13
+ t;
+
+ t: w@ ( adr -- w )
+ tst r8,#1 <> if
+ begin ldrh r0,[r10] again
+ then
+ ldrh r10,[r10]
+ t;
+
+ t: w! ( w adr -- )
+ tst r8,#1 <> if
+ begin strh r11,[r10] again
+ then
+ strh r11,[r10]
+ pop2
+ t;
+
+ t: w!@ ( n adr -- n' )
+ tst r8,#1 <> if
+ begin strh r11,[r10] ldrh r0,[r10] again
+ then
+ strh r11,[r10]
+ ldrh r10,[r10]
+ mov r11,r12 mov r12,r13
+ t;
+
+[ifdef] isa-io-pa
+ t: pc@ ( port# -- b )
+ set r0,`isa-io-pa #`
+ tst r8,#1 <> if
+ begin ldrb r1,[r10,r0] again
+ then
+
+ ldrb r10,[r10,r0]
+ t;
+
+ t: pc! ( b port# -- )
+ set r0,`isa-io-pa #`
+ tst r8,#1 <> if
+ begin strb r11,[r10,r0] again
+ then
+ strb r11,[r10,r0]
+ pop2
+ t;
+
+ t: pw@ ( port# -- w )
+ set r0,`isa-io-pa #`
+ tst r8,#1 <> if
+ begin ldrh r1,[r10,r0] again
+ then
+ ldrh r10,[r10,r0]
+ t;
+
+ t: pw! ( w port# -- )
+ set r0,`isa-io-pa #`
+ tst r8,#1 <> if
+ begin strh r11,[r10,r0] again
+ then
+ strh r11,[r10,r0]
+ pop2
+ t;
+
+ t: pl@ ( port# -- l )
+ set r0,`isa-io-pa #`
+ tst r8,#1 <> if
+ begin ldr r1,[r10,r0] again
+ then
+ ldr r10,[r10,r0]
+ t;
+
+ t: pl! ( l port# -- )
+ set r0,`isa-io-pa #`
+ tst r8,#1 <> if
+ begin str r11,[r10,r0] again
+ then
+ str r11,[r10,r0]
+ pop2
+ t;
+[then]
+
+ t: + ( n1 n2 -- n1+n2 )
+ add r10,r11,r10 mov r11,r12 mov r12,r13
+ t;
+
+ t: - ( n1 n2 -- n1-n2 )
+ sub r10,r11,r10 mov r11,r12 mov r12,r13
+ t;
+
+ t: and ( n1 n2 -- n1&n2 )
+ and r10,r11,r10 mov r11,r12 mov r12,r13
+ t;
+
+ t: or ( n1 n2 -- n1|n2 )
+ orr r10,r11,r10 mov r11,r12 mov r12,r13
+ t;
+
+ t: xor ( n1 n2 -- n1^n2 )
+ eor r10,r11,r10 mov r11,r12 mov r12,r13
+ t;
+
+ t: lshift ( n1 n2 -- n1<<n2 )
+ mov r10,r11,lsl r10 mov r11,r12 mov r12,r13
+ t;
+
+ t: rshift ( n1 n2 -- n1>>n2 )
+ mov r10,r11,lsr r10 mov r11,r12 mov r12,r13
+ t;
+
+ t: invert ( n -- ~n )
+ mvn r10,r10
+ t;
+
+ t: negate ( n -- -n )
+ rsb r10,r10,#0
+ t;
+
+ t: spin ( -- ) \ Modifies next @/!-class command to loop forever
+ mov r8,#1
+ t;
+
+ t: * ( n1 n2 -- n1*n2 )
+ mul r10,r11,r10 mov r11,r12 mov r12,r13
+ t;
+
+ t: . ( n -- )
+ mov r0,r10
+ bl `dot`
+ bl `putcr`
+ pop1
+ t;
+
+ t: move ( src dst len -- )
+ cmp r10,#0
+ <> if
+ cmp r11,r12
+ u< if
+ begin
+ ldrb r0,[r12],#1
+ strb r0,[r11],#1
+ decs r10,1
+ 0= until
+ else
+ begin
+ decs r10,1
+ ldrb r0,[r12,r10]
+ strb r0,[r11,r10]
+ 0= until
+ then
+ then
+ pop3
+ t;
+
+ t: compare ( adr1 adr2 len -- -1 | offset )
+ mov r1,r10 \ Save len for later
+ mvn r0,#0 \ -1 - provisional return value
+ inc r10,1
+ begin
+ decs r10,1
+ 0> while
+ ldrb r2,[r11],#1
+ ldrb r3,[r12],#1
+ cmp r2,r3
+ subne r0,r1,r10
+ <> until
+ then
+ pop3
+ push1
+ mov r10,r0
+ t;
+
+ t: fill ( adr len b -- )
+ begin
+ decs r11,1
+ strgeb r10,[r12],#1
+ < until
+ pop3
+ t;
+
+ t: check ( adr len b -- )
+ begin
+ decs r11,1
+ >= while
+ ldrb r7,[r12],#1
+ cmp r7,r10
+ <> if
+ sub r0,r12,#1 bl `dot`
+ bl `putcolon`
+ mov r0,r7 bl `dot`
+ bl `putcr`
+ then
+ repeat
+ pop3
+ t;
+
+ t: test ( adr len b -- )
+ mov r0,r10
+ mov r1,r11
+ mov r2,r12
+ begin
+ decs r11,1
+ strgeb r10,[r12],#1
+ < until
+ mov r10,r0
+ mov r11,r1
+ mov r12,r2
+ begin
+ decs r11,1
+ >= while
+ ldrb r7,[r12],#1
+ cmp r7,r10
+ <> if
+ sub r0,r12,#1 bl `dot`
+ bl `putcolon`
+ mov r0,r7 bl `dot`
+ bl `putcr`
+ then
+ repeat
+ pop3
+ t;
+
+ t: lfill ( adr len l -- )
+ begin
+ decs r11,4
+ strge r10,[r12],#4
+ < until
+ pop3
+ t;
+
+ t: lcheck ( adr len l -- )
+ begin
+ decs r11,4
+ >= while
+ ldr r7,[r12],#4
+ cmp r7,r10
+ <> if
+ sub r0,r12,#4 bl `dot`
+ bl `putcolon`
+ mov r0,r7 bl `dot`
+ bl `putcr`
+ then
+ repeat
+ pop3
+ t;
+
+ t: ltest ( adr len l -- )
+ mov r0,r10
+ mov r1,r11
+ mov r2,r12
+ begin
+ decs r11,4
+ strge r10,[r12],#4
+ < until
+ mov r10,r0
+ mov r11,r1
+ mov r12,r2
+ begin
+ decs r11,4
+ >= while
+ ldr r7,[r12],#4
+ cmp r7,r10
+ <> if
+ sub r0,r12,#4 bl `dot`
+ bl `putcolon`
+ mov r0,r7 bl `dot`
+ bl `putcr`
+ then
+ repeat
+ pop3
+
+ t;
+
+ t: afill ( adr len -- )
+ begin
+ decs r10,4
+ strge r11,[r11],#4
+ < until
+ pop2
+ t;
+
+ t: acheck ( adr len -- )
+ begin
+ decs r10,4
+ >= while
+ ldr r7,[r11]
+ cmp r7,r11
+ <> if
+ mov r0,r11 bl `dot`
+ bl `putcolon`
+ mov r0,r7 bl `dot`
+ bl `putcr`
+ then
+ add r11,r11,#4
+ repeat
+ pop2
+ t;
+
+ t: atest
+ mov r0,r10
+ mov r1,r11
+ begin
+ decs r10,4
+ strge r11,[r11],#4
+ < until
+ mov r10,r0
+ mov r11,r1
+ begin
+ decs r10,4
+ >= while
+ ldr r7,[r11]
+ cmp r7,r11
+ <> if
+ mov r0,r11 bl `dot`
+ bl `putcolon`
+ mov r0,r7 bl `dot`
+ bl `putcr`
+ then
+ add r11,r11,#4
+ repeat
+ pop2
+ t;
+
+ t: sum ( adr len -- checksum )
+ set r0,0
+ begin
+ decs r10,1
+ ldrgeb r1,[r11],#1
+ addge r0,r0,r1
+ < until
+ pop2
+ push1
+ mov r10,r0
+ t;
+
+ t: erase ( adr len -- )
+ set r0,0
+ begin
+ decs r10,1
+ strgeb r0,[r11],#1
+ < until
+ pop2
+ t;
+
+ t: dump ( adr len -- )
+ begin
+ decs r10,1
+ >= while
+ mov r0,r11 bl `dot`
+ bl `putcolon`
+ ldrb r0,[r11],#1 bl `dot`
+ bl `putcr`
+ repeat
+ pop2
+ t;
+
+ t: ldump ( adr len -- )
+ begin
+ decs r10,4
+ >= while
+ mov r0,r11
+ bl `dot`
+ bl `putcolon`
+ ldr r0,[r11],#4
+ bl `dot`
+ bl `putcr`
+ repeat
+ pop2
+ t;
+
+ t: dup ( n -- n n )
+ mov r13,r12 mov r12,r11 mov r11,r10
+ t;
+
+ t: drop ( n -- )
+ mov r10,r11 mov r11,r12 mov r12,r13
+ t;
+
+ t: swap ( n1 n2 -- n2 n1 )
+ mov r0,r11 mov r11,r10 mov r10,r0
+ t;
+
+ t: over ( n1 n2 -- n1 n2 n1 )
+ mov r13,r12 mov r12,r11 mov r11,r10 mov r10,r12
+ t;
+
+ t: rot ( n1 n2 n3 -- n2 n3 n1 )
+ mov r0,r12 mov r12,r11 mov r11,r10 mov r10,r0
+ t;
+
+ t: -rot ( n1 n2 n3 -- n3 n1 n2 )
+ mov r0,r12 mov r12,r10 mov r10,r11 mov r11,r0
+ t;
+
+ t: icache-on ( -- )
+ mrc p15, 0, r0, cr1, cr0, 0 \ write the control register
+ orr r0, r0, #0x1000 \ Turn on the icache
+ mcr p15, 0, r0, cr1, cr0, 0 \ write the control register
+ t;
+
+ t: icache-off ( -- )
+ mrc p15, 0, r0, cr1, cr0, 0 \ write the control register
+ bic r0, r0, #0x1000 \ Turn off the icache
+ mcr p15, 0, r0, cr1, cr0, 0 \ write the control register
+ t;
+
+ \ Turning on the dcache and write buffer are not so simple, because
+ \ the MMU must be on first.
+
+ t: control@ ( -- n )
+ push1
+ mrc p15, 0, r10, cr1, cr0, 0 \ read the control register
+ t;
+
+ t: control! ( n -- )
+ mcr p15, 0, r10, cr1, cr0, 0 \ write the control register
+ pop1
+ t;
+
+ t: script ( address -- )
+ mov r9,r10
+ orr r8,r8,#0xc \ Set script and no-echo flags
+ pop1
+ t;
+
+ t: rom-script ( offset -- )
+ add r9,r10,`rom-pa #`
+ orr r8,r8,#0xc \ Set script and no-echo flags
+ pop1
+ t;
+
+ t: fexit ( -- )
+ bic r8,r8,#0xc \ Clear script and no-echo flags
+ t;
+
+ t: scripts ( -- )
+ mov r6,#0
+ set r7,`rom-pa h# 10000 + #`
+ begin
+ ldrb r0,[r7]
+ cmp r0,`ascii \ #` \ If the script aread begings
+ = if \ with a comment character
+ \ display "s#: "
+ mov r0,`ascii s #` bl `putchar`
+ add r0,r6,`ascii 0 #` bl `putchar`
+ mov r0,`ascii : #` bl `putchar`
+ bl `putspace`
+ begin \ display the first comment line
+ ldrb r0,[r7],1 \ Get comment byte
+ cmp r0,#0x0d \ Carriage return?
+ cmpne r0,#0x0a \ Line feed?
+ <> while
+ bl `putchar`
+ repeat
+ bl `putcr`
+ then
+ mov r7,r7,lsr #12 \ Clear low bits
+ mov r7,r7,lsl #12
+ add r7,r7,#0x1000 \ Advance to next script
+ add r6,r6,#1
+ cmp r6,#10
+ = until
+ t;
+
+ t: s0 ( -- )
+ set r9,`rom-pa h# 10000 + #`
+ orr r8,r8,#0xc \ Set script and no-echo flags
+ t;
+
+ t: s1 ( -- )
+ set r9,`rom-pa h# 11000 + #`
+ orr r8,r8,#0xc \ Set script and no-echo flags
+ t;
+
+ t: s2 ( -- )
+ set r9,`rom-pa h# 12000 + #`
+ orr r8,r8,#0xc \ Set script and no-echo flags
+ t;
+
+ t: s3 ( -- )
+ set r9,`rom-pa h# 13000 + #`
+ orr r8,r8,#0xc \ Set script and no-echo flags
+ t;
+
+ t: s4 ( -- )
+ set r9,`rom-pa h# 14000 + #`
+ orr r8,r8,#0xc \ Set script and no-echo flags
+ t;
+
+ t: s5 ( -- )
+ set r9,`rom-pa h# 15000 + #`
+ orr r8,r8,#0xc \ Set script and no-echo flags
+ t;
+
+ t: s6 ( -- )
+ set r9,`rom-pa h# 16000 + #`
+ orr r8,r8,#0xc \ Set script and no-echo flags
+ t;
+
+ t: s7 ( -- )
+ set r9,`rom-pa h# 17000 + #`
+ orr r8,r8,#0xc \ Set script and no-echo flags
+ t;
+
+ t: s8 ( -- )
+ set r9,`rom-pa h# 18000 + #`
+ orr r8,r8,#0xc \ Set script and no-echo flags
+ t;
+
+ t: s9 ( -- )
+ set r9,`rom-pa h# 19000 + #`
+ orr r8,r8,#0xc \ Set script and no-echo flags
+ t;
+
+ \ The original intention of "no-echo" and its inverse "echo" was
+ \ to create a capability like "dl" whereby one could download a
+ \ script over the serial line, but without requiring the use of
+ \ memory. However, this has the serious problem that there is
+ \ no flow control, so commands that can take a long time (like
+ \ memory tests) potentially cause input overrun. Consequently,
+ \ it's better to use quiet mode. However, quiet mode has its own
+ \ problem: few if any terminal programs support its character-echo
+ \ flow control technique. Character-echo flow control is not
+ \ particularly great anyway - it can be fooled by generated output
+ \ that happens to contain the next input character.
+ t: no-echo ( -- )
+ orr r8,r8,#0x8 \ Set no-echo flag
+ t;
+
+ t: echo ( -- )
+ bic r8,r8,#0x8 \ Clear no-echo flag
+ t;
+
+ t: cr ( -- )
+ bl `putcr`
+ t;
+
+ t: key ( -- char )
+ bl `getchar`
+ push1 mov r10,r0
+ t;
+
+ t: emit ( char -- )
+ mov r0,r10
+ bl `putchar`
+ pop1
+ t;
+
+ \ This is useful for diagnostics in script mode, but essentially
+ \ useless otherwise.
+ t: .( ( "string" -- )
+ begin
+ tst r8,#4 0<> if \ Script mode
+ ldrb r0,[r9],#1
+ else \ Normal mode
+ bl `getchar` ( char in r0 )
+ then
+ cmp r0,`char ) #`
+ <> while
+ bl `putchar`
+ repeat
+ t;
+
+ \ This is useful for commentary in script mode, but essentially
+ \ useless otherwise.
+ t: \ ( "rest-of-line" -- )
+ begin
+ tst r8,#4 0<> if \ Script mode
+ ldrb r0,[r9],#1
+ else \ Normal mode
+ bl `getchar` ( char in r0 )
+ then
+ cmp r0,#0x0a
+ cmpne r0,#0x0d
+ = until
+ t;
+
+ t: goto ( address -- )
+ mov pc,r10
+ t;
+
+ t: gettext ( address -- length )
+ mov r4,r10
+ begin
+ bl `getchar`
+ cmp r0,#4 \ Control-D (ASCII EOT)
+ <> while
+ strb r0,[r4],#1
+ repeat
+
+ sub r10,r4,r10
+ t;
+
+ t: getbytes ( address length -- )
+ begin
+ decs r10,1
+ 0>= while
+ bl `getchar`
+ strb r0,[r11],#1
+ repeat
+ pop2
+ t;
+
+[ifdef] init-sequoia
+ t: seq@ ( reg# -- w )
+ set r0, `isa-io-pa #`
+ tst r8,#1 <> if
+ begin strh r10,[r0, #0x24] ldrh r10,[r0,#0x26] again
+ then
+ strh r10, [r0, #0x24] \ Point to the register
+ ldrh r10, [r0, #0x26] \ Get the data
+ t;
+
+ t: seq! ( w reg# -- )
+ set r0, `isa-io-pa #`
+ tst r8,#1 <> if
+ begin strh r10,[r0, #0x24] strh r11,[r0,#0x26] again
+ then
+ strh r10, [r0, #0x24] \ Point to the register
+ strh r11, [r0, #0x26] \ Get the data
+ pop2
+ t;
+[then]
+
+[ifdef] rom-pa
+ t: rom ( -- adr )
+ push1 set r10,`rom-pa #`
+ t;
+[then]
+
+[ifdef] isa-io-pa
+ t: io ( -- adr )
+ push1 set r10,`isa-io-pa #`
+ t;
+[then]
+
+[ifdef] mem0-pa
+ t: mem0 ( -- adr )
+ push1 set r10,`mem0-pa #`
+ t;
+[then]
+
+[ifdef] mem1-pa
+ t: mem1 ( -- adr )
+ push1 set r10,`mem1-pa #`
+ t;
+[then]
+
+[ifdef] mem2-pa
+ t: mem2 ( -- adr )
+ push1 set r10,`mem2-pa #`
+ t;
+[then]
+
+[ifdef] mem3-pa
+ t: mem3 ( -- adr )
+ push1 set r10,`mem3-pa #`
+ t;
+[then]
+
+ t: 1m ( -- n )
+ push1 mov r10,#0x100000
+ t;
+
+ t: 1m ( -- n )
+ push1 mov r10,#0x100000
+ t;
+
+ t: 1m ( -- n )
+ push1 mov r10,#0x100000
+ t;
+
+ t: 2m ( -- n )
+ push1 mov r10,#0x200000
+ t;
+
+ t: 4m ( -- n )
+ push1 mov r10,#0x400000
+ t;
+
+ t: 8m ( -- n )
+ push1 mov r10,#0x800000
+ t;
+
+ t: 16m ( -- n )
+ push1 mov r10,#0x1000000
+ t;
+
+ t: 32m ( -- n )
+ push1 mov r10,#0x2000000
+ t;
+
+
+ \ The word was not recognized; parse it as a number or complain
+ bl `convert-number` cmp r1,#0 <> if \ Number in r0
+ \ Push the number
+ push1 mov r10,r0 ( -- n )
+ else
+ \ The word was neither recognized nor numeric; complain
+ mov r0,`char ? #` bl `putchar` bl `putcr`
+ then
+
+ again
+
+end-code
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1997 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/minifth.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/mmu.fth
===================================================================
--- cpu/arm/mmu.fth (rev 0)
+++ cpu/arm/mmu.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,317 @@
+purpose: ARM MMU driver
+\ See license at end of file
+
+\ Definition:
+\ PTE: Page Table Entry - a page descriptor - a 32 number that goes in
+\ a level-2 page table.
+\ PMEG: Page Map Entry Group - a level-2 page table - a group of 256
+\ page table entries.
+
+0 value st-va
+h# 400 constant /pmeg
+h# 10.0000 constant /section
+
+\ Read and write section-table entries.
+: >section ( va -- smadr ) d# 20 rshift st-va swap la+ ;
+: section@ ( va -- ste ) >section l@ ;
+: section! ( ste va -- ) >section l! ;
+
+0 constant st-imp \ 0 or h# 10 - "imp" bit setting
+0 5 lshift constant fw-domain
+h# c02 fw-domain or constant ste-lowbits \ AP=11, C=0, B=0,
+
+0 value pmeg-pa \ Physical address page selector bits for current PMEG
+0 value 'pt-ent \ Location of the pte that is used for mapping ptes
+
+0 value pmeg-section-va \ Virtual address of section used for PMEG access
+
+\ Returns the virtual address where the selected PMEG can be accessed
+: pmeg-va ( -- adr ) pmeg-pa pmeg-section-va or ;
+
+\ Select the PMEG at pmeg-pa by setting the section entry for
+\ pmeg-section-va to refer to it.
+: map-pmeg ( ste|pmeg-pa -- )
+ h# 3ff invert and dup h# 000f.f000 and to pmeg-pa
+ pmeg-section-va flush-d-tlb-entry \ Blast the old entry
+ h# f.f000 invert and ste-lowbits or pmeg-section-va section!
+;
+
+\ Convert a level-1 (section) map entry to a level-2 (page) map entry
+\ with the same permissions and beginning page number. This is used
+\ when converting a section-level mapping to page-level mappings.
+: ste>pte ( ste -- pte )
+ dup h# fff0.000f and swap ( base/cb l1-pte )
+ h# c00 and dup 2 rshift or ( base/cb ap3/2 )
+ dup 4 rshift or or ( base/ap3/2/1/0/cb )
+;
+
+\ Allocate memory for a new page map entry group, install it in the
+\ section table at the appropriate location for va, and create a
+\ temporary virtual mapping for it so we can access it, returning its
+\ temporary virtual address.
+: get-pmeg ( va -- )
+ /pmeg /pmeg mem-claim ( va pte-pa )
+ tuck fw-domain or st-imp or 1 or ( pte-pa va ste )
+ swap section! ( pte-pa )
+ map-pmeg ( )
+;
+
+\ Create a new page map entry group for the section contaning va,
+\ initializing it to consecutive physical pages using base-pte as
+\ a template. To create initially-invalid entries, use 0 for base-pte.
+: new-pmeg ( va base-pte -- )
+ swap get-pmeg ( base-pte adr )
+ pmeg-va /pmeg bounds do dup i l! pagesize + /l +loop ( pte )
+ drop ( )
+;
+
+0 value remapping? \ True if a newly-allocated PMEG will loaded with
+ \ new entries.
+: set-pmeg ( va -- )
+ dup section@ dup 3 and case ( va ste type )
+ 1 of ( va ste )
+ nip map-pmeg ( )
+ endof ( )
+ 2 of ( va ste )
+ ste>pte new-pmeg ( )
+ endof ( )
+ ( default ) ( va ste type )
+ remapping? if ( va ste type )
+ \ We are going to create mappings in the range,
+ \ so create a new PMEG and prime it with invalid PTEs.
+ nip swap 0 new-pmeg ( type )
+ else ( va ste type )
+ \ If we are going to unmap the range
+ \ and it's already unmapped, leave it so.
+ nip nip ( type )
+ then ( type )
+ ( end default ) ( type )
+ endcase ( )
+;
+
+: (pte-setup) ( va -- adr ) d# 10 rshift h# 3fc and pmeg-va + ;
+: (pte!) ( pte va -- ) (pte-setup) l! ;
+: (pte@) ( va -- pte ) (pte-setup) l@ ;
+
+: >pt ( va -- true | offset pte-page-pa false )
+ dup section@ dup 3 and 1 = if ( va ste )
+ h# 3ff invert and ( va pte-page-pa )
+ swap d# 10 rshift h# 3fc and swap ( offset pte-page-pa )
+ false
+ else
+ 2drop true
+ then
+;
+
+: .cb ( s/pment -- )
+ dup 8 and if ." Cacheable" then
+ 4 and if ." Buffered" then
+;
+: .domain ( ste -- ) ." Domain: " d# 5 rshift h# f and . ;
+: .ap ( n bit# -- n ) over swap rshift 3 and (.) type ;
+: .l1-mapping ( va ste -- )
+ push-hex
+ ." Section-mapped - Physical: " ( va ste )
+ swap h# fffff and over h# fffff invert and or 8 u.r ( ste )
+ ." AP: " d# 10 .ap space ( ste )
+ dup .domain ( ste )
+ dup h# 10 and if ." IMP" then ( ste )
+ .cb ( )
+ cr
+ pop-base
+;
+: .l2-mapping ( va ste -- )
+ push-hex
+ ." PMEG at: " dup h# ffff.fc00 and 8 u.r ( va ste )
+ dup .domain ( va ste )
+ map-pmeg dup (pte@) cr ( va pte )
+ dup 3 and 1 2 between if ( va pte )
+ dup 3 and 1 = if ( va pte )
+ ." 64K" h# ffff ( va pte mask )
+ else ( va pte )
+ ." 4K" h# 0fff ( va pte mask )
+ then ( va pte mask )
+ ." Physical: " rot over and ( pte mask val )
+ -rot invert over and rot or 8 u.r ( pte )
+ ." AP: " ( pte )
+ d# 10 .ap ." ," 8 .ap ." ," 6 .ap ." ," 4 .ap space ( pte )
+ .cb ( )
+ else ( va pte )
+ 2drop ." Not Mapped" ( )
+ then ( )
+ cr
+ pop-base
+;
+
+: map? ( va -- )
+ dup section@ dup 3 and case ( va ste type )
+ 1 of .l2-mapping endof
+ 2 of .l1-mapping endof
+ ( default: va ste type )
+ ." Not mapped at section level" 3drop exit
+ endcase
+;
+
+\ "Circular arithmetic" max and min. In circular arithmetic, 0 is greater
+\ than ff00.0000. The use of these operators instead of umax and umin
+\ correctly handles the case where an address range ends at 2^^32, which
+\ looks like 0 in 32-bit twos-complement arithmetic.
+: cmax ( adr1 adr2 -- max ) 2dup - 0> if drop else nip then ;
+: cmin ( adr1 adr2 -- min ) 2dup - 0< if drop else nip then ;
+
+\ Break the range into three ranges -
+\ The range on top of the stack goes from adr up to the first section boundary
+\ The middle range goes from the first to the last section boundary
+\ The last range goes from the last section boundary to adr+len
+\ Some ranges may be zero-length
+: split-range ( adr len -- end end-sec end-sec start-sec start-sec start )
+ bounds ( end start )
+ over /section round-down over cmax tuck swap ( end end-sec end-sec start )
+ 2dup /section round-up cmin tuck swap
+ ( end end-sec end-sec start-sec start-sec start )
+;
+
+: ?set-pmeg ( end start -- end start ) 2dup <> if dup set-pmeg then ;
+
+: ?release-pmeg ( va -- va )
+ dup section@ 3 and 1 = if \ Reclaim old PMEG ( va )
+ dup section@ h# ffff.fc00 and /pmeg mem-release ( va )
+ then ( va )
+;
+: invalidate-page ( va -- ) 0 swap (pte!) ;
+: invalidate-section ( va -- ) ?release-pmeg 0 swap section! ;
+
+: remap-pages ( mode pa va-end va-start -- mode pa' )
+ ?do ( mode pa )
+ over ste>pte over or i (pte!) ( mode pa )
+ pagesize + ( mode pa' )
+ pagesize +loop ( mode pa' )
+;
+
+: remap-sections ( pa mode va-end va-start mode -- pa' mode )
+ ?do ( mode pa )
+ dup h# f.f000 and if ( mode pa )
+ \ Physical not aligned; use page-level mappings
+ i section@ 3 and 1 = if \ Reuse old PMEG ( mode pa )
+ i section@ map-pmeg ( mode pa )
+ else \ Allocate a new PMEG ( mode pa )
+ i get-pmeg ( mode pa )
+ then ( mode pa )
+ i /section bounds remap-pages ( mode pa' )
+ else ( mode pa )
+ \ Physical is aligned; use section-level mappings
+ i ?release-pmeg drop ( mode pa )
+ 2dup or i section! ( mode pa )
+ /section + ( mode pa' )
+ then ( mode pa' )
+ /section +loop ( mode pa )
+;
+
+: remap-range ( phys mode adr len -- )
+ true to remapping?
+ 2swap 2 or swap h# fff invert and ( adr len mode pa )
+ 2>r split-range 2r> ( d.r2 d.r1 d.r0 mode pa )
+
+ 2swap ?set-pmeg remap-pages ( d.r2 d.r1 mode pa' )
+ 2swap ?set-pmeg remap-sections ( d.r2 mode pa' )
+ 2swap ?set-pmeg remap-pages ( mode pa' )
+
+ 2drop ( )
+;
+
+\ XXX Perhaps we should invalidate the cache within this range.
+: unmap-range ( adr len -- )
+ 2dup invalidate-cache-range
+ false to remapping?
+ split-range ( d.range2 d.range1 d.range0 )
+ ?set-pmeg ?do i invalidate-page pagesize +loop ( d.range2 d.range1 )
+ ?do i invalidate-section /section +loop ( d.range2 )
+ ?set-pmeg ?do i invalidate-page pagesize +loop ( )
+;
+
+: (shootdown-range) ( adr len -- )
+ over swap 2>r ( adr r: adr len )
+ translate ( false | phys mode true r: adr len )
+ if 2r> remap-range else 2r> unmap-range then
+ flush-i&d-tlb
+;
+' (shootdown-range) to shootdown-range
+
+: (map-mode) ( phys.. mode -- mode' )
+ >r memory? r> ( memory? mode )
+ dup -2 -1 between if ( memory? -1 )
+ drop if ( )
+ h# c0c \ Memory: AC=3, C=1, B=1
+ else ( )
+ h# c00 \ I/O: AC=3, C=0, B=0
+ then ( mode' )
+ else ( memory? mode )
+ nip ( mode )
+ then ( mode' )
+;
+' (map-mode) to map-mode
+
+headerless
+list: translations-list
+
+\ After initial-mmu-setup exits, the mmu must be on and st-va must
+\ be set to the virtual address of the section table.
+defer initial-mmu-setup ( -- ) ' noop to initial-mmu-setup
+defer initial-claim ( -- ) ' noop to initial-claim
+defer initial-map ( -- ) ' noop to initial-map
+
+: init-virtual-list ( -- )
+ 0 memrange ! \ Clear free list
+
+ \ Create the available memory list from which the firmware is allowed
+ \ to dynamically allocate virtual memory.
+
+ fw-virt-base fw-virt-size set-node fwvirt insert-after
+
+ \ Setup the virtual list from which the firmware isn't permitted to allocate
+ 0 fw-virt-base add-os-piece
+ fw-virt-base fw-virt-size + 0 add-os-piece
+;
+
+headers
+warning off
+: open ( -- )
+ initial-mmu-setup \ Do platform-specific stuff as necessary
+
+ init-virtual-list
+
+ initial-claim \ Claim any pre-committed platform-specific addresses
+
+ \ Grab a Meg of virtual address space to use for temporary PMEG access
+ /section /section claim to pmeg-section-va
+
+ translations-list to translations
+
+ initial-map \ Set up platform-specific hardcoded translations
+ true
+;
+warning on
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1997 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/mmu.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/muldiv.fth
===================================================================
--- cpu/arm/muldiv.fth (rev 0)
+++ cpu/arm/muldiv.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,366 @@
+purpose: Multiply and divide
+\ See license at end of file
+
+[ifdef] fixme
+0 value StrongARM?
+[else]
+0 value arm4?
+[then]
+
+hex
+code * ( n1 n2 -- n3 ) pop r0,sp mul tos,r0,tos c;
+code u* ( u1 u2 -- u3 ) pop r0,sp mul tos,r0,tos c;
+
+code um* ( u1 u2 -- ud )
+[ifdef] fixme
+ ldr r0,'user StrongARM?
+[else]
+ ldr r0,'user arm4?
+[then]
+ cmp r0,#0
+ <> if
+ pop r4,sp
+ umull r1,r0,tos,r4
+ psh r1,sp
+ mov tos,r0
+ next
+ then
+ mov r6,#0xff
+ orr r6,r6,#0xff00
+ and r0,r6,tos \ r0: lu2
+ and r1,r6,tos,lsr #0x10 \ r1: tu2
+ ldr tos,[sp]
+ and r2,r6,tos \ r2: lu1
+ and r3,r6,tos,lsr #0x10 \ r3: tu1
+
+ mul r4,r0,r2 \ low
+ mul r6,r0,r3 \ interm
+ mul tos,r1,r3 \ upper
+ mul r0,r1,r2 \ interm
+
+ adds r0,r0,r6
+ inccs tos#0x10000
+ adds r4,r4,r0,lsl #0x10
+ adc tos,tos,r0,lsr #0x10 \ adding CARRY
+ str r4,[sp]
+c;
+
+code m* ( n1 n2 -- d )
+[ifdef] fixme
+ ldr r0,'user StrongARM?
+[else]
+ ldr r0,'user arm4?
+[then]
+ cmp r0,#0
+ <> if
+ pop r4,sp
+ smull r1,r0,tos,r4
+ psh r1,sp
+ mov tos,r0
+ next
+ then
+ mov r5,#0 \ clear change-sign flag
+ mov r6,#0xff
+ orr r6,r6,#0xff00
+ cmps tos,#0
+ rsblt tos,tos,#0
+ mvnlt r5,r5 \ setting flag
+ and r0,r6,tos \ r0: lu2
+ and r1,r6,tos,lsr #0x10 \ r1: tu2
+ pop tos,sp
+ cmps tos,#0
+ rsblt tos,tos,#0
+ mvnlt r5,r5
+ and r2,r6,tos \ r2: lu1
+ and r3,r6,tos,lsr #0x10 \ r3: tu1
+
+ mul r4,r0,r2 \ low
+ mul r6,r0,r3 \ interm
+ mul tos,r1,r3 \ upper
+ mul r0,r1,r2 \ interm
+
+ adds r0,r0,r6
+ inccs tos,#0x10000
+ adds r4,r4,r0,lsl #0x10
+ adc tos,tos,r0,lsr #0x10 \ adding CARRY
+ cmps r5,#0
+ <> if
+ decs r4,#1
+ sbc tos,tos,#0
+ mvn r4,r4
+ mvn tos,tos
+ then
+ psh r4,sp
+c;
+
+\ (32/32division) does a 32/32bit unsigned division
+\ r0 / tos = r0.rem tos.quot
+code (32/32division)
+ mov r3,#1
+\ cmp tos,#0
+\ ' divide-error dolink eq branch
+ begin
+ cmp tos,#0x80000000
+ cmpcc tos,r0
+ movcc tos,tos,lsl #1
+ movcc r3,r3,lsl #1
+ u>= until
+ mov r2,#0
+ begin
+ cmp r0,tos
+ subcs r0,r0,tos
+ addcs r2,r2,r3
+ movs r3,r3,lsr #1
+ movne tos,tos,lsr #1
+ 0= until
+ mov tos,r2
+ mov pc,lk
+end-code
+
+code (u64division)
+ stmdb sp!,{r7,r8,r9}
+ mov r6,#0
+ mov r7,#1
+ mov r4,#0
+ mov r5,#0
+ orrs r8,r2,r3
+\ ' divide-error bleq *
+ begin
+ cmp r2,#0x80000000
+ u< if
+ cmp r2,r0
+ cmpeq r3,r1
+ u< if
+ mov r2,r2,lsl #1
+ orr r2,r2,r3,lsr #0x1f
+ mov r3,r3,lsl #1
+ mov r6,r6,lsl #1
+ orr r6,r6,r7,lsr #0x1f
+ mov r7,r7,lsl #1
+ then
+ then
+ u>= until
+ begin
+ cmp r0,r2
+ cmpeq r1,r3
+ u>= if
+ subs r1,r1,r3
+ sbc r0,r0,r2
+ adds r5,r5,r7
+ adc r4,r4,r6
+ then
+ movs r6,r6,lsr #1
+ mov r7,r7,ror #0
+ orrs r8,r6,r7
+ 0<> if
+ movs r2,r2,lsr #1
+ mov r3,r3,ror #0
+ then
+ orrs r8,r6,r7
+ 0= until
+ ldmia sp!,{r7,r8,r9}
+ mov pc,lk
+end-code
+
+\ unsigned 64/64bit division (u64division)
+\ r0 -> r0.h-r1.l r1 -> r2.h-r3.l
+\ r2 -> r4.h-r5.l r3 -> r6.h-r7.l
+\ r01 / r23 = r01.rem r45.quot
+code du/mod ( ud1 ud2 -- du.rem du.quot )
+ mov r2,tos
+ pop r3,sp
+ pop r0,sp
+ pop r1,sp
+ bl 'code (u64division)
+ psh r1,sp
+ psh r0,sp
+ psh r5,sp
+ mov tos,r4
+c;
+
+code um/mod ( ud u1 -- u.rem u.quot )
+ mov r2,#0
+ mov r3,tos
+
+ pop r0,sp
+ pop r1,sp
+ bl 'code (u64division)
+ psh r1,sp
+ mov tos,r5
+c;
+code mu/mod ( ud u1 -- u.rem ud.quot )
+ mov r2,#0
+ mov r3,tos
+ pop r0,sp
+ pop r1,sp
+ bl 'code (u64division)
+ psh r1,sp
+ psh r5,sp
+ mov tos,r4
+c;
+
+code fm/mod ( d.dividend s.divisor -- s.rem s.quot )
+ mov r3,tos
+ mov r2,tos,asr #0 \ sign extend divisor
+ pop r0,sp
+ pop r1,sp
+ stmdb sp!,{r8,r9}
+ cmp r0,#0
+ < if
+ rsbs r1,r1,#0
+ rsc r0,r0,#0
+ cmp r2,#0
+ < if
+ rsbs r3,r3,#0
+ rsc r2,r2,#0
+ bl 'code (u64division)
+ rsbs r1,r1,#0
+ rsc r0,r0,#0
+ else
+ mov r8,r2
+ mov r9,r3
+ bl 'code (u64division)
+ rsbs r5,r5,#0
+ rsc r4,r4,#0
+ orrs tos,r0,r1
+ 0<> if
+ subs r5,r5,#1
+ sbc r4,r4,#0
+ subs r1,r9,r1
+ sbc r0,r8,r0
+ then
+ then
+ else
+ cmp r2,#0
+ < if
+ mov r8,r2
+ mov r9,r3
+ rsbs r3,r3,#0
+ rsc r2,r2,#0
+ bl 'code (u64division)
+ rsbs r5,r5,#0
+ rsc r4,r4,#0
+ orrs tos,r0,r1
+ 0<> if
+ subs r5,r5,#1
+ sbc r4,r4,#0
+ adds r1,r1,r9
+ adc r0,r0,r8
+ then
+ else
+ bl 'code (u64division)
+ then
+ then
+ ldmia sp!,{r8,r9}
+ psh r1,sp
+ mov tos,r5
+c;
+
+code u/mod ( u.dividend u.divisor -- u.rem u.quot )
+ ldr r0,[sp]
+ ' (32/32division) bl * \ r0 / tos = r0.rem tos.quot
+ str r0,[sp]
+c;
+
+code /mod ( n.dividend s.divisor -- s.rem s.quot )
+ ldr r0,[sp]
+ cmp r0,#0
+ < if
+ rsb r0,r0,#0
+ cmp tos,#0
+ < if
+ rsb tos,tos,#0
+ bl 'code (32/32division) \ r0 / tos = r0.rem tos.quot
+ rsb r0,r0,#0
+ else
+ mov r4,tos
+ bl 'code (32/32division) \ r0 / tos = r0.rem tos.quot
+ rsb tos,tos,#0
+ cmp r0,#0
+ decne tos,#1
+ subne r0,r4,r0
+ then
+ else
+ cmp tos,#0
+ < if
+ mov r4,tos
+ rsb tos,tos,#0
+ bl 'code (32/32division) \ r0 / tos = r0.rem tos.quot
+ rsb tos,tos,#0
+ cmp r0,#0
+ decne tos,#1
+ addne r0,r0,r4
+ else
+ bl 'code (32/32division) \ r0 / tos = r0.rem tos.quot
+ then
+ then
+ str r0,[sp]
+c;
+
+code sm/rem ( d.dividend s.divisor -- s.rem s.quot )
+ mov r3,tos
+ mov r2,tos,asr #0
+ pop r0,sp
+ pop r1,sp
+ cmp r0,#0 \ dividend <0
+ < if
+ rsbs r1,r1,#0
+ rsc r0,r0,#0
+ cmp r2,#0 \ divisor <0
+ < if
+ rsbs r3,r3,#0
+ rsc r2,r2,#0
+ bl 'code (u64division)
+ rsbs r1,r1,#0
+ rsc r0,r0,#0
+ else
+ bl 'code (u64division)
+ rsbs r1,r1,#0
+ rsc r0,r0,#0
+ rsbs r5,r5,#0
+ rsc r4,r4,#0
+ then
+ else
+ cmp r2,#0 \ divisor <0
+ < if
+ rsbs r3,r3,#0
+ rsc r2,r2,#0
+ bl 'code (u64division)
+ rsbs r5,r5,#0
+ rsc r4,r4,#0
+ else
+ bl 'code (u64division)
+ then
+ then
+ psh r1,sp
+ mov tos,r5
+c;
+
+: / ( dividend divisor -- quotient ) /mod nip ;
+: mod ( dividend divisor -- modulus ) /mod drop ;
+: */mod ( n1 n2 n3 -- n.mod n.quot ) >r m* r> fm/mod ;
+: */ ( n1 n2 n3 -- n4 ) */mod nip ;
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1997 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/muldiv.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/native.bth
===================================================================
--- cpu/arm/native.bth (rev 0)
+++ cpu/arm/native.bth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,10 @@
+purpose: Build file for native.dic
+
+dictionary: ${BP}/cpu/arm/build/tools.dic
+command: &armforth &dictionary &this
+build-now
+
+fload ${BP}/ofw/tokenizer/tokenize.fth
+fload ${BP}/forth/lib/builder.fth
+
+.( --- Saving native.dic --- ) cr "" native.dic save-forth
Property changes on: cpu/arm/native.bth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/objcode.fth
===================================================================
--- cpu/arm/objcode.fth (rev 0)
+++ cpu/arm/objcode.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,101 @@
+purpose: Code words for support of multiple-code-field objects
+\ See license at end of file
+
+code >code-adr ( acf -- code-adr )
+ r0 top ) ldr
+ r0 r0 8 #lsl mov
+ top top r0 6 #asr add
+ top 2 cells incr c;
+
+\ As i understand your high-level definition of >action-adr
+\ it assumes action to be: 0 < action# <= #actions, is this ok?
+\ Testing for action#=0 not necessary?
+
+code >action-adr ( object-acf action# -- ... )
+( ... -- object-acf action# #actions true | object-apf action-adr false )
+\ !!!! the next line should ONLY be included for RiscOS Forthmacs testing
+\ BASE 'body origin pcr ldr
+ r1 sp ) ldr \ r1: object-acf top: action#
+
+ r0 r1 ) ldr \ r0: object-code-field
+ r0 r0 8 #asl mov \ remove opcode bits
+ r0 r1 r0 6 #asr add \ r0: adr of object ;code clause - 8
+
+ \ adding /cell is the same as adding
+ \ 8 then subtracting 4
+ r0 /cell incr \ r0: object-#actions-adr r1: obj-acf
+
+ r2 r0 ) ldr \ r2: #actions
+ top r2 cmp \ action# greater #actions
+gt if top r2 2 sp db! stm \ push action# and #actions
+ top -1 # mov \ return true
+ next
+then \ r0: object-#actions-adr r1: object-acf r2: #actions top: action#
+
+ r0 r0 top 2 #asl sub \ r0: adr of action cell
+ r0 r0 ) ldr \ r0: action-adr
+\ r0 r0 BASE add
+ \ r0: object-action-adr r1: object-acf top: action#
+ r1 /cell incr \ r1: object-apf
+ r1 sp ) str \ put object-apf on stack
+ r0 sp push \ push action-adr
+ top 0 # mov c; \ return false
+
+\ Object data structure:
+\
+\ Created by object defining words (actions, action:, etc):
+\
+\ tokenN-1 tokenN-1 ... token1 #actions (does-clause) ...
+\ |________|________|________|________|________|________
+
+: action-name \ name ( action# -- )
+ create ,
+ ;code
+\ !!!! the next line should ONLY be included for RiscOS Forthmacs testing
+ \ BASE 'body origin pcr ldr \ Test
+\ r0 top ) ldr \ r0: action#
+
+ r0 get-link
+ r0 r0 ) ldr \ r0: action#
+
+ r2 ip )+ ldr
+\ r2 r2 BASE add \ r2: object-acf
+ top sp push \ make room on stack
+ top r2 /cell # add \ top: object-apf
+
+ r3 r2 ) ldr \ r3: object-code-field
+ r3 r3 8 #lsl mov \ remove opcode bits
+ r3 r2 r3 6 #asr add \ r3: adr of object ;code clause - 8
+ r3 2 cells incr \ r3:object-code-adr
+
+ r0 1 incr \ r0: index to action-cell
+ r3 r3 r0 2 #asl sub \ r3: adr of action cell
+\ I am not sure about implementing execute, here the pc is just
+\ set to token@
+ pc r3 ) ldr \ execute action
+\ pc r3 BASE add
+c;
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2006 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/objcode.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/objsup.fth
===================================================================
--- cpu/arm/objsup.fth (rev 0)
+++ cpu/arm/objsup.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,109 @@
+purpose: Machine dependent support routines used for the objects package.
+\ See license at end of file
+
+\ These words know intimate details about the Forth virtual machine
+\ implementation.
+
+\ Assembles the common code executed by actions. That code
+\ extracts the next token (which is the acf of the object) from the
+\ code stream and leaves the corresponding apf on the stack.
+
+headerless
+
+: start-code ( -- ) code-cf !csp ;
+
+\ Assembles code to begin a ;code clause
+: start-;code ( -- ) start-code ;
+
+\ Code field for an object action.
+: doaction ( -- ) acf-align colon-cf ;
+
+code >action-adr ( object-acf action# -- ... )
+( ... -- object-acf action# #actions true | object-apf action-adr false )
+\ !!!! the next line should ONLY be included for RiscOS Forthmacs testing
+\ ldr base,[pc,`'body origin swap here 8 + - swap']
+ ldr r1,[sp] \ r1: object-acf top: action#
+
+ ldr r0,[r1] \ r0: object-code-field
+ mov r0,r0,lsl #8 \ remove opcode bits
+ add r0,r1,r0,asr #6 \ r0: adr of object ;code clause - 8
+
+ \ adding /cell is the same as adding
+ \ 8 then subtracting 4
+ inc r0,1cell \ r0: object-#actions-adr r1: obj-acf
+
+ ldr r2,[r0] \ r2: #actions
+ cmp tos,r2 \ action# greater #actions
+ > if
+ stmdb sp!,{tos,r2} \ push action# and #actions
+ mvn tos,#0 \ return true
+ next
+ then
+
+ \ r0: object-#actions-adr r1: object-acf r2: #actions tos: action#
+ sub r0,r0,tos,lsl #2 \ r0: adr of action cell
+ ldr r0,[r0] \ r0: action-adr
+\ add r0,r0,base
+
+ \ r0: object-action-adr r1: object-acf tos: action#
+ inc r1,1cell \ r1: object-apf
+ str r1,[sp] \ put object-apf on stack
+ psh r0,sp \ push action-adr
+ mov tos,#0 \ return false
+c;
+
+headers
+: action-name \ name ( action# -- )
+ create ,
+ ;code
+\ !!!! the next line should ONLY be included for RiscOS Forthmacs testing
+\ ldr base,[pc,`'body origin swap here 8 + - swap`] \ Test
+\ ldr r0,[tos] \ r0: action#
+
+ lnk r0
+ ldr r0,[r0] \ r0: action#
+
+ ldr r2,[ip],1cell
+\ add r2,r2,base \ r2: object-acf
+ psh tos,sp \ make room on stack
+ add tos,r2,1cell \ tos: object-apf
+
+ ldr r3,[r2] \ r3: object-code-field
+ mov r3,r3,lsl #8 \ remove opcode bits
+ add r3,r2,r3,asr #6 \ r3: adr of object ;code clause - 8
+ inc r3,2cells \ r3:object-code-adr
+
+ inc r0,#1 \ r0: index to action-cell
+ sub r3,r3,r0,lsl #2 \ r3: adr of action cell
+\ I am not sure about implementing execute, here the pc is just
+\ set to token@
+ ldr pc,[r3] \ execute action
+\ add pc,r3,base
+c;
+
+: >action# ( apf -- action# ) @ ;
+headers
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1997 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/objsup.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/psr.fth
===================================================================
--- cpu/arm/psr.fth (rev 0)
+++ cpu/arm/psr.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,54 @@
+purpose: Access functions for processor status register
+\ See license at end of file
+
+code psr@ ( -- n ) psh tos,sp mrs tos,cpsr c;
+code psr! ( n -- ) msr cpsr,tos pop tos,sp c;
+
+h# 80 constant interrupt-enable-bit
+: interrupt-enable@ ( -- n ) psr@ interrupt-enable-bit and ;
+: interrupt-enable! ( n -- ) psr@ interrupt-enable-bit invert and or psr! ;
+
+headerless
+: (disable-interrupts) ( -- ) psr@ interrupt-enable-bit or psr! ;
+: (enable-interrupts) ( -- ) psr@ interrupt-enable-bit invert and psr! ;
+: interrupts-enabled? ( -- yes? ) interrupt-enable@ 0= ;
+
+code (lock) ( -- ) ( R: -- oldMSR )
+ mrs r0,cpsr
+ psh r0,rp
+ orr r0,r0,#0x80
+ msr cpsr,r0
+c;
+code (unlock) ( -- ) ( R: oldMSR -- )
+ pop r0,rp
+ msr cpsr,r0
+c;
+
+' (enable-interrupts) to enable-interrupts
+' (disable-interrupts) to disable-interrupts
+' (lock) to lock[
+' (unlock) to ]unlock
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1997 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/psr.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/regacc.fth
===================================================================
--- cpu/arm/regacc.fth (rev 0)
+++ cpu/arm/regacc.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,36 @@
+purpose: Register access words for ARM
+\ See license at end of file
+
+\ We assume that all devices of interest are mapped with write-buffering
+\ disabled.
+
+alias rl@ l@ ( addr -- l )
+alias rl! l! ( l addr -- )
+alias rw@ w@ ( addr -- w )
+alias rw! w! ( w addr -- )
+alias rb@ c@ ( addr -- b )
+alias rb! c! ( b addr -- )
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1997 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/regacc.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/register.fth
===================================================================
--- cpu/arm/register.fth (rev 0)
+++ cpu/arm/register.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,420 @@
+purpose: Common code to managed saved program state
+\ See license at end of file
+
+\ Requires:
+\
+\ >state ( offset -- addr )
+\ Returns an address within the processor state array given the
+\ offset into that array
+\
+\ Defines:
+\
+\ register names
+\ .registers
+
+needs action: objects.fth
+
+decimal
+headerless
+
+only forth hidden also forth also definitions
+
+\ GP regs PSR state-stuff
+d# 16 1+ 4 +
+
+[ifdef] save-fp-regs
+8 3 * +
+[then]
+
+/l* constant /save-area
+
+: state-valid ( -- addr ) d# 40 /l* >state ;
+: ?saved-state ( -- )
+ state-valid @ 0= abort" No program state has been saved in this session."
+;
+
+: clear-save-area ( -- ) 0 >state /save-area erase ;
+
+: >vmem ;
+
+3 actions
+action: @ ?saved-state >state @ ;
+action: @ >state ! ; ( is )
+action: @ >state ; ( addr )
+: reg \ name ( offset -- )
+ create /l* ,
+ use-actions
+;
+: regs \ name name ... ( start #regs -- )
+ bounds ?do i reg loop
+;
+
+[ifdef] save-fp-regs
+: l@+ ( adr -- l adr' ) dup l@ swap la1+ ;
+: l!- ( l adr -- adr' ) tuck l! -1 la+ ;
+3 actions
+action: @ ?saved-state >state l@+ l@+ l@+ ;
+action: @ >state 2 la+ l!- l!- l!- ; ( is )
+action: @ >state ; ( addr )
+: freg \ name ( offset -- )
+ create /l* ,
+ use-actions
+;
+: fregs \ name name ... ( start #regs -- )
+ 3 * bounds ?do i freg 3 +loop
+;
+[then]
+
+headers
+[ifdef] new-frame
+ 0 1 regs psr
+
+ 1 8 regs r0 r1 r2 r3 r4 r5 r6 r7
+ 9 8 regs r8 r9 r10 r11 r12 r13 r14 r15
+
+10 4 regs up tos rp ip
+14 3 regs sp lr pc
+16 1 regs rpc
+[else]
+ 0 8 regs r0 r1 r2 r3 r4 r5 r6 r7
+ 8 8 regs r8 r9 r10 r11 r12 r13 r14 r15
+
+ 9 4 regs up tos rp ip
+13 3 regs sp lr pc
+15 1 regs rpc
+
+16 1 regs psr
+[then]
+
+17 1 regs exception-psr
+18 3 regs %saved-my-self %state-valid %restartable?
+
+[ifdef] save-fp-regs
+21 8 fregs f0 f1 f2 f3 f4 f5 f6 f7
+[then]
+
+\ Following words defined here to satisfy the
+\ references to these "variables" anywhere else
+: saved-my-self ( -- addr ) addr %saved-my-self ;
+: restartable? ( -- addr ) addr %restartable? ;
+
+headerless
+: .lx ( l -- ) base @ >r hex 9 u.r r> base ! ;
+
+: .mode ( n -- )
+ case
+ h# 10 of ." User32" endof
+ h# 11 of ." FIQ32" endof
+ h# 12 of ." IRQ32" endof
+ h# 13 of ." SVC32" endof
+ h# 17 of ." Abort32" endof
+ h# 1b of ." Undef32" endof
+ h# 1f of ." System32" endof
+ endcase
+;
+headers
+: .psr ( -- )
+ psr " nzcv~~~~~~~~~~~~~~~~~~~~ift~~~~~" show-bits
+ ." _" psr h# 1f and .mode
+;
+: .registers ( -- )
+ ?saved-state
+ ??cr
+." r0 r1 r2 r3 r4 r5 r6 r7" cr
+ r0 .lx r1 .lx r2 .lx r3 .lx r4 .lx r5 .lx r6 .lx r7 .lx
+cr cr
+." r8 r9/up r10/tos r11/rp/fp r12/ip r13/sp r14/lr pc" cr
+ r8 .lx r9 .lx r10 .lx r11 .lx r12 .lx r13 .lx r14 .lx r15 .lx
+cr cr
+." PSR = " .psr
+cr
+;
+
+headerless
+only forth also hidden also forth definitions
+
+: enterforth ( -- )
+ state-valid on
+ my-self to %saved-my-self
+ handle-breakpoint
+;
+
+also arm-assembler definitions
+: 'state ( "name" -- )
+ r0 drop rb-field
+ [ also forth ]
+ safe-parse-word ['] forth $vfind 0= abort" Bad saved register name"
+ >body @
+ [ previous ]
+ set-offset
+;
+previous definitions
+
+h# e600.0010 value breakpoint-opcode
+
+\ The is the first half of the state restoration procedure. It executes
+\ in normal state (e.g user state when running under an OS)
+code (restart ( -- )
+ \ Restore the Forth stacks.
+
+ \ Establish the Data and Return stacks
+ ldr rp,'user rp0
+ ldr sp,'user sp0
+
+ \ Restore the Forth Data and Return stacks from the save area.
+
+ \ Data Stack
+ ldr r3,'user sp0
+ dec r3,`ps-size #` \ Address of data stack area
+ ldr r0,'user pssave \ Address of data stack save area
+ mov r1,`ps-size /l / #` \ Size of data stack area in longwords
+
+ begin
+ ldr r2,[r0],1cell
+ str r2,[r3],1cell
+ subs r1,r1,#1
+ 0= until
+
+ \ Return Stack
+ ldr r3,'user rp0
+ dec r3,`rs-size #` \ Address of return stack area
+ ldr r0,'user rssave \ Address of return stack save area
+ mov r1,`rs-size /l / #` \ Size of return stack area in longwords
+
+ begin
+ ldr r2,[r0],1cell
+ str r2,[r3],1cell
+ subs r1,r1,#1
+ 0= until
+
+ \ The following code communicates with the first part of "save-state".
+ \ See the description there.
+
+
+ \ Remember offset
+ here 'code (restart drop - >r
+
+ \ Take another trap, so we can fix up the PC's in the signal handler
+ breakpoint-opcode asm, \ Undefined instruction
+
+end-code
+
+r> constant restart-offset
+
+\ This is the second half of the state saving procedure. It executes
+\ in normal state (not exception state).
+
+label finish-save
+
+ \ Find the user area
+ adr up,'body main-task \ Get user pointer address
+ ldr up,[up] \ Get user pointer
+
+ \ Establish the Data and Return stacks
+
+ \ Copy the entire Forth Data and Return stacks areas to a save area.
+
+ \ Data Stack
+ ldr r3,'user sp0
+ dec r3,`ps-size #` \ Address of data stack area
+ ldr r0,'user pssave \ Address of data stack save area
+ mov r1,`ps-size /l / #` \ Size of data stack area in longwords
+
+ begin
+ ldr r2,[r3],1cell
+ str r2,[r0],1cell
+ subs r1,r1,#1
+ 0= until
+
+ ldr sp,'user sp0
+
+ \ Return Stack
+ ldr r3,'user rp0
+ dec r3,`rs-size #` \ Address of return stack area
+ ldr r0,'user rssave \ Address of return stack save area
+ mov r1,`rs-size /l / #` \ Size of return stack area in longwords
+
+ begin
+ ldr r2,[r3],1cell
+ str r2,[r0],1cell
+ subs r1,r1,#1
+ 0= until
+
+ ldr rp,'user rp0
+
+ \ Adjust the stack pointer to account for the top of stack register
+ inc sp,1cell
+
+ \ Restart the Forth interpreter.
+
+ \ Execute enterforth
+ adr ip,'body enterforth
+c;
+
+label restart-common
+ \ Entry: r13: cpu-state others: scratch
+
+ \ In the early part of this code, we don't have to be too careful
+ \ about register usage, because we will eventually restore all the
+ \ registers to saved values.
+
+ mov r0,r13 \ Get cpu-state address into r0
+
+ ldr r3,'state r13 \ Get r13 for return mode
+ ldr r4,'state r14 \ Get r14 for return mode
+
+ mrs r2,cpsr \ Get PSR for this mode
+ ldr r1,'state psr \ Get PSR for return mode
+ msr spsr,r1 \ Put it in place
+
+ tst r1,#0xf \ Check for user mode
+ orreq r1,r1,#0xf \ Set system mode if previous mode was user
+ orr r1,r1,#0x80 \ Disable interrupts
+ msr cpsr,r1 \ Get into the return mode
+
+ mov r13,r3 \ Set r13 in return mode
+ mov r14,r4 \ Set r14 in return mode
+
+ msr cpsr,r2 \ Get back into undef mode
+
+ ldr r14,'state pc \ Get PC for return mode
+
+ ldmia r0,{r0,r1,r2,r3,r4,r5,r6,r7,r8,r9,r10,r11,r12} \ Restore
+
+ \ Set the saved PC to point to the rest of the state save
+ \ routine, then return from interrupt.
+
+ movs pc,r14 \ Return from exception
+end-code
+
+label save-common
+ str r14,'state pc \ Save PC from previous context
+
+ mrs r2,cpsr \ Get PSR from this context
+ str r2,'state exception-psr \ Save exception PSR
+
+ mrs r1,spsr \ Get PSR from previous context
+ str r1,'state psr \ Save it
+
+ orr r3,r1,#0x80 \ Disable interrupts
+ tst r3,#0xf \ Check for user mode
+ orreq r3,r3,#0xf \ Set system mode if previous mode was user
+ msr cpsr,r3 \ Get into the old mode
+
+ str r13,'state r13 \ Save r13 from the old mode
+ str r14,'state r14 \ Save r14 from the old mode
+
+ msr cpsr,r2 \ Get back into undef mode
+
+ \ When we enter Forth, we want interrupts to be enabled if they were
+ \ enabled before the exception occurred, unless the exception was caused
+ \ by an unexpected interrupt.
+ and r1,r1,#0x80 \ Get interrupt disable bit from previous mode
+ bic r2,r2,#0x80 \ Clear interrupt disable bit
+ and r3,r2,#0xf \ Get mode type bits
+ cmp r3,#2 \ Interrupt? (unexpected or user-abort)
+ cmpeq r4,#0 \ User-abort? (r4 != 0 if user abort)
+ orreq r2,r2,#0x80 \ Set interrupt disable bit if unexp. int.
+ orrne r2,r2,r1 \ Merge old int. dis. bit into new mode
+
+ bic r2,r2,#0x1f \ Clear mode bits
+ orr r2,r2,#0x13 \ Set SVC32 mode
+ msr spsr,r2 \ Put it in SPSR so the return below puts
+ \ us back into the right mode for Forth
+
+ \ Set the saved PC to point to the rest of the state save
+ \ routine, then return from interrupt.
+
+ adr r14,'body finish-save
+
+ movs pc,r14 \ Return from exception
+end-code
+
+string-array exception-name
+( 00 ) ," Reset"
+( 01 ) ," Undefined Instruction"
+( 02 ) ," Software Interrupt"
+( 03 ) ," Prefetch Abort"
+( 04 ) ," Data Abort"
+( 05 ) ," Address Exception"
+( 06 ) ," Interrupt"
+( 07 ) ," Fast Interrupt"
+end-string-array
+
+hex
+create mode>exception
+\ 0 1 2 3 4 5 6 7
+ ff c, 7 c, 6 c, 2 c, ff c, ff c, ff c, 4 c,
+
+\ 8 9 a b c d e f
+ ff c, ff c, ff c, 1 c, ff c, ff c, ff c, ff c,
+
+: exception# ( -- )
+ exception-psr h# f and mode>exception + c@
+;
+
+: (.exception) ( -- )
+ exception# dup 7 < if
+ exception-name count type
+ else
+ ." Bogus exception # " .h
+ then
+ cr
+;
+' (.exception) is .exception
+
+[ifdef] notdef
+\ Very simple handler, useful before the full breakpoint mechanism is installed
+: print-breakpoint
+ .exception \ norm
+ interactive? 0= if bye then \ Restart only if a human is at the controls
+ ??cr quit
+;
+' print-breakpoint is handle-breakpoint
+[then]
+
+defer install-handler ( handler exception# -- )
+defer catch-exception ( exception# -- )
+
+headers
+: catch-exceptions ( -- )
+ /save-area alloc-mem is cpu-state
+ ps-size alloc-mem is pssave
+ rs-size alloc-mem is rssave
+
+ 1 catch-exception \ Undefined instruction
+\ 2 catch-exception \ Software interrupt
+ 3 catch-exception \ Prefetch abort
+ 4 catch-exception \ Data abort
+ 5 catch-exception \ 26-bit address exceptions
+ 6 catch-exception \ Interrupt
+ 7 catch-exception \ Fast Interrupt
+;
+
+headers
+
+only forth also definitions
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1997 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/register.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/savefort.fth
===================================================================
--- cpu/arm/savefort.fth (rev 0)
+++ cpu/arm/savefort.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,128 @@
+purpose: Save the Forth dictionary image in a file in ARM image format
+\ See license at end of file
+
+\ save-forth ( filename -- )
+\ Saves the Forth dictionary to a file so it may be later used under Unix
+\
+\ save-image ( header-adr header-len init-routine-name filename -- )
+\ Primitive save routine. Saves the dictionary image to a file.
+\ The header is placed at the start of the file. The latest definition
+\ whose name is the same as the "init-routine-name" argument is
+\ installed as the init-io routine.
+
+hex
+
+variable dictionary-size
+
+only forth also hidden also
+hidden definitions
+
+headerless
+
+: dict-size ( -- size-of-dictionary ) here origin - aligned ;
+: rel-size ( -- reloc-size ) dict-size d# 31 + d# 32 / ;
+
+headers
+
+only forth also hidden also
+forth definitions
+
+h# 80 buffer: aif-header
+ \ 00 NOP (BL decompress code)
+ \ 04 NOP (BL self reloc code)
+ \ 08 NOP (BL ZeroInit code)
+ \ 0c BL entry (or offset to entry point for non-executable AIF header)
+ \ 10 NOP (program exit instruction)
+ \ 14 0 (Read-only section size)
+ \ 18 Dictionary size, actual value will be set later
+ \ 1c Reloc Size (ARM Debug size)
+ \ 20 0 (ARM zero-init size)
+ \ 24 0 (image debug type)
+ \ 28 Reloc save base (image base)
+ \ 2c Dictionary growth size (min workspace size)
+ \ 30 d#32 (address mode)
+ \ 34 0 (data base address)
+ \ 38 reserved
+ \ 3c reserved
+ \ 40 NOP (debug init instruction)
+ \ 44-7c unused (zero-init code)
+
+decimal
+
+: aif! ( n offset -- ) aif-header + ! ;
+: nop! ( offset -- ) h# e1a00000 swap aif! ;
+
+headerless
+: $save-image ( header header-len filename$ -- )
+ $new-file ( header header-len )
+
+ relocation-off
+ \ There is no need to copy the user area to the initial user area
+ \ image because the user area is currently accessed in-place.
+
+ ( header header-len ) ofd @ fputs \ Write header
+ origin dict-size ofd @ fputs \ Write dictionary
+ relocation-map rel-size ofd @ fputs \ Write the relocation table
+ ofd @ fclose
+ relocation-on
+;
+: make-arm-header ( -- )
+ \ Build the header
+ aif-header h# 80 erase
+ h# 00 nop!
+ h# 04 nop!
+ h# 08 nop!
+ h# eb00001b h# 0c aif! \ branch to just after the header
+ h# ef000011 h# 10 aif! \ SWI_Exit
+ h# 80 h# 14 aif! \ Read-only image size = header size
+ dict-size rel-size + h# 18 aif! \ Read-write size
+ 0 h# 1c aif!
+ 0 h# 20 aif!
+ 0 h# 24 aif!
+ h# 8000 h# 28 aif! \ Load base
+ dictionary-size @ h# 8.0000 max h# 2c aif! \ Dictionary growth size
+ h# 20 h# 30 aif! \ 32-bit address mode
+ 0 h# 34 aif!
+\ dict-size h# 38 aif! \ Dictionary size (Using a reserved field!)
+\ origin h# 3c aif! \ Save base (Using a reserved field!)
+ h# 40 nop!
+ dict-size h# 10 origin+ ! \ Dictionary size
+ origin h# 14 origin+ ! \ Save base
+;
+headers
+
+\ Save an image of the target system in a file.
+: $save-forth ( str -- )
+ 2>r
+ make-arm-header
+ " sys-init-io" $find-name is init-io
+ " sys-init" init-save
+
+ aif-header h# 80 2r> $save-image
+;
+
+only forth also definitions
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1997 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/savefort.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/savemeta.fth
===================================================================
--- cpu/arm/savemeta.fth (rev 0)
+++ cpu/arm/savemeta.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,97 @@
+purpose: Save the metacompiled kernel into a relocatable binary
+\ See license at end of file
+
+\ Binary relocation table stuff
+\ The relocation information in a binary file appears after the data segment.
+\ The relocation table is a bit map with one bit for every 32-bit word
+\ in the binary image. A one bit means that the longword is to be relocated.
+
+\ Binary file header
+
+only forth labels also forth also definitions
+
+hex
+create aif-header forth
+ 80 allot aif-header 80 erase
+ \ 00 NOP (BL decompress code)
+ \ 04 NOP (BL self reloc code)
+ \ 08 NOP (BL ZeroInit code)
+ \ 0c BL entry
+ \ 10 NOP (program exit instruction)
+ \ 14 0 (Read-only section size)
+ \ 18 Dictionary size, actual value will be set later
+ \ 1c Reloc Size (ARM Debug size)
+ \ 20 0 (ARM zero-init size)
+ \ 24 0 (image debug type)
+ \ 28 Reloc save base (image base)
+ \ 2c Dictionary growth size (min workspace size)
+ \ 30 d#32 (address mode)
+ \ 34 0 (data base address)
+ \ 38 reserved
+ \ 3c reserved
+ \ 40 NOP (debug init instruction)
+ \ 44-7c unused (zero-init code)
+
+only forth also meta also forth-h also definitions
+
+: text-base ( -- adr-t ) origin-t ;
+: text-size ( -- n ) here-t text-base - ;
+: reloc-size ( -- n ) text-size 1f + 5 >> ;
+
+: aif! ( n offset -- ) aif-header + l-t! ;
+: nop! ( offset -- ) th e1a00000 swap aif! ;
+
+\ Save an image of the target system in a file.
+: $save-meta ( name$ -- )
+ $new-file
+ \ Build and output the header
+ 00 nop!
+ 04 nop!
+ 08 nop!
+ eb00001b 0c aif! \ branch to just after the header
+ ef000011 10 aif! \ SWI_Exit
+ 80 14 aif! \ Read-only image size = header size
+ text-size reloc-size + 18 aif! \ Read-write size
+ 0 1c aif!
+ 0 20 aif!
+ 0 24 aif!
+ 8000 28 aif! \ Relocation save base
+ 8.0000 2c aif! \ Dictionary growth size
+ 20 30 aif! \ 32-bit address mode
+ 0 34 aif!
+\ text-size 38 aif! \ Dictionary size (Using a reserved field!)
+\ 0 3c aif! \ Save base (Using a reserved field!)
+ 40 nop!
+ text-size origin-t h# 10 + l!-t \ Dictionary size
+ 0 origin-t h# 14 + l!-t \ Save base
+
+ aif-header 80 ofd @ fputs
+ text-base >hostaddr text-size ofd @ fputs \ Text image
+ relocation-map reloc-size ofd @ fputs \ Relocation map
+
+ ofd @ fclose
+;
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2008 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/savemeta.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/scc.fth
===================================================================
--- cpu/arm/scc.fth (rev 0)
+++ cpu/arm/scc.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,114 @@
+purpose: System Control Coprocessor access words
+\ See license at end of file
+
+hex
+code scc-id@ ( -- n ) psh tos,sp mrc p15,0,tos,cr0,cr0,0 c;
+code control@ ( -- n ) psh tos,sp mrc p15,0,tos,cr1,cr0,0 c;
+code ttbase@ ( -- n ) psh tos,sp mrc p15,0,tos,cr2,cr0,0 c;
+code domain-access@ ( -- n ) psh tos,sp mrc p15,0,tos,cr3,cr0,0 c;
+code fault-status@ ( -- n ) psh tos,sp mrc p15,0,tos,cr5,cr0,0 c;
+code fault-address@ ( -- n ) psh tos,sp mrc p15,0,tos,cr6,cr0,0 c;
+
+code control! ( n -- ) mcr p15,0,tos,cr1,cr0,0 pop tos,sp c;
+code ttbase! ( n -- ) mcr p15,0,tos,cr2,cr0,0 pop tos,sp c;
+code domain-access! ( n -- ) mcr p15,0,tos,cr3,cr0,0 pop tos,sp c;
+code fault-status! ( n -- ) mcr p15,0,tos,cr5,cr0,0 pop tos,sp c;
+code fault-address! ( n -- ) mcr p15,0,tos,cr6,cr0,0 pop tos,sp c;
+code flush-i&d$ ( -- ) mcr p15,0,r0,cr7,cr7,0 c;
+code flush-i$ ( -- ) mcr p15,0,r0,cr7,cr5,0 c;
+code flush-d$ ( -- ) mcr p15,0,r0,cr7,cr6,0 c;
+code flush-d$-entry ( va -- ) mcr p15,0,tos,cr7,cr6,1 pop tos,sp c;
+code clean-d$-entry ( va -- ) mcr p15,0,tos,cr7,cr10,1 pop tos,sp c;
+code drain-write-buffer ( -- ) mcr p15,0,r0,cr7,cr10,4 c;
+code flush-i&d-tlb ( -- ) mcr p15,0,r0,cr8,cr7,0 c;
+code flush-i-tlb ( -- ) mcr p15,0,r0,cr8,cr5,0 c;
+code flush-d-tlb ( -- ) mcr p15,0,r0,cr8,cr6,0 c;
+code flush-d-tlb-entry ( va -- ) mcr p15,0,tos,cr8,cr6,1 pop tos,sp c;
+
+code enable-odd-lfsr ( -- ) mcr p15,0,r0,cr15,cr1,1 c;
+code enable-even-lfsr ( -- ) mcr p15,0,r0,cr15,cr2,1 c;
+code clear-lfsr ( -- ) mcr p15,0,r0,cr15,cr4,1 c;
+code lfsr-to-r14 ( -- ) mcr p15,0,r0,cr15,cr8,1 c;
+code fast-clock ( -- ) mcr p15,0,r0,cr15,cr1,2 c;
+code slow-clock ( -- ) mcr p15,0,r0,cr15,cr2,2 c;
+code disable-mclk ( -- ) mcr p15,0,r0,cr15,cr4,2 c;
+code wait-for-interrupt ( -- ) mcr p15,0,r0,cr15,cr8,2 c;
+
+: ttbase ( -- n ) ttbase@ h# 3ff invert and ;
+
+: .control ( -- ) control@ " i..rsb...wcam" show-bits ;
+
+d# 32 constant /cache-line
+: cache-bounds ( adr len -- end start )
+ bounds swap /cache-line round-up swap /cache-line round-down
+;
+: invalidate-cache-range ( adr len -- )
+ dup if flush-i$ then
+ cache-bounds ?do i flush-d$-entry /cache-line +loop
+;
+d# 32 constant /cache-line
+: flush-d$-range ( adr len -- )
+ bounds swap /cache-line round-up swap /cache-line round-down ?do
+ i clean-d$-entry i flush-d$-entry
+ /cache-line +loop
+;
+
+\ System-dependent function to flush the entire cache
+\ (In normal ARM nomenclature, as used by most of the words in this file,
+\ "flush" means "invalidate without ensuring that cached data has been
+\ written to memory", while "clean" means "ensure that cached data has been
+\ written to memory". In normal Open Firmware parlance, "invalidate" means
+\ the former and "flush" the latter. "flush-cache" is a generic Open Firmware
+\ operation, so it uses the Open Firmware nomenclature.
+defer flush-cache ' noop to flush-cache
+
+: icache-on ( -- ) flush-i$ control@ h# 1000 or control! ;
+: icache-off ( -- ) control@ h# 1000 invert and control! ;
+: dcache-on ( -- ) flush-d$ control@ 4 or control! ;
+: dcache-off ( -- )
+ control@ dup 4 and if
+ flush-cache
+ 4 invert and control!
+ else
+ drop
+ then
+;
+
+: write-buffer-on ( -- ) control@ 8 or control! ;
+: write-buffer-off ( -- )
+ drain-write-buffer control@ 8 invert and control!
+;
+
+: stand-sync-cache ( adr len -- )
+ cache-bounds ?do i clean-d$-entry /cache-line +loop
+ drain-write-buffer
+ flush-i$
+;
+: stand-init-io ( -- )
+ stand-init-io
+ ['] stand-sync-cache to sync-cache
+;
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1997 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/scc.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/sqroot.fth
===================================================================
--- cpu/arm/sqroot.fth (rev 0)
+++ cpu/arm/sqroot.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,52 @@
+purpose: Integer square-root for ARM processors
+\ See license at end of file
+
+\ u1 -- 32-bit unsigned
+\ n -- significant digits
+\ 16 -> sqrt-integer
+\ 32 -> fractional integer 16/16bits
+
+code (sqrt \ ( u1 n -- u2 )
+ r0 sp pop
+ r1 0 # mov
+ r2 0 # mov
+ begin r3 r1 mov
+ r0 r0 1 #lsl s mov
+ r2 r2 r2 adc
+ r0 r0 1 #lsl s mov
+ r2 r2 r2 adc
+ r1 r1 2 #lsl mov
+ r1 1 incr
+ r2 r2 r1 s sub \ get C-flag
+ r2 r2 r1 lt add
+ r1 r3 1 #lsl mov
+ r1 r1 1 # ge orr \ bit0 = not-C
+ top 1 s decr
+ eq until
+ top r1 mov c;
+
+: sqrt ( u1 -- u2 ) td 16 (sqrt ;
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2008 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/sqroot.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/sync.fth
===================================================================
--- cpu/arm/sync.fth (rev 0)
+++ cpu/arm/sync.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,45 @@
+purpose: Synchronize the caches the hard way (not used if sys-sync-cache works)
+\ See license at end of file
+
+code blow-icache
+ h# 1000 0 do h# ea000006 asm, loop \ b .+32
+c;
+code touch-lines ( adr len -- )
+ pop r0,sp
+ ahead begin
+ ldr r1,[r0]
+ add r0,r0,#32
+ but then
+ subs tos,tos,#32
+ 0<= until
+ pop tos,sp
+c;
+: slow-sync-cache ( adr len -- )
+ 2drop
+ origin h# 8000 touch-lines \ Touch 2x /cache to displace the data cache
+ blow-icache
+;
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1997 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/sync.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/sys.fth
===================================================================
--- cpu/arm/sys.fth (rev 0)
+++ cpu/arm/sys.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,102 @@
+purpose: Low-level I/O interface for use with a C "wrapper" program.
+\ See license at end of file
+
+\ The C program provides the Forth kernel with an array of entry-points
+\ into C subroutines for performing the actual system calls.
+\ This scheme should be reasonably compatible with nearly any Unix
+\ implementation. The only difference would be in the implementation of
+\ "syscall", which has to look up the address of the actual system call
+\ C routine in the system call table provided to it by the C program loader.
+\ It then has to convert the stack arguments into the same form as is
+\ expected by the C system call routines. This obviously depends on the
+\ details of the C calling sequence, but should not be too hard because
+\ C compilers usually pass arguments on the stack.
+\ Syscall is defined in the kernel, because it is needed for basics like
+\ key and emit.
+
+decimal
+
+/l ualloc-t dup equ syscall-user#
+user syscall-vec \ long address of system call vector
+nuser sysretval
+
+\ I/O for running under an OS with a C program providing actual I/O routines
+
+meta
+code syscall ( call# -- )
+ ldmia sp,{r0,r1,r2,r3,r4,r5} \ Get some arguments
+
+ psh ip,rp \ This register may be clobbered
+ ldr r6,'user syscall-vec \ Get address of system call table
+ add r6,r6,tos \ Call through vector
+ ldr r6,[r6]
+
+ mov lk,pc \ Return address
+ mov pc,r6
+\ ldr pc,[r6,tos] \ Call through vector
+
+ str r0,'user sysretval \ Save the result
+
+ pop ip,rp \ Restore IP
+ pop tos,sp \ Fix stack
+c;
+: retval ( -- return_value ) sysretval l@ ;
+: lretval ( -- l.return_value ) sysretval l@ ;
+
+nuser errno \ The last system error code
+: error? ( return-value -- return-value error? )
+ dup 0< dup if 60 syscall retval errno ! then ( return-value flag )
+;
+
+\ Rounds down to a block boundary. This causes all file accesses to the
+\ underlying operating system to occur on disk block boundaries. Some
+\ systems (e.g. CP/M) require this; others which don't require it
+\ usually run faster with alignment than without.
+
+\ Aligns to a 512-byte boundary
+hex
+: _falign ( l.byte# fd -- l.aligned ) drop 1ff invert and ;
+: _dfalign ( d.byte# fd -- d.aligned ) drop swap 1ff invert and swap ;
+
+: sys-init-io ( -- )
+ install-wrapper-alloc
+ init-relocation
+ install-wrapper-key
+
+ install-disk-io
+ \ Don't poll the keyboard under Unix; block waiting for a key
+ ['] (key ['] key (is
+\ sp@ hex . cr
+\ rp@ hex . cr
+\ origin hex . cr
+\ here hex . cr
+;
+' sys-init-io is init-io
+
+: sys-init ; \ Environment initialization chain
+' sys-init is init-environment
+decimal
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1994 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/sys.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/target.fth
===================================================================
--- cpu/arm/target.fth (rev 0)
+++ cpu/arm/target.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,286 @@
+purpose: Target-dependent definitions for metacompiling the kernel for ARM
+\ See license at end of file
+
+hex
+defer init-relocation-t
+defer set-relocation-bit-t
+
+18000 constant max-kernel \ Maximum size of the kernel
+
+only forth also meta also definitions
+
+
+variable protocol? protocol? off \ true -> information about compiled code
+variable last-protocol
+
+: .data ( n adr -- )
+ push-hex
+ last-protocol @ 0ffffff0 and over 0ffffff0 and <>
+ over d# 12 and 3 * d# 15 + dup >r #out @ < or
+ if cr 0ffffff0 and dup last-protocol ! 9 u.r
+ else drop
+ then
+ r> to-column 8 u.r
+ pop-base
+;
+: .protocol ( c t-adr -- ) protocol? @ if 2dup .data then ;
+
+: lobyte 0ff and ;
+: hibyte 8 >> lobyte ;
+
+ 2 constant /w-t
+ 4 constant /l-t
+ /l-t constant /n-t
+ /l-t constant /a-t
+ /a-t constant /thread-t
+ /l-t constant /token-t
+ /l-t constant /link-t
+/token-t constant /defer-t
+/n-t 800 * constant user-size-t
+/n-t 100 * constant ps-size-t
+/n-t 100 * constant rs-size-t
+/l-t constant /user#-t
+
+\ 32 bit host Forth compiling 32-bit target Forth
+: l->n-t ; immediate
+: n->l-t ; immediate
+: n->n-t ; immediate
+: s->l-t ; immediate
+
+: c!-t ( n adr -- ) >hostaddr c! ;
+: c@-t ( adr -- n ) >hostaddr c@ ;
+\ : w!-t ( n adr -- ) .protocol >hostaddr le-w! ;
+\ : w@-t ( t-adr -- n ) >hostaddr le-w@ ;
+
+: l!-t ( l adr -- ) .protocol >hostaddr le-l! ;
+: l@-t ( t-adr -- l ) >hostaddr le-l@ ;
+
+: !-t ( n adr -- ) l!-t ;
+: @-t ( t-adr -- n ) l@-t ;
+
+\ Store target data types into the host address space.
+: c-t! ( c h-adr -- ) c! ;
+\ : w-t! ( w h-adr -- ) le-w! ;
+: l-t! ( l h-adr -- ) le-l! ;
+: n-t! ( n h-adr -- ) l-t! ;
+
+: c-t@ ( host-address -- c ) c@ ;
+: l-t@ ( host-address -- l ) le-l@ ;
+
+\ Next 3 are machine-independent
+\ Next 3 are machine-independent
+: c,-t ( byte -- ) here-t 1 allot-t c!-t ;
+: w,-t true abort" Called w,-t" ;
+\ : w,-t ( word -- ) here-t /w-t allot-t w!-t ;
+: l,-t ( long -- ) here-t /l-t allot-t l!-t ;
+
+: ,-t ( adr -- ) l,-t ;
+: ,user#-t ( user# -- ) l,-t ;
+
+: a@-t ( t-adr -- t-adr ) l@-t ;
+: a!-t ( token t-adr -- ) set-relocation-bit-t l!-t ;
+: token@-t ( t-adr -- t-adr ) a@-t ;
+: token!-t ( token t-adr -- ) a!-t ;
+
+: rlink@-t ( occurrence -- next-occurrence ) a@-t ;
+: rlink!-t ( next-occurrence occurrence -- ) token!-t ;
+
+
+\ Machine independent
+: a,-t ( adr -- ) here-t /a-t allot-t a!-t ;
+: token,-t ( token -- ) here-t /token-t allot-t token!-t ;
+
+\ These versions of linkx-t are for absolute links
+: link@-t ( t-adr -- t-adr' ) a@-t ;
+: link!-t ( t-adr t-adr -- ) a!-t ;
+: link,-t ( t-adr -- ) a,-t ;
+: a-t@ ( host-address -- target-address )
+[ also forth ]
+ dup origin here within over up@ dup user-size + within or if
+[ previous ]
+ l@
+ else
+ hostaddr> a@-t
+ then
+;
+: a-t! ( target-address host-address -- )
+[ also forth ]
+ dup origin here within over up@ dup user-size + within or if
+[ previous ]
+ l!
+ else
+ hostaddr> a!-t
+ then
+;
+: rlink-t@ ( host-adr -- target-adr ) a-t@ ;
+: rlink-t! ( target-adr host-adr -- ) a-t! ;
+
+: token-t@ ( host-adr -- t-adr ) a-t@ ;
+: token-t! ( t-adr host-adr -- ) a-t! ;
+: link-t@ ( host-adr -- t-adr ) a-t@ ;
+: link-t! ( t-adr host-adr -- ) a-t! ;
+
+\ Machine independent
+: a-t, ( t-adr -- ) here /a-t allot a-t! ;
+: token-t, ( t-adr -- ) here /token-t allot token-t! ;
+: >body-t ( cfa-t -- pfa-t )
+ dup l@-t ff000000 and eb000000 =
+ if /l-t + then ;
+
+1 constant #threads-t \ Must be a power of 2
+create threads-t #threads-t 1+ /link-t * allot
+
+: $hash-t ( adr len voc-ptr -- thread )
+ -rot nip #threads-t 1- and /thread-t * +
+;
+
+\ Should allocate these dynamically.
+\ The dictionary space should be dynamically allocated too.
+
+\ The user area image lives in the host address space.
+\ We wish to store into the user area with -t commands so as not
+\ to need separate words to store target items into host addresses.
+\ That is why user+ returns a target address.
+
+\ Machine Independent
+
+0 constant userarea-t
+: setup-user-area ( -- )
+ here-t is userarea-t
+ user-size-t allot-t
+ userarea-t >hostaddr user-size-t erase ;
+
+: >user-t ( cfa-t -- user-adr-t ) >body-t @-t userarea-t + >hostaddr ;
+: n>link-t ( anf-t -- alf-t ) /link-t - ;
+: l>name-t ( alf-t -- anf-t ) /link-t + ;
+
+decimal
+/l constant #align-t
+/l constant #talign-t
+/l constant #linkalign-t
+/l constant #acf-align-t
+: aligned-t ( n1 -- n2 ) #align-t 1- + #align-t negate and ;
+: acf-aligned-t ( n1 -- n2 ) #acf-align-t 1- + #acf-align-t negate and ;
+
+\ NullFix bl -> 0
+: align-t ( -- )
+ begin here-t #align-t 1- and while 0 c,-t repeat
+;
+: talign-t ( -- )
+ begin here-t #talign-t 1- and while 0 c,-t repeat
+;
+: linkalign-t ( -- )
+ begin here-t #linkalign-t 1- and while 0 c,-t repeat
+;
+: acf-align-t ( -- ) talign-t ;
+
+: entercode ( -- )
+ only forth also labels also meta also arm-assembler
+ [ also arm-assembler also helpers ]
+ ['] $arm-assem-do-undefined is $do-undefined
+ [ previous previous ]
+ align-t
+;
+
+\ Next 5 are Machine Independent
+: cmove-t ( from to-t n -- )
+ 2dup 2>r
+ 0 do over c@ over c!-t ca1+ swap ca1+ swap loop 2drop
+ 2r> protocol? @
+ if base @ >r hex last-protocol off
+ cr ." String at" over 6 u.r space ascii " emit bounds
+ do i c@-t dup bl <
+ if drop else emit then
+ loop ascii " emit r> base !
+ else 2drop
+ then ;
+: place-cstr-t ( adr len cstr-adr-t -- cstr-adr-t )
+ >r tuck r@ swap cmove-t ( len ) r@ + 0 swap c!-t r>
+;
+: "copy-t ( from to-t -- )
+ over c@ 2+ cmove-t ;
+: toggle-t ( addr-t n -- )
+ protocol? @
+ if cr ." Toggle at" base @ >r hex 2dup swap 6 u.r 3 u.r
+ last-protocol off r> base !
+ then
+ swap >r r@ c@-t xor r> c!-t ;
+
+: clear-threads-t ( hostaddr -- )
+ #threads-t /link-t * bounds do
+ origin-t i link-t!
+ /link +loop
+;
+: initmeta ( -- )
+ init-relocation-t
+ threads-t #threads-t /link-t * bounds
+ do origin-t i link-t!
+ threads-t current-t !
+ /link +loop
+ last-protocol on ;
+
+\ For compiling branch offsets/addresses used by control constructs.
+/l-t constant /branch
+
+\rel : branch! ( from to -- ) over - swap l!-t ;
+\rel : branch, ( to -- ) here-t - l,-t ;
+
+\abs : branch! ( from to -- ) swap a!-t ;
+\abs : branch, ( to -- ) a,-t ;
+
+\ Store actions for some data structures. This has to be in this
+\ file because it depends on the location of the user area (in the
+\ ARMx version, the user area is in the dictionary for
+\ relocation to work right, but that is not true for the SPARC
+\ version. Ultimately, separate relocation for the user area is
+\ needed. The relocation probably should be automatic, by looking
+\ at the storage address.
+
+: isuser ( n acf -- ) >user-t n-t! ;
+: istuser ( acf1 acf -- ) >user-t token-t! ;
+: isvalue ( n acf -- ) >user-t n-t! ;
+: isdefer ( acf acf -- ) >user-t token-t! ;
+
+: thread-t! ( thread adr -- ) link!-t ;
+
+
+only forth also meta also definitions
+: install-target-assembler
+ [ assembler also helpers ]
+ ['] allot-t is asm-allot
+ ['] here-t is here
+\ ['] c!-t is byte!
+ ['] l!-t is asm!
+ ['] l@-t is asm@
+ ['] set-relocation-bit-t is asm-set-relocation-bit
+ [ previous previous ]
+;
+: install-host-assembler ( -- )
+\ XXX Just punt for now.
+;
+
+decimal
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2008 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/target.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/testasm.txt
===================================================================
--- cpu/arm/testasm.txt (rev 0)
+++ cpu/arm/testasm.txt 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,1191 @@
+purpose: Test for ARM assembler
+\ See license at end of file
+
+arm-asm helpers
+\ debug amode-lsm
+testloop
+000000 e1a0c00d MOV r12,r13
+000004 e92d000f STMDB r13!,{r0-r3}
+000008 e92ddff0 STMDB r13!,{r4-r12,r14,pc}
+00000c e24cb014 SUB r11,r12,#0x14
+000010 e1a04002 MOV r4,r2
+000014 e2821080 ADD r1,r2,#0x80
+000018 e59b6008 LDR r6,[r11,#8]
+00001c e582107c STR r1,[r2,#0x7c]
+000020 e1a01002 MOV r1,r2
+000028 e3a00000 MOV r0,#0
+00002c e5941008 LDR r1,[r4,#8]
+000030 e2811001 ADD r1,r1,#1
+000034 e2800001 ADD r0,r0,#1
+000038 e3500003 CMP r0,#3
+00003c e5841008 STR r1,[r4,#8]
+000040 bafffff9 BLT 0x2c
+000044 e5940008 LDR r0,[r4,#8]
+000048 e4d01001 LDRB r1,[r0],#1
+00004c e5840008 STR r0,[r4,#8]
+000050 e3a00000 MOV r0,#0
+000054 e5942008 LDR r2,[r4,#8]
+000058 e2822001 ADD r2,r2,#1
+00005c e2800001 ADD r0,r0,#1
+000060 e3500006 CMP r0,#6
+000064 e5842008 STR r2,[r4,#8]
+000068 bafffff9 BLT 0x54
+00006c e3110008 TST r1,#8
+000070 0a000004 BEQ 0x88
+000074 e5941008 LDR r1,[r4,#8]
+000078 e4d10001 LDRB r0,[r1],#1
+00007c e3300000 TEQ r0,#0
+000080 e5841008 STR r1,[r4,#8]
+000084 1afffffa BNE 0x74
+000088 e5941000 LDR r1,[r4,#0]
+00008c e1a02004 MOV r2,r4
+000090 e3a00001 MOV r0,#1
+000098 e2008001 AND r8,r0,#1
+00009c e1a010a0 MOV r1,r0,LSR #1
+0000a0 e5940004 LDR r0,[r4,#4]
+0000a4 e2400001 SUB r0,r0,#1
+0000a8 e5840004 STR r0,[r4,#4]
+0000ac e1a02004 MOV r2,r4
+0000b0 e3a00002 MOV r0,#2
+0000b8 e2101003 ANDS r1,r0,#3
+0000bc e1a02120 MOV r2,r0,LSR #2
+0000c0 e5940004 LDR r0,[r4,#4]
+0000c4 e2400002 SUB r0,r0,#2
+0000c8 e5840004 STR r0,[r4,#4]
+0000cc e5842000 STR r2,[r4,#0]
+0000d0 1a00002a BNE 0x180
+0000d4 e1a01002 MOV r1,r2
+0000d8 e2002007 AND r2,r0,#7
+0000dc e1a01231 MOV r1,r1,LSR r2
+0000e0 e0400002 SUB r0,r0,r2
+0000e4 e5840004 STR r0,[r4,#4]
+0000e8 e1a02004 MOV r2,r4
+0000ec e3a00010 MOV r0,#0x10
+0000f4 e1a05800 MOV r5,r0,LSL #16
+0000f8 e1a05825 MOV r5,r5,LSR #16
+0000fc e1a01820 MOV r1,r0,LSR #16
+000100 e5940004 LDR r0,[r4,#4]
+000104 e2400010 SUB r0,r0,#0x10
+000108 e5840004 STR r0,[r4,#4]
+00010c e1a02004 MOV r2,r4
+000110 e3a00010 MOV r0,#0x10
+000118 e1e01000 MVN r1,r0
+00011c e1a01801 MOV r1,r1,LSL #16
+000120 e1a01821 MOV r1,r1,LSR #16
+000124 e1310005 TEQ r1,r5
+000128 13a08001 MOVNE r8,#1
+00012c 1a0000a5 BNE 0x3c8
+000130 e1a01820 MOV r1,r0,LSR #16
+000134 e5940004 LDR r0,[r4,#4]
+000138 e2400010 SUB r0,r0,#0x10
+00013c e2457001 SUB r7,r5,#1
+000140 e3350000 TEQ r5,#0
+000144 e5840004 STR r0,[r4,#4]
+000148 0a00000a BEQ 0x178
+00014c e1a02004 MOV r2,r4
+000150 e3a00008 MOV r0,#8
+000158 e4c60001 STRB r0,[r6],#1
+00015c e1a01420 MOV r1,r0,LSR #8
+000160 e5940004 LDR r0,[r4,#4]
+000164 e2400008 SUB r0,r0,#8
+000168 e5840004 STR r0,[r4,#4]
+00016c e1b00007 MOVS r0,r7
+000170 e2477001 SUB r7,r7,#1
+000174 1afffff4 BNE 0x14c
+000178 e5841000 STR r1,[r4,#0]
+00017c ea000091 B 0x3c8
+000180 e24ddc05 SUB r13,r13,#0x500
+000184 e3310001 TEQ r1,#1
+000188 e1a03004 MOV r3,r4
+00018c e1a0200d MOV r2,r13
+000190 e28d1e4f ADD r1,r13,#0x4f0
+000194 e92d000e STMDB r13!,{r1-r3}
+000198 e28d3c05 ADD r3,r13,#0x500
+00019c e28d2f41 ADD r2,r13,#0x104
+0001a0 e2822b01 ADD r2,r2,#0x400
+0001a4 e28d1f42 ADD r1,r13,#0x108
+0001a8 e2811b01 ADD r1,r1,#0x400
+0001ac 1a000001 BNE 0x1b8
+0001b4 ea000000 B 0x1bc
+0001bc e28dd00c ADD r13,r13,#0xc
+0001c0 e3300000 TEQ r0,#0
+0001c4 13a08001 MOVNE r8,#1
+0001c8 1a00007d BNE 0x3c4
+0001cc e24dd004 SUB r13,r13,#4
+0001d0 e5941000 LDR r1,[r4,#0]
+0001d4 e3a09001 MOV r9,#1
+0001d8 e59d04f8 LDR r0,[r13,#0x4f8]
+0001dc e1a00019 MOV r0,r9,LSL r0
+0001e0 e240a001 SUB r10,r0,#1
+0001e4 e59d04f4 LDR r0,[r13,#0x4f4]
+0001e8 e1a00019 MOV r0,r9,LSL r0
+0001ec e2400001 SUB r0,r0,#1
+0001f0 e58d0000 STR r0,[r13,#0]
+0001f4 e1a02004 MOV r2,r4
+0001f8 e59d04f8 LDR r0,[r13,#0x4f8]
+000200 e000200a AND r2,r0,r10
+000204 e59d1500 LDR r1,[r13,#0x500]
+000208 e0817182 ADD r7,r1,r2,LSL #3
+00020c e5d75000 LDRB r5,[r7,#0]
+000210 e3550010 CMP r5,#0x10
+000214 9a000013 BLS 0x268
+000218 e3a09001 MOV r9,#1
+00021c e3350063 TEQ r5,#0x63
+000220 0a000066 BEQ 0x3c0
+000224 e5d72001 LDRB r2,[r7,#1]
+000228 e1a01230 MOV r1,r0,LSR r2
+00022c e5940004 LDR r0,[r4,#4]
+000230 e0400002 SUB r0,r0,r2
+000234 e2455010 SUB r5,r5,#0x10
+000238 e5840004 STR r0,[r4,#4]
+00023c e1a02004 MOV r2,r4
+000240 e1a00005 MOV r0,r5
+000248 e1a02519 MOV r2,r9,LSL r5
+00024c e2422001 SUB r2,r2,#1
+000250 e0022000 AND r2,r2,r0
+000254 e5b71004 LDR r1,[r7,#4]!
+000258 e0817182 ADD r7,r1,r2,LSL #3
+00025c e5d75000 LDRB r5,[r7,#0]
+000260 e3550010 CMP r5,#0x10
+000264 8affffec BHI 0x21c
+000268 e5d72001 LDRB r2,[r7,#1]
+00026c e1a01230 MOV r1,r0,LSR r2
+000270 e5940004 LDR r0,[r4,#4]
+000274 e0400002 SUB r0,r0,r2
+000278 e3350010 TEQ r5,#0x10
+00027c e5840004 STR r0,[r4,#4]
+000280 05970004 LDREQ r0,[r7,#4]
+000284 04c60001 STREQB r0,[r6],#1
+000288 0affffd9 BEQ 0x1f4
+00028c e335000f TEQ r5,#0xf
+000290 0a000047 BEQ 0x3b4
+000294 e1a02004 MOV r2,r4
+000298 e1a00005 MOV r0,r5
+0002a0 e5972004 LDR r2,[r7,#4]
+0002a4 e1a02802 MOV r2,r2,LSL #16
+0002a8 e3a01001 MOV r1,#1
+0002ac e1a01511 MOV r1,r1,LSL r5
+0002b0 e2411001 SUB r1,r1,#1
+0002b4 e0011000 AND r1,r1,r0
+0002b8 e0819822 ADD r9,r1,r2,LSR #16
+0002bc e1a01530 MOV r1,r0,LSR r5
+0002c0 e5940004 LDR r0,[r4,#4]
+0002c4 e0400005 SUB r0,r0,r5
+0002c8 e5840004 STR r0,[r4,#4]
+0002cc e1a02004 MOV r2,r4
+0002d0 e59d04f4 LDR r0,[r13,#0x4f4]
+0002d8 e59d1000 LDR r1,[r13,#0]
+0002dc e0001001 AND r1,r0,r1
+0002e0 e59d24fc LDR r2,[r13,#0x4fc]
+0002e4 e0827181 ADD r7,r2,r1,LSL #3
+0002e8 e5d75000 LDRB r5,[r7,#0]
+0002ec e3550010 CMP r5,#0x10
+0002f0 9a000013 BLS 0x344
+0002f4 e3350063 TEQ r5,#0x63
+0002f8 0a000030 BEQ 0x3c0
+0002fc e5d72001 LDRB r2,[r7,#1]
+000300 e1a01230 MOV r1,r0,LSR r2
+000304 e5940004 LDR r0,[r4,#4]
+000308 e0400002 SUB r0,r0,r2
+00030c e2455010 SUB r5,r5,#0x10
+000310 e5840004 STR r0,[r4,#4]
+000314 e1a02004 MOV r2,r4
+000318 e1a00005 MOV r0,r5
+000320 e3a02001 MOV r2,#1
+000324 e1a02512 MOV r2,r2,LSL r5
+000328 e2422001 SUB r2,r2,#1
+00032c e0022000 AND r2,r2,r0
+000330 e5b71004 LDR r1,[r7,#4]!
+000334 e0817182 ADD r7,r1,r2,LSL #3
+000338 e5d75000 LDRB r5,[r7,#0]
+00033c e3550010 CMP r5,#0x10
+000340 8affffeb BHI 0x2f4
+000344 e5d72001 LDRB r2,[r7,#1]
+000348 e1a01230 MOV r1,r0,LSR r2
+00034c e5940004 LDR r0,[r4,#4]
+000350 e0400002 SUB r0,r0,r2
+000354 e5840004 STR r0,[r4,#4]
+000358 e1a02004 MOV r2,r4
+00035c e1a00005 MOV r0,r5
+000364 e5971004 LDR r1,[r7,#4]
+000368 e1a01801 MOV r1,r1,LSL #16
+00036c e3a02001 MOV r2,#1
+000370 e1a02512 MOV r2,r2,LSL r5
+000374 e2422001 SUB r2,r2,#1
+000378 e0022000 AND r2,r2,r0
+00037c e0822821 ADD r2,r2,r1,LSR #16
+000380 e1a01530 MOV r1,r0,LSR r5
+000384 e5940004 LDR r0,[r4,#4]
+000388 e0400005 SUB r0,r0,r5
+00038c e5840004 STR r0,[r4,#4]
+000390 e2490001 SUB r0,r9,#1
+000394 e3390000 TEQ r9,#0
+000398 0affff95 BEQ 0x1f4
+00039c e7563002 LDRB r3,[r6,-r2]
+0003a0 e4c63001 STRB r3,[r6],#1
+0003a4 e1b03000 MOVS r3,r0
+0003a8 e2400001 SUB r0,r0,#1
+0003ac 1afffffa BNE 0x39c
+0003b0 eaffff8f B 0x1f4
+0003b4 e5940020 LDR r0,[r4,#0x20]
+0003b8 e584007c STR r0,[r4,#0x7c]
+0003bc e5841000 STR r1,[r4,#0]
+0003c0 e28dd004 ADD r13,r13,#4
+0003c4 e28ddc05 ADD r13,r13,#0x500
+0003c8 e3380000 TEQ r8,#0
+0003cc 0affff2d BEQ 0x88
+0003d0 e59b1008 LDR r1,[r11,#8]
+0003d4 e0460001 SUB r0,r6,r1
+0003d8 e91baff0 LDMDB r11,{r4-r11,r13,pc}
+0003dc e92d47f0 STMDB r13!,{r4-r10,r14}
+0003e0 e3a02000 MOV r2,#0
+0003e4 e5812000 STR r2,[r1,#0]
+0003e8 e5810008 STR r0,[r1,#8]
+0003ec e5812004 STR r2,[r1,#4]
+0003f0 e591007c LDR r0,[r1,#0x7c]
+0003f4 e581000c STR r0,[r1,#0xc]
+0003f8 e591007c LDR r0,[r1,#0x7c]
+0003fc e280004c ADD r0,r0,#0x4c
+000400 e581007c STR r0,[r1,#0x7c]
+000404 e3a09010 MOV r9,#0x10
+000408 e591000c LDR r0,[r1,#0xc]
+00040c e3a05011 MOV r5,#0x11
+000410 e3a03012 MOV r3,#0x12
+000414 e4809004 STR r9,[r0],#4
+000418 e4805004 STR r5,[r0],#4
+00041c e4803004 STR r3,[r0],#4
+000420 e5802000 STR r2,[r0,#0]
+000424 e2806004 ADD r6,r0,#4
+000428 e3a04008 MOV r4,#8
+00042c e3a0e007 MOV r14,#7
+000430 e3a0c009 MOV r12,#9
+000434 e3a03006 MOV r3,#6
+000438 e3a0800a MOV r8,#0xa
+00043c e3a00005 MOV r0,#5
+000440 e3a0700b MOV r7,#0xb
+000444 e3a0a004 MOV r10,#4
+000448 e8a64010 STMIA r6!,{r4,r14}
+00044c e486c004 STR r12,[r6],#4
+000450 e8a60108 STMIA r6!,{r3,r8}
+000454 e8a60481 STMIA r6!,{r0,r7,r10}
+000458 e3a0a00c MOV r10,#0xc
+00045c e486a004 STR r10,[r6],#4
+000460 e3a0a003 MOV r10,#3
+000464 e486a004 STR r10,[r6],#4
+000468 e3a0a00d MOV r10,#0xd
+00046c e486a004 STR r10,[r6],#4
+000470 e3a0a002 MOV r10,#2
+000474 e486a004 STR r10,[r6],#4
+000478 e3a0a00e MOV r10,#0xe
+00047c e486a004 STR r10,[r6],#4
+000480 e3a0a001 MOV r10,#1
+000484 e486a004 STR r10,[r6],#4
+000488 e3a0a00f MOV r10,#0xf
+00048c e586a000 STR r10,[r6,#0]
+000490 e591607c LDR r6,[r1,#0x7c]
+000494 e5816010 STR r6,[r1,#0x10]
+000498 e591607c LDR r6,[r1,#0x7c]
+00049c e2866040 ADD r6,r6,#0x40
+0004a0 e581607c STR r6,[r1,#0x7c]
+0004a4 e3a0a003 MOV r10,#3
+0004a8 e5916010 LDR r6,[r1,#0x10]
+0004ac e5c6a000 STRB r10,[r6,#0]
+0004b0 e5c62001 STRB r2,[r6,#1]
+0004b4 e3a0a004 MOV r10,#4
+0004b8 e5e6a002 STRB r10,[r6,#2]!
+0004bc e5c62001 STRB r2,[r6,#1]
+0004c0 e5e60002 STRB r0,[r6,#2]!
+0004c4 e5c62001 STRB r2,[r6,#1]
+0004c8 e5e63002 STRB r3,[r6,#2]!
+0004cc e5c62001 STRB r2,[r6,#1]
+0004d0 e5e6e002 STRB r14,[r6,#2]!
+0004d4 e5c62001 STRB r2,[r6,#1]
+0004d8 e5e64002 STRB r4,[r6,#2]!
+0004dc e5c62001 STRB r2,[r6,#1]
+0004e0 e5e6c002 STRB r12,[r6,#2]!
+0004e4 e5c62001 STRB r2,[r6,#1]
+0004e8 e5e68002 STRB r8,[r6,#2]!
+0004ec e5c62001 STRB r2,[r6,#1]
+0004f0 e5e67002 STRB r7,[r6,#2]!
+0004f4 e5c62001 STRB r2,[r6,#1]
+0004f8 e3a0a00d MOV r10,#0xd
+0004fc e5e6a002 STRB r10,[r6,#2]!
+000500 e5c62001 STRB r2,[r6,#1]
+000504 e3a0a00f MOV r10,#0xf
+000508 e5e6a002 STRB r10,[r6,#2]!
+00050c e5c62001 STRB r2,[r6,#1]
+000510 e5e65002 STRB r5,[r6,#2]!
+000514 e5c62001 STRB r2,[r6,#1]
+000518 e3a07013 MOV r7,#0x13
+00051c e5e67002 STRB r7,[r6,#2]!
+000520 e5c62001 STRB r2,[r6,#1]
+000524 e3a07017 MOV r7,#0x17
+000528 e5e67002 STRB r7,[r6,#2]!
+00052c e5c62001 STRB r2,[r6,#1]
+000530 e3a0701b MOV r7,#0x1b
+000534 e5e67002 STRB r7,[r6,#2]!
+000538 e5c62001 STRB r2,[r6,#1]
+00053c e3a0701f MOV r7,#0x1f
+000540 e5e67002 STRB r7,[r6,#2]!
+000544 e5c62001 STRB r2,[r6,#1]
+000548 e3a07023 MOV r7,#0x23
+00054c e5e67002 STRB r7,[r6,#2]!
+000550 e5c62001 STRB r2,[r6,#1]
+000554 e3a0702b MOV r7,#0x2b
+000558 e5e67002 STRB r7,[r6,#2]!
+00055c e5c62001 STRB r2,[r6,#1]
+000560 e3a07033 MOV r7,#0x33
+000564 e5e67002 STRB r7,[r6,#2]!
+000568 e5c62001 STRB r2,[r6,#1]
+00056c e3a0703b MOV r7,#0x3b
+000570 e5e67002 STRB r7,[r6,#2]!
+000574 e5c62001 STRB r2,[r6,#1]
+000578 e3a08043 MOV r8,#0x43
+00057c e5e68002 STRB r8,[r6,#2]!
+000580 e5c62001 STRB r2,[r6,#1]
+000584 e2867002 ADD r7,r6,#2
+000588 e3a06053 MOV r6,#0x53
+00058c e5c76000 STRB r6,[r7,#0]
+000590 e5c72001 STRB r2,[r7,#1]
+000594 e3a06063 MOV r6,#0x63
+000598 e5e76002 STRB r6,[r7,#2]!
+00059c e5c72001 STRB r2,[r7,#1]
+0005a0 e3a08073 MOV r8,#0x73
+0005a4 e5e78002 STRB r8,[r7,#2]!
+0005a8 e5c72001 STRB r2,[r7,#1]
+0005ac e3a08083 MOV r8,#0x83
+0005b0 e5e78002 STRB r8,[r7,#2]!
+0005b4 e5c72001 STRB r2,[r7,#1]
+0005b8 e3a080a3 MOV r8,#0xa3
+0005bc e5e78002 STRB r8,[r7,#2]!
+0005c0 e5c72001 STRB r2,[r7,#1]
+0005c4 e3a080c3 MOV r8,#0xc3
+0005c8 e5e78002 STRB r8,[r7,#2]!
+0005cc e5c72001 STRB r2,[r7,#1]
+0005d0 e3a080e3 MOV r8,#0xe3
+0005d4 e5e78002 STRB r8,[r7,#2]!
+0005d8 e5c72001 STRB r2,[r7,#1]
+0005dc e2877002 ADD r7,r7,#2
+0005e0 e3a08002 MOV r8,#2
+0005e4 e5c78000 STRB r8,[r7,#0]
+0005e8 e3a0a001 MOV r10,#1
+0005ec e5c7a001 STRB r10,[r7,#1]
+0005f0 e7e72008 STRB r2,[r7,r8]!
+0005f4 e5c72001 STRB r2,[r7,#1]
+0005f8 e7e72008 STRB r2,[r7,r8]!
+0005fc e5c72001 STRB r2,[r7,#1]
+000600 e591707c LDR r7,[r1,#0x7c]
+000604 e5817014 STR r7,[r1,#0x14]
+000608 e591707c LDR r7,[r1,#0x7c]
+00060c e2877040 ADD r7,r7,#0x40
+000610 e581707c STR r7,[r1,#0x7c]
+000614 e3a07000 MOV r7,#0
+000618 e591a014 LDR r10,[r1,#0x14]
+00061c e3a02000 MOV r2,#0
+000620 e5ca2000 STRB r2,[r10,#0]
+000624 e5ca2001 STRB r2,[r10,#1]
+000628 e28aa002 ADD r10,r10,#2
+00062c e2877001 ADD r7,r7,#1
+000630 e3570004 CMP r7,#4
+000634 bafffff8 BLT 0x61c
+000638 e357001c CMP r7,#0x1c
+00063c aa000012 BGE 0x68c
+000640 e2572001 SUBS r2,r7,#1
+000644 42822003 ADDMI r2,r2,#3
+000648 e1a02142 MOV r2,r2,ASR #2
+00064c e1a08802 MOV r8,r2,LSL #16
+000650 e1a08828 MOV r8,r8,LSR #16
+000654 e1a0200a MOV r2,r10
+000658 e5ca8000 STRB r8,[r10,#0]
+00065c e1a0a448 MOV r10,r8,ASR #8
+000660 e5c2a001 STRB r10,[r2,#1]
+000664 e5e28002 STRB r8,[r2,#2]!
+000668 e5c2a001 STRB r10,[r2,#1]
+00066c e5e28002 STRB r8,[r2,#2]!
+000670 e5c2a001 STRB r10,[r2,#1]
+000674 e5e28002 STRB r8,[r2,#2]!
+000678 e5c2a001 STRB r10,[r2,#1]
+00067c e282a002 ADD r10,r2,#2
+000680 e2877004 ADD r7,r7,#4
+000684 e357001c CMP r7,#0x1c
+000688 baffffec BLT 0x640
+00068c e3a02000 MOV r2,#0
+000690 e5ca2000 STRB r2,[r10,#0]
+000694 e5ca2001 STRB r2,[r10,#1]
+000698 e5ea6002 STRB r6,[r10,#2]!
+00069c e5ca2001 STRB r2,[r10,#1]
+0006a0 e5ea6002 STRB r6,[r10,#2]!
+0006a4 e5ca2001 STRB r2,[r10,#1]
+0006a8 e591607c LDR r6,[r1,#0x7c]
+0006ac e5816018 STR r6,[r1,#0x18]
+0006b0 e2867040 ADD r7,r6,#0x40
+0006b4 e581707c STR r7,[r1,#0x7c]
+0006b8 e3a07001 MOV r7,#1
+0006bc e5c67000 STRB r7,[r6,#0]
+0006c0 e5c62001 STRB r2,[r6,#1]
+0006c4 e3a0a002 MOV r10,#2
+0006c8 e5e6a002 STRB r10,[r6,#2]!
+0006cc e5c62001 STRB r2,[r6,#1]
+0006d0 e3a08003 MOV r8,#3
+0006d4 e7e6800a STRB r8,[r6,r10]!
+0006d8 e5c62001 STRB r2,[r6,#1]
+0006dc e3a08004 MOV r8,#4
+0006e0 e7e6800a STRB r8,[r6,r10]!
+0006e4 e5c62001 STRB r2,[r6,#1]
+0006e8 e5e60002 STRB r0,[r6,#2]!
+0006ec e5c62001 STRB r2,[r6,#1]
+0006f0 e5e6e002 STRB r14,[r6,#2]!
+0006f4 e5c62001 STRB r2,[r6,#1]
+0006f8 e5e6c002 STRB r12,[r6,#2]!
+0006fc e5c62001 STRB r2,[r6,#1]
+000700 e3a0000d MOV r0,#0xd
+000704 e5e60002 STRB r0,[r6,#2]!
+000708 e5c62001 STRB r2,[r6,#1]
+00070c e5e65002 STRB r5,[r6,#2]!
+000710 e5c62001 STRB r2,[r6,#1]
+000714 e2860002 ADD r0,r6,#2
+000718 e3a0c019 MOV r12,#0x19
+00071c e5c0c000 STRB r12,[r0,#0]
+000720 e5c02001 STRB r2,[r0,#1]
+000724 e3a0c021 MOV r12,#0x21
+000728 e5e0c002 STRB r12,[r0,#2]!
+00072c e5c02001 STRB r2,[r0,#1]
+000730 e3a0c031 MOV r12,#0x31
+000734 e5e0c002 STRB r12,[r0,#2]!
+000738 e5c02001 STRB r2,[r0,#1]
+00073c e3a0c041 MOV r12,#0x41
+000740 e5e0c002 STRB r12,[r0,#2]!
+000744 e5c02001 STRB r2,[r0,#1]
+000748 e3a0c061 MOV r12,#0x61
+00074c e5e0c002 STRB r12,[r0,#2]!
+000750 e5c02001 STRB r2,[r0,#1]
+000754 e3a0c081 MOV r12,#0x81
+000758 e5e0c002 STRB r12,[r0,#2]!
+00075c e5c02001 STRB r2,[r0,#1]
+000760 e3a0c0c1 MOV r12,#0xc1
+000764 e5e0c002 STRB r12,[r0,#2]!
+000768 e5c02001 STRB r2,[r0,#1]
+00076c e2800002 ADD r0,r0,#2
+000770 e3a0c001 MOV r12,#1
+000774 e5c0c000 STRB r12,[r0,#0]
+000778 e5c07001 STRB r7,[r0,#1]
+00077c e2800002 ADD r0,r0,#2
+000780 e3a0c081 MOV r12,#0x81
+000784 e5c0c000 STRB r12,[r0,#0]
+000788 e5c07001 STRB r7,[r0,#1]
+00078c e2800002 ADD r0,r0,#2
+000790 e3a0c001 MOV r12,#1
+000794 e5c0c000 STRB r12,[r0,#0]
+000798 e5c0a001 STRB r10,[r0,#1]
+00079c e2800002 ADD r0,r0,#2
+0007a0 e5c0c000 STRB r12,[r0,#0]
+0007a4 e3a08003 MOV r8,#3
+0007a8 e5c08001 STRB r8,[r0,#1]
+0007ac e2800002 ADD r0,r0,#2
+0007b0 e5c0c000 STRB r12,[r0,#0]
+0007b4 e3a08004 MOV r8,#4
+0007b8 e5c08001 STRB r8,[r0,#1]
+0007bc e2800002 ADD r0,r0,#2
+0007c0 e3a0c001 MOV r12,#1
+0007c4 e5c0c000 STRB r12,[r0,#0]
+0007c8 e5c03001 STRB r3,[r0,#1]
+0007cc e2800002 ADD r0,r0,#2
+0007d0 e3a03001 MOV r3,#1
+0007d4 e5c03000 STRB r3,[r0,#0]
+0007d8 e5c04001 STRB r4,[r0,#1]
+0007dc e2800002 ADD r0,r0,#2
+0007e0 e5c03000 STRB r3,[r0,#0]
+0007e4 e3a0a00c MOV r10,#0xc
+0007e8 e5c0a001 STRB r10,[r0,#1]
+0007ec e2800002 ADD r0,r0,#2
+0007f0 e5c03000 STRB r3,[r0,#0]
+0007f4 e5c09001 STRB r9,[r0,#1]
+0007f8 e2800002 ADD r0,r0,#2
+0007fc e3a03001 MOV r3,#1
+000800 e5c03000 STRB r3,[r0,#0]
+000804 e3a03018 MOV r3,#0x18
+000808 e5c03001 STRB r3,[r0,#1]
+00080c e2800002 ADD r0,r0,#2
+000810 e3a03001 MOV r3,#1
+000814 e5c03000 STRB r3,[r0,#0]
+000818 e3a03020 MOV r3,#0x20
+00081c e5c03001 STRB r3,[r0,#1]
+000820 e2800002 ADD r0,r0,#2
+000824 e3a03001 MOV r3,#1
+000828 e5c03000 STRB r3,[r0,#0]
+00082c e3a03030 MOV r3,#0x30
+000830 e5c03001 STRB r3,[r0,#1]
+000834 e2800002 ADD r0,r0,#2
+000838 e3a03001 MOV r3,#1
+00083c e5c03000 STRB r3,[r0,#0]
+000840 e3a03040 MOV r3,#0x40
+000844 e5c03001 STRB r3,[r0,#1]
+000848 e2800002 ADD r0,r0,#2
+00084c e3a03001 MOV r3,#1
+000850 e5c03000 STRB r3,[r0,#0]
+000854 e3a03060 MOV r3,#0x60
+000858 e5c03001 STRB r3,[r0,#1]
+00085c e591007c LDR r0,[r1,#0x7c]
+000860 e581001c STR r0,[r1,#0x1c]
+000864 e1a03000 MOV r3,r0
+000868 e2800040 ADD r0,r0,#0x40
+00086c e581007c STR r0,[r1,#0x7c]
+000870 e5c32000 STRB r2,[r3,#0]
+000874 e5c32001 STRB r2,[r3,#1]
+000878 e5e32002 STRB r2,[r3,#2]!
+00087c e5c32001 STRB r2,[r3,#1]
+000880 e2833002 ADD r3,r3,#2
+000884 e3a00002 MOV r0,#2
+000888 e2402001 SUB r2,r0,#1
+00088c e0822fa2 ADD r2,r2,r2,LSR #31
+000890 e1a020c2 MOV r2,r2,ASR #1
+000894 e1a0c802 MOV r12,r2,LSL #16
+000898 e1a0c82c MOV r12,r12,LSR #16
+00089c e5c3c000 STRB r12,[r3,#0]
+0008a0 e1a0242c MOV r2,r12,LSR #8
+0008a4 e5c32001 STRB r2,[r3,#1]
+0008a8 e5e3c002 STRB r12,[r3,#2]!
+0008ac e5c32001 STRB r2,[r3,#1]
+0008b0 e2833002 ADD r3,r3,#2
+0008b4 e2800002 ADD r0,r0,#2
+0008b8 e350001e CMP r0,#0x1e
+0008bc bafffff1 BLT 0x888
+0008c0 e591007c LDR r0,[r1,#0x7c]
+0008c4 e5a10020 STR r0,[r1,#0x20]!
+0008c8 e8bd87f0 LDMIA r13!,{r4-r10,pc}
+0008cc e5923004 LDR r3,[r2,#4]
+0008d0 e1530000 CMP r3,r0
+0008d4 2a000008 BCS 0x8fc
+0008d8 e5923008 LDR r3,[r2,#8]
+0008dc e4d3c001 LDRB r12,[r3],#1
+0008e0 e5823008 STR r3,[r2,#8]
+0008e4 e5923004 LDR r3,[r2,#4]
+0008e8 e181131c ORR r1,r1,r12,LSL r3
+0008ec e2833008 ADD r3,r3,#8
+0008f0 e5823004 STR r3,[r2,#4]
+0008f4 e1530000 CMP r3,r0
+0008f8 3afffff6 BCC 0x8d8
+0008fc e1a00001 MOV r0,r1
+000900 e1a0f00e MOV pc,r14
+000904 e1a0c00d MOV r12,r13
+000908 e92d000f STMDB r13!,{r0-r3}
+00090c e92ddff0 STMDB r13!,{r4-r12,r14,pc}
+000910 e24cb014 SUB r11,r12,#0x14
+000914 e59b301c LDR r3,[r11,#0x1c]
+000918 e24ddf5b SUB r13,r13,#0x16c
+00091c e24ddb01 SUB r13,r13,#0x400
+000920 e3a02000 MOV r2,#0
+000924 e3a0c000 MOV r12,#0
+000928 e28def46 ADD r14,r13,#0x118
+00092c e28eeb01 ADD r14,r14,#0x400
+000930 e78ec102 STR r12,[r14,r2,LSL #2]
+000934 e2822001 ADD r2,r2,#1
+000938 e3520011 CMP r2,#0x11
+00093c 3afffff9 BCC 0x928
+000940 e1a02000 MOV r2,r0
+000944 e1a0e001 MOV r14,r1
+000948 e28d5f46 ADD r5,r13,#0x118
+00094c e2855b01 ADD r5,r5,#0x400
+000950 e4924004 LDR r4,[r2],#4
+000954 e0854104 ADD r4,r5,r4,LSL #2
+000958 e5945000 LDR r5,[r4,#0]
+00095c e2855001 ADD r5,r5,#1
+000960 e25ee001 SUBS r14,r14,#1
+000964 e5845000 STR r5,[r4,#0]
+000968 1afffff6 BNE 0x948
+00096c e59d2518 LDR r2,[r13,#0x518]
+000970 e1320001 TEQ r2,r1
+000974 1a000004 BNE 0x98c
+000978 e1a0000c MOV r0,r12
+00097c e59bc018 LDR r12,[r11,#0x18]
+000980 e58c0000 STR r0,[r12,#0]
+000984 e5830000 STR r0,[r3,#0]
+000988 ea000107 B 0xdac
+00098c e3a04001 MOV r4,#1
+000990 e5932000 LDR r2,[r3,#0]
+000994 e28def46 ADD r14,r13,#0x118
+000998 e28eeb01 ADD r14,r14,#0x400
+00099c e79ee104 LDR r14,[r14,r4,LSL #2]
+0009a0 e33e0000 TEQ r14,#0
+0009a4 1a000002 BNE 0x9b4
+0009a8 e2844001 ADD r4,r4,#1
+0009ac e3540010 CMP r4,#0x10
+0009b0 9afffff7 BLS 0x994
+0009b4 e1a05004 MOV r5,r4
+0009b8 e1520004 CMP r2,r4
+0009bc 31a02004 MOVCC r2,r4
+0009c0 e3a0e010 MOV r14,#0x10
+0009c4 e28d6f46 ADD r6,r13,#0x118
+0009c8 e2866b01 ADD r6,r6,#0x400
+0009cc e796610e LDR r6,[r6,r14,LSL #2]
+0009d0 e3360000 TEQ r6,#0
+0009d4 1a000001 BNE 0x9e0
+0009d8 e25ee001 SUBS r14,r14,#1
+0009dc 1afffff8 BNE 0x9c4
+0009e0 e58de510 STR r14,[r13,#0x510]
+0009e4 e152000e CMP r2,r14
+0009e8 81a0200e MOVHI r2,r14
+0009ec e5832000 STR r2,[r3,#0]
+0009f0 e3a03001 MOV r3,#1
+0009f4 e1a07413 MOV r7,r3,LSL r4
+0009f8 e3a06002 MOV r6,#2
+0009fc e154000e CMP r4,r14
+000a00 2a00000a BCS 0xa30
+000a04 e28d8f46 ADD r8,r13,#0x118
+000a08 e2888b01 ADD r8,r8,#0x400
+000a0c e7988104 LDR r8,[r8,r4,LSL #2]
+000a10 e0577008 SUBS r7,r7,r8
+000a14 5a000001 BPL 0xa20
+000a18 e1a00006 MOV r0,r6
+000a1c ea0000e2 B 0xdac
+000a20 e2844001 ADD r4,r4,#1
+000a24 e1a07087 MOV r7,r7,LSL #1
+000a28 e154000e CMP r4,r14
+000a2c 3afffff4 BCC 0xa04
+000a30 e28d4f46 ADD r4,r13,#0x118
+000a34 e2844b01 ADD r4,r4,#0x400
+000a38 e794410e LDR r4,[r4,r14,LSL #2]
+000a3c e0577004 SUBS r7,r7,r4
+000a40 e58d7000 STR r7,[r13,#0]
+000a44 4afffff3 BMI 0xa18
+000a48 e59d7000 LDR r7,[r13,#0]
+000a4c e0846007 ADD r6,r4,r7
+000a50 e28d4f46 ADD r4,r13,#0x118
+000a54 e2844b01 ADD r4,r4,#0x400
+000a58 e784610e STR r6,[r4,r14,LSL #2]
+000a5c e3a04000 MOV r4,#0
+000a60 e58d4008 STR r4,[r13,#8]
+000a64 e28d6f47 ADD r6,r13,#0x11c
+000a68 e2866b01 ADD r6,r6,#0x400
+000a6c e28d700c ADD r7,r13,#0xc
+000a70 e25ee001 SUBS r14,r14,#1
+000a74 0a000004 BEQ 0xa8c
+000a78 e4968004 LDR r8,[r6],#4
+000a7c e0884004 ADD r4,r8,r4
+000a80 e25ee001 SUBS r14,r14,#1
+000a84 e4874004 STR r4,[r7],#4
+000a88 1afffffa BNE 0xa78
+000a8c e1a04000 MOV r4,r0
+000a90 e4940004 LDR r0,[r4],#4
+000a94 e3300000 TEQ r0,#0
+000a98 0a000006 BEQ 0xab8
+000a9c e28d6004 ADD r6,r13,#4
+000aa0 e7968100 LDR r8,[r6,r0,LSL #2]
+000aa4 e2887001 ADD r7,r8,#1
+000aa8 e28d6004 ADD r6,r13,#4
+000aac e7867100 STR r7,[r6,r0,LSL #2]
+000ab0 e28d0048 ADD r0,r13,#0x48
+000ab4 e780e108 STR r14,[r0,r8,LSL #2]
+000ab8 e28ee001 ADD r14,r14,#1
+000abc e15e0001 CMP r14,r1
+000ac0 3afffff2 BCC 0xa90
+000ac4 e3a0e000 MOV r14,#0
+000ac8 e58de004 STR r14,[r13,#4]
+000acc e28d6048 ADD r6,r13,#0x48
+000ad0 e3e04000 MVN r4,#0
+000ad4 e2620000 RSB r0,r2,#0
+000ad8 e3a08000 MOV r8,#0
+000adc e3a07000 MOV r7,#0
+000ae0 e58dc4c8 STR r12,[r13,#0x4c8]
+000ae4 e59d9510 LDR r9,[r13,#0x510]
+000ae8 e1550009 CMP r5,r9
+000aec ca0000a8 BGT 0xd94
+000af0 e28dc048 ADD r12,r13,#0x48
+000af4 e08c1101 ADD r1,r12,r1,LSL #2
+000af8 e58d1568 STR r1,[r13,#0x568]
+000afc e28d1f46 ADD r1,r13,#0x118
+000b00 e2811b01 ADD r1,r1,#0x400
+000b04 e7911105 LDR r1,[r1,r5,LSL #2]
+000b08 e2413001 SUB r3,r1,#1
+000b0c e3310000 TEQ r1,#0
+000b10 e58d355c STR r3,[r13,#0x55c]
+000b14 0a00009a BEQ 0xd84
+000b18 e28d3f46 ADD r3,r13,#0x118
+000b1c e2833b01 ADD r3,r3,#0x400
+000b20 e083c105 ADD r12,r3,r5,LSL #2
+000b24 e2451001 SUB r1,r5,#1
+000b28 e3a03001 MOV r3,#1
+000b2c e1a01113 MOV r1,r3,LSL r1
+000b30 e58d1560 STR r1,[r13,#0x560]
+000b34 e58dc564 STR r12,[r13,#0x564]
+000b38 e0801002 ADD r1,r0,r2
+000b3c e1510005 CMP r1,r5
+000b40 aa000041 BGE 0xc4c
+000b44 e59d155c LDR r1,[r13,#0x55c]
+000b48 e2811001 ADD r1,r1,#1
+000b4c e2844001 ADD r4,r4,#1
+000b50 e0800002 ADD r0,r0,r2
+000b54 e59d3510 LDR r3,[r13,#0x510]
+000b58 e0433000 SUB r3,r3,r0
+000b5c e1530002 CMP r3,r2
+000b60 91a07003 MOVLS r7,r3
+000b64 81a07002 MOVHI r7,r2
+000b68 e0453000 SUB r3,r5,r0
+000b6c e3a0a001 MOV r10,#1
+000b70 e1a0c31a MOV r12,r10,LSL r3
+000b74 e15c0001 CMP r12,r1
+000b78 9a00000c BLS 0xbb0
+000b7c e04c8001 SUB r8,r12,r1
+000b80 e2833001 ADD r3,r3,#1
+000b84 e1530007 CMP r3,r7
+000b88 e59dc564 LDR r12,[r13,#0x564]
+000b8c 2a000007 BCS 0xbb0
+000b90 e1a09088 MOV r9,r8,LSL #1
+000b94 e5bc8004 LDR r8,[r12,#4]!
+000b98 e1590008 CMP r9,r8
+000b9c 9a000003 BLS 0xbb0
+000ba0 e0498008 SUB r8,r9,r8
+000ba4 e2833001 ADD r3,r3,#1
+000ba8 e1530007 CMP r3,r7
+000bac 3afffff7 BCC 0xb90
+000bb0 e1a0731a MOV r7,r10,LSL r3
+000bb4 e59b9020 LDR r9,[r11,#0x20]
+000bb8 e5b9c07c LDR r12,[r9,#0x7c]!
+000bbc e08c8187 ADD r8,r12,r7,LSL #3
+000bc0 e2888008 ADD r8,r8,#8
+000bc4 e59b9020 LDR r9,[r11,#0x20]
+000bc8 e5a9807c STR r8,[r9,#0x7c]!
+000bcc e28c8008 ADD r8,r12,#8
+000bd0 e59b9018 LDR r9,[r11,#0x18]
+000bd4 e5898000 STR r8,[r9,#0]
+000bd8 e3a09000 MOV r9,#0
+000bdc e28cc004 ADD r12,r12,#4
+000be0 e58bc018 STR r12,[r11,#0x18]
+000be4 e58c9000 STR r9,[r12,#0]
+000be8 e28dc0c8 ADD r12,r13,#0xc8
+000bec e28ccb01 ADD r12,r12,#0x400
+000bf0 e78c8104 STR r8,[r12,r4,LSL #2]
+000bf4 e3340000 TEQ r4,#0
+000bf8 0a000010 BEQ 0xc40
+000bfc e28dc004 ADD r12,r13,#4
+000c00 e78ce104 STR r14,[r12,r4,LSL #2]
+000c04 e5cd2509 STRB r2,[r13,#0x509]
+000c08 e2833010 ADD r3,r3,#0x10
+000c0c e5cd3508 STRB r3,[r13,#0x508]
+000c10 e0403002 SUB r3,r0,r2
+000c14 e1a0333e MOV r3,r14,LSR r3
+000c18 e58d850c STR r8,[r13,#0x50c]
+000c1c e28dc0c8 ADD r12,r13,#0xc8
+000c20 e28ccb01 ADD r12,r12,#0x400
+000c24 e08cc104 ADD r12,r12,r4,LSL #2
+000c28 e51cc004 LDR r12,[r12,#-4]
+000c2c e08c9183 ADD r9,r12,r3,LSL #3
+000c30 e28daf42 ADD r10,r13,#0x108
+000c34 e28aab01 ADD r10,r10,#0x400
+000c38 e89a1008 LDMIA r10,{r3,r12}
+000c3c e8891008 STMIA r9,{r3,r12}
+000c40 e0803002 ADD r3,r0,r2
+000c44 e1530005 CMP r3,r5
+000c48 baffffbf BLT 0xb4c
+000c4c e0453000 SUB r3,r5,r0
+000c50 e5cd3509 STRB r3,[r13,#0x509]
+000c54 e59d1568 LDR r1,[r13,#0x568]
+000c58 e1510006 CMP r1,r6
+000c5c 93a01063 MOVLS r1,#0x63
+000c60 95cd1508 STRLSB r1,[r13,#0x508]
+000c64 9a000019 BLS 0xcd0
+000c68 e5961000 LDR r1,[r6,#0]
+000c6c e59bc00c LDR r12,[r11,#0xc]
+000c70 e151000c CMP r1,r12
+000c74 2a000008 BCS 0xc9c
+000c78 e3510c01 CMP r1,#0x100
+000c7c 23a0100f MOVCS r1,#0xf
+000c80 33a01010 MOVCC r1,#0x10
+000c84 e5cd1508 STRB r1,[r13,#0x508]
+000c88 e4961004 LDR r1,[r6],#4
+000c8c e5cd150c STRB r1,[r13,#0x50c]
+000c90 e1a01441 MOV r1,r1,ASR #8
+000c94 e5cd150d STRB r1,[r13,#0x50d]
+000c98 ea00000c B 0xcd0
+000c9c e59bc00c LDR r12,[r11,#0xc]
+000ca0 e041100c SUB r1,r1,r12
+000ca4 e59bc014 LDR r12,[r11,#0x14]
+000ca8 e79c1081 LDR r1,[r12,r1,LSL #1]
+000cac e5cd1508 STRB r1,[r13,#0x508]
+000cb0 e4961004 LDR r1,[r6],#4
+000cb4 e59bc00c LDR r12,[r11,#0xc]
+000cb8 e041100c SUB r1,r1,r12
+000cbc e59bc010 LDR r12,[r11,#0x10]
+000cc0 e79c1081 LDR r1,[r12,r1,LSL #1]
+000cc4 e5cd150c STRB r1,[r13,#0x50c]
+000cc8 e1a01441 MOV r1,r1,ASR #8
+000ccc e5cd150d STRB r1,[r13,#0x50d]
+000cd0 e3a0c001 MOV r12,#1
+000cd4 e1a0331c MOV r3,r12,LSL r3
+000cd8 e1a0103e MOV r1,r14,LSR r0
+000cdc e1510007 CMP r1,r7
+000ce0 e58d3514 STR r3,[r13,#0x514]
+000ce4 2a000008 BCS 0xd0c
+000ce8 e088a181 ADD r10,r8,r1,LSL #3
+000cec e28d9f42 ADD r9,r13,#0x108
+000cf0 e2899b01 ADD r9,r9,#0x400
+000cf4 e8991008 LDMIA r9,{r3,r12}
+000cf8 e88a1008 STMIA r10,{r3,r12}
+000cfc e59d3514 LDR r3,[r13,#0x514]
+000d00 e0811003 ADD r1,r1,r3
+000d04 e1510007 CMP r1,r7
+000d08 3afffff6 BCC 0xce8
+000d0c e3a0c001 MOV r12,#1
+000d10 e59d1560 LDR r1,[r13,#0x560]
+000d14 e11e0001 TST r14,r1
+000d18 0a000003 BEQ 0xd2c
+000d1c e02ee001 EOR r14,r14,r1
+000d20 e1a010a1 MOV r1,r1,LSR #1
+000d24 e11e0001 TST r14,r1
+000d28 1afffffb BNE 0xd1c
+000d2c e02ee001 EOR r14,r14,r1
+000d30 e1a0101c MOV r1,r12,LSL r0
+000d34 e2411001 SUB r1,r1,#1
+000d38 e001100e AND r1,r1,r14
+000d3c e28d3004 ADD r3,r13,#4
+000d40 e7933104 LDR r3,[r3,r4,LSL #2]
+000d44 e1310003 TEQ r1,r3
+000d48 0a000008 BEQ 0xd70
+000d4c e2444001 SUB r4,r4,#1
+000d50 e0400002 SUB r0,r0,r2
+000d54 e1a0101c MOV r1,r12,LSL r0
+000d58 e2411001 SUB r1,r1,#1
+000d5c e001300e AND r3,r1,r14
+000d60 e28d1004 ADD r1,r13,#4
+000d64 e7911104 LDR r1,[r1,r4,LSL #2]
+000d68 e1330001 TEQ r3,r1
+000d6c 1afffff6 BNE 0xd4c
+000d70 e59d155c LDR r1,[r13,#0x55c]
+000d74 e2413001 SUB r3,r1,#1
+000d78 e3310000 TEQ r1,#0
+000d7c e58d355c STR r3,[r13,#0x55c]
+000d80 1affff6c BNE 0xb38
+000d84 e2855001 ADD r5,r5,#1
+000d88 e59d3510 LDR r3,[r13,#0x510]
+000d8c e1550003 CMP r5,r3
+000d90 daffff59 BLE 0xafc
+000d94 e59d7000 LDR r7,[r13,#0]
+000d98 e3370000 TEQ r7,#0
+000d9c 159d3510 LDRNE r3,[r13,#0x510]
+000da0 13330001 TEQNE r3,#1
+000da4 03a00000 MOVEQ r0,#0
+000da8 13a00001 MOVNE r0,#1
+000dac e91baff0 LDMDB r11,{r4-r11,r13,pc}
+000db0 e1a0c00d MOV r12,r13
+000db4 e92dd8f0 STMDB r13!,{r4-r7,r11,r12,r14,pc}
+000db8 e24cb004 SUB r11,r12,#4
+000dbc e1a04002 MOV r4,r2
+000dc0 e1a02003 MOV r2,r3
+000dc4 e3a03000 MOV r3,#0
+000dc8 e3a00008 MOV r0,#8
+000dcc e28b6008 ADD r6,r11,#8
+000dd0 e8960060 LDMIA r6,{r5,r6}
+000dd4 e59b7004 LDR r7,[r11,#4]
+000dd8 e7850103 STR r0,[r5,r3,LSL #2]
+000ddc e2833001 ADD r3,r3,#1
+000de0 e3530090 CMP r3,#0x90
+000de4 bafffffb BLT 0xdd8
+000de8 e3a0c009 MOV r12,#9
+000dec e3530c01 CMP r3,#0x100
+000df0 aa000003 BGE 0xe04
+000df4 e785c103 STR r12,[r5,r3,LSL #2]
+000df8 e2833001 ADD r3,r3,#1
+000dfc e3530c01 CMP r3,#0x100
+000e00 bafffffb BLT 0xdf4
+000e04 e3a0c007 MOV r12,#7
+000e08 e3530f46 CMP r3,#0x118
+000e0c aa000003 BGE 0xe20
+000e10 e785c103 STR r12,[r5,r3,LSL #2]
+000e14 e2833001 ADD r3,r3,#1
+000e18 e3530f46 CMP r3,#0x118
+000e1c bafffffb BLT 0xe10
+000e20 e3530e12 CMP r3,#0x120
+000e24 aa000003 BGE 0xe38
+000e28 e7850103 STR r0,[r5,r3,LSL #2]
+000e2c e2833001 ADD r3,r3,#1
+000e30 e3530e12 CMP r3,#0x120
+000e34 bafffffb BLT 0xe28
+000e38 e1a03006 MOV r3,r6
+000e3c e582c000 STR r12,[r2,#0]
+000e40 e5960014 LDR r0,[r6,#0x14]
+000e44 e92d000f STMDB r13!,{r0-r3}
+000e48 e1a00005 MOV r0,r5
+000e4c e3a02001 MOV r2,#1
+000e50 e2822c01 ADD r2,r2,#0x100
+000e54 e3a01e12 MOV r1,#0x120
+000e58 e5963010 LDR r3,[r6,#0x10]
+000e60 e28dd010 ADD r13,r13,#0x10
+000e64 e1b03000 MOVS r3,r0
+000e68 191ba8f0 LDMNEDB r11,{r4-r7,r11,r13,pc}
+000e6c e3a00005 MOV r0,#5
+000e70 e7850103 STR r0,[r5,r3,LSL #2]
+000e74 e2833001 ADD r3,r3,#1
+000e78 e353001e CMP r3,#0x1e
+000e7c bafffffb BLT 0xe70
+000e80 e1a03006 MOV r3,r6
+000e84 e5870000 STR r0,[r7,#0]
+000e88 e1a02007 MOV r2,r7
+000e8c e1a01004 MOV r1,r4
+000e90 e596001c LDR r0,[r6,#0x1c]
+000e94 e92d000f STMDB r13!,{r0-r3}
+000e98 e1a00005 MOV r0,r5
+000e9c e3a02000 MOV r2,#0
+000ea0 e3a0101e MOV r1,#0x1e
+000ea4 e5b63018 LDR r3,[r6,#0x18]!
+000eac e28dd010 ADD r13,r13,#0x10
+000eb0 e3500001 CMP r0,#1
+000eb4 d3a00000 MOVLE r0,#0
+000eb8 e91ba8f0 LDMDB r11,{r4-r7,r11,r13,pc}
+000ebc e1a0c00d MOV r12,r13
+000ec0 e92d000f STMDB r13!,{r0-r3}
+000ec4 e92ddff0 STMDB r13!,{r4-r12,r14,pc}
+000ec8 e24cb014 SUB r11,r12,#0x14
+000ecc e1a04003 MOV r4,r3
+000ed0 e59b501c LDR r5,[r11,#0x1c]
+000ed4 e59b8018 LDR r8,[r11,#0x18]
+000ed8 e24dd00c SUB r13,r13,#0xc
+000edc e5951000 LDR r1,[r5,#0]
+000ee0 e1a02005 MOV r2,r5
+000ee4 e3a00005 MOV r0,#5
+000eec e200101f AND r1,r0,#0x1f
+000ef0 e2811001 ADD r1,r1,#1
+000ef4 e2811c01 ADD r1,r1,#0x100
+000ef8 e58d1004 STR r1,[r13,#4]
+000efc e1a012a0 MOV r1,r0,LSR #5
+000f00 e5950004 LDR r0,[r5,#4]
+000f04 e2400005 SUB r0,r0,#5
+000f08 e5850004 STR r0,[r5,#4]
+000f0c e1a02005 MOV r2,r5
+000f10 e3a00005 MOV r0,#5
+000f18 e200101f AND r1,r0,#0x1f
+000f1c e2811001 ADD r1,r1,#1
+000f20 e58d1000 STR r1,[r13,#0]
+000f24 e1a012a0 MOV r1,r0,LSR #5
+000f28 e5950004 LDR r0,[r5,#4]
+000f2c e2400005 SUB r0,r0,#5
+000f30 e5850004 STR r0,[r5,#4]
+000f34 e1a02005 MOV r2,r5
+000f38 e3a00004 MOV r0,#4
+000f40 e200100f AND r1,r0,#0xf
+000f44 e2819004 ADD r9,r1,#4
+000f48 e1a07220 MOV r7,r0,LSR #4
+000f4c e5950004 LDR r0,[r5,#4]
+000f50 e2400004 SUB r0,r0,#4
+000f54 e5850004 STR r0,[r5,#4]
+000f58 e3a0a001 MOV r10,#1
+000f5c e59d0004 LDR r0,[r13,#4]
+000f60 e250cf47 SUBS r12,r0,#0x11c
+000f64 a35c0002 CMPGE r12,#2
+000f68 959d0000 LDRLS r0,[r13,#0]
+000f6c 9350001e CMPLS r0,#0x1e
+000f70 81a0000a MOVHI r0,r10
+000f74 8a0000c4 BHI 0x128c
+000f78 e3a06000 MOV r6,#0
+000f7c e3590000 CMP r9,#0
+000f80 8a000001 BHI 0xf8c
+000f84 e3a01000 MOV r1,#0
+000f88 ea000011 B 0xfd4
+000f8c e1a02005 MOV r2,r5
+000f90 e1a01007 MOV r1,r7
+000f94 e3a00003 MOV r0,#3
+000f9c e2002007 AND r2,r0,#7
+000fa0 e595100c LDR r1,[r5,#0xc]
+000fa4 e7911106 LDR r1,[r1,r6,LSL #2]
+000fa8 e7882101 STR r2,[r8,r1,LSL #2]
+000fac e1a071a0 MOV r7,r0,LSR #3
+000fb0 e5950004 LDR r0,[r5,#4]
+000fb4 e2400003 SUB r0,r0,#3
+000fb8 e2866001 ADD r6,r6,#1
+000fbc e1560009 CMP r6,r9
+000fc0 e5850004 STR r0,[r5,#4]
+000fc4 3afffff0 BCC 0xf8c
+000fc8 e3560013 CMP r6,#0x13
+000fcc 3affffec BCC 0xf84
+000fd0 ea000005 B 0xfec
+000fd4 e595000c LDR r0,[r5,#0xc]
+000fd8 e7900106 LDR r0,[r0,r6,LSL #2]
+000fdc e7881100 STR r1,[r8,r0,LSL #2]
+000fe0 e2866001 ADD r6,r6,#1
+000fe4 e3560013 CMP r6,#0x13
+000fe8 3afffff9 BCC 0xfd4
+000fec e3a00007 MOV r0,#7
+000ff0 e1a03005 MOV r3,r5
+000ff4 e5840000 STR r0,[r4,#0]
+000ff8 e1a02004 MOV r2,r4
+000ffc e3a00000 MOV r0,#0
+001000 e59b1008 LDR r1,[r11,#8]
+001004 e92d000f STMDB r13!,{r0-r3}
+001008 e1a00008 MOV r0,r8
+00100c e3a03000 MOV r3,#0
+001010 e3a02013 MOV r2,#0x13
+001014 e3a01013 MOV r1,#0x13
+00101c e28dd010 ADD r13,r13,#0x10
+001020 e1b06000 MOVS r6,r0
+001024 0a000001 BEQ 0x1030
+001028 e3360001 TEQ r6,#1
+00102c 0a000096 BEQ 0x128c
+001030 e89d0003 LDMIA r13,{r0,r1}
+001034 e0819000 ADD r9,r1,r0
+001038 e3a0a001 MOV r10,#1
+00103c e5940000 LDR r0,[r4,#0]
+001040 e1a0001a MOV r0,r10,LSL r0
+001044 e2402001 SUB r2,r0,#1
+001048 e3a06000 MOV r6,#0
+00104c e1a0a006 MOV r10,r6
+001050 e3590000 CMP r9,#0
+001054 e58d2008 STR r2,[r13,#8]
+001058 9a000068 BLS 0x1200
+00105c e1a02005 MOV r2,r5
+001060 e1a01007 MOV r1,r7
+001064 e5940000 LDR r0,[r4,#0]
+00106c e1a01000 MOV r1,r0
+001070 e59d2008 LDR r2,[r13,#8]
+001074 e0000002 AND r0,r0,r2
+001078 e59b2008 LDR r2,[r11,#8]
+00107c e5922000 LDR r2,[r2,#0]
+001080 e0820180 ADD r0,r2,r0,LSL #3
+001084 e59b200c LDR r2,[r11,#0xc]
+001088 e5820000 STR r0,[r2,#0]
+00108c e5d00001 LDRB r0,[r0,#1]
+001090 e1a07031 MOV r7,r1,LSR r0
+001094 e5951004 LDR r1,[r5,#4]
+001098 e0410000 SUB r0,r1,r0
+00109c e5850004 STR r0,[r5,#4]
+0010a0 e59b200c LDR r2,[r11,#0xc]
+0010a4 e5920000 LDR r0,[r2,#0]
+0010a8 e5900004 LDR r0,[r0,#4]
+0010ac e1a00800 MOV r0,r0,LSL #16
+0010b0 e1a00820 MOV r0,r0,LSR #16
+0010b4 e3500010 CMP r0,#0x10
+0010b8 2a000004 BCS 0x10d0
+0010bc e1a0a000 MOV r10,r0
+0010c0 e1a00006 MOV r0,r6
+0010c4 e2866001 ADD r6,r6,#1
+0010c8 e788a100 STR r10,[r8,r0,LSL #2]
+0010cc ea000049 B 0x11f8
+0010d0 1a000018 BNE 0x1138
+0010d4 e1a02005 MOV r2,r5
+0010d8 e1a01007 MOV r1,r7
+0010dc e3a00002 MOV r0,#2
+0010e4 e2001003 AND r1,r0,#3
+0010e8 e2811003 ADD r1,r1,#3
+0010ec e1a07120 MOV r7,r0,LSR #2
+0010f0 e5950004 LDR r0,[r5,#4]
+0010f4 e2400002 SUB r0,r0,#2
+0010f8 e5850004 STR r0,[r5,#4]
+0010fc e0860001 ADD r0,r6,r1
+001100 e1500009 CMP r0,r9
+001104 9a000001 BLS 0x1110
+001108 e3a00001 MOV r0,#1
+00110c ea00005e B 0x128c
+001110 e2410001 SUB r0,r1,#1
+001114 e3310000 TEQ r1,#0
+001118 0a000036 BEQ 0x11f8
+00111c e1a01006 MOV r1,r6
+001120 e2866001 ADD r6,r6,#1
+001124 e788a101 STR r10,[r8,r1,LSL #2]
+001128 e1b01000 MOVS r1,r0
+00112c e2400001 SUB r0,r0,#1
+001130 1afffff9 BNE 0x111c
+001134 ea00002f B 0x11f8
+001138 e3300011 TEQ r0,#0x11
+00113c e1a02005 MOV r2,r5
+001140 e1a01007 MOV r1,r7
+001144 1a000015 BNE 0x11a0
+001148 e3a00003 MOV r0,#3
+001150 e2001007 AND r1,r0,#7
+001154 e2811003 ADD r1,r1,#3
+001158 e1a071a0 MOV r7,r0,LSR #3
+00115c e5950004 LDR r0,[r5,#4]
+001160 e2400003 SUB r0,r0,#3
+001164 e5850004 STR r0,[r5,#4]
+001168 e0860001 ADD r0,r6,r1
+00116c e1500009 CMP r0,r9
+001170 8affffe4 BHI 0x1108
+001174 e2410001 SUB r0,r1,#1
+001178 e3310000 TEQ r1,#0
+00117c 0a00001c BEQ 0x11f4
+001180 e3a02000 MOV r2,#0
+001184 e1a01006 MOV r1,r6
+001188 e2866001 ADD r6,r6,#1
+00118c e7882101 STR r2,[r8,r1,LSL #2]
+001190 e1b01000 MOVS r1,r0
+001194 e2400001 SUB r0,r0,#1
+001198 1afffff9 BNE 0x1184
+00119c ea000014 B 0x11f4
+0011a0 e3a00007 MOV r0,#7
+0011a8 e200107f AND r1,r0,#0x7f
+0011ac e281100b ADD r1,r1,#0xb
+0011b0 e1a073a0 MOV r7,r0,LSR #7
+0011b4 e5950004 LDR r0,[r5,#4]
+0011b8 e2400007 SUB r0,r0,#7
+0011bc e5850004 STR r0,[r5,#4]
+0011c0 e0860001 ADD r0,r6,r1
+0011c4 e1500009 CMP r0,r9
+0011c8 8affffce BHI 0x1108
+0011cc e2410001 SUB r0,r1,#1
+0011d0 e3310000 TEQ r1,#0
+0011d4 0a000006 BEQ 0x11f4
+0011d8 e3a02000 MOV r2,#0
+0011dc e1a01006 MOV r1,r6
+0011e0 e2866001 ADD r6,r6,#1
+0011e4 e7882101 STR r2,[r8,r1,LSL #2]
+0011e8 e1b01000 MOVS r1,r0
+0011ec e2400001 SUB r0,r0,#1
+0011f0 1afffff9 BNE 0x11dc
+0011f4 e3a0a000 MOV r10,#0
+0011f8 e1560009 CMP r6,r9
+0011fc 3affff96 BCC 0x105c
+001200 e5950020 LDR r0,[r5,#0x20]
+001204 e585007c STR r0,[r5,#0x7c]
+001208 e3a00009 MOV r0,#9
+00120c e5857000 STR r7,[r5,#0]
+001210 e1a03005 MOV r3,r5
+001214 e5840000 STR r0,[r4,#0]
+001218 e1a02004 MOV r2,r4
+00121c e59b1008 LDR r1,[r11,#8]
+001220 e5950014 LDR r0,[r5,#0x14]
+001224 e92d000f STMDB r13!,{r0-r3}
+001228 e5953010 LDR r3,[r5,#0x10]
+00122c e1a00008 MOV r0,r8
+001230 e3a02001 MOV r2,#1
+001234 e2822c01 ADD r2,r2,#0x100
+001238 e59d1014 LDR r1,[r13,#0x14]
+001240 e28dd010 ADD r13,r13,#0x10
+001244 e3300000 TEQ r0,#0
+001248 1a00000f BNE 0x128c
+00124c e3a00006 MOV r0,#6
+001250 e59b2014 LDR r2,[r11,#0x14]
+001254 e1a03005 MOV r3,r5
+001258 e5820000 STR r0,[r2,#0]
+00125c e59b100c LDR r1,[r11,#0xc]
+001260 e59b2014 LDR r2,[r11,#0x14]
+001264 e595001c LDR r0,[r5,#0x1c]
+001268 e92d000f STMDB r13!,{r0-r3}
+00126c e5b53018 LDR r3,[r5,#0x18]!
+001270 e59d0014 LDR r0,[r13,#0x14]
+001274 e0880100 ADD r0,r8,r0,LSL #2
+001278 e3a02000 MOV r2,#0
+00127c e59d1010 LDR r1,[r13,#0x10]
+001284 e28dd010 ADD r13,r13,#0x10
+001288 e3300000 TEQ r0,#0
+00128c e91baff0 LDMDB r11,{r4-r11,r13,pc}
+
+\ LICENSE_BEGIN
+\ Copyright (c) 2008 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/testasm.txt
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/testmmu.fth
===================================================================
--- cpu/arm/testmmu.fth (rev 0)
+++ cpu/arm/testmmu.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,3 @@
+select /mmu
+1000 1000 claim constant pf
+40000000 pf 1000 -2 map
Property changes on: cpu/arm/testmmu.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/tools.bth
===================================================================
--- cpu/arm/tools.bth (rev 0)
+++ cpu/arm/tools.bth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,47 @@
+purpose: Load file for Forth toolkit, without firmware
+\ See license at end of file
+
+dictionary: ${BP}/cpu/arm/build/kernel.dic
+command: &armforth &dictionary &this
+build-now
+
+\ ' $report-name is include-hook
+\ ' noop is include-hook
+\ : rn (cr 2dup type 15 spaces ; ' rn is include-hook
+
+fload ${BP}/forth/lib/fwsetup.fth
+
+transient
+true value assembler? \ False to discard assembler after compilation
+resident
+
+fload ${BP}/forth/lib/loadcomm.fth \ CPU-independent Forth tools
+fload ${BP}/cpu/arm/loadmach.fth \ CPU and OS-specific extensions
+
+[ifndef] no-heads
+.( --- Saving tools.dic --- ) " tools.dic" $save-forth cr
+[then]
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1994 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/tools.bth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/traps.fth
===================================================================
--- cpu/arm/traps.fth (rev 0)
+++ cpu/arm/traps.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,82 @@
+purpose: Save the processor state after an exception - hardware version
+\ See license at end of file
+
+only forth also hidden also forth definitions
+
+\ The common subroutines on which this depends are defined in
+\ cpu/arm/register.fth
+
+headerless
+
+\ This is the first part of the exception handling sequence and the last
+\ half of the exception restart sequence. It is executed in exception state.
+
+label hw-save-state
+ \ On entry: r13: scratch r14: PC from old mode
+
+ \ Check for second half of (restart, if so restore all the registers
+ \ from the save area and return from the exception.
+
+ 'code (restart drop restart-offset + ( offset )
+ adr r13,* \ Address of trap in (restart
+
+ dec r14,1cell \ Point to the trapped instruction
+ cmp r13,r14
+
+ adr r13,'body main-task \ Get user pointer address
+ ldr r13,[r13] \ Get user pointer
+ ldr r13,[r13,`'user# cpu-state`] \ State save address
+
+ beq 'body restart-common
+
+ stmia r13,{r0,r1,r2,r3,r4,r5,r6,r7,r8,r9,r10,r11,r12}
+
+ mov r0,r13 \ Move cpu-state pointer into r0
+ mov r4,#0 \ Set r4 to 0 to indicate no user abort
+ b 'body save-common
+end-code
+
+: hw-install-handler ( handler exception# -- )
+ \ Put "ldr pc,[pc,40-8]" in exception vector at 0 + (exception# * 4)
+ h# e59ff038 over /l* instruction! ( exception# )
+
+ \ Put handler address in address table at 40 + (exception# * 4)
+ h# 40 swap la+ l!
+;
+: hw-catch-exception ( exception# -- ) hw-save-state swap install-handler ;
+
+: stand-init-io ( -- )
+ stand-init-io
+ ['] (restart is restart
+ ['] hw-install-handler is install-handler
+ ['] hw-catch-exception is catch-exception
+ catch-exceptions
+ 2 catch-exception \ Software interrupt (we don't catch this under DEMON)
+;
+
+headers
+only forth also definitions
+
+\ LICENSE_BEGIN
+\ Copyright (c) 1997 FirmWorks
+\
+\ Permission is hereby granted, free of charge, to any person obtaining
+\ a copy of this software and associated documentation files (the
+\ "Software"), to deal in the Software without restriction, including
+\ without limitation the rights to use, copy, modify, merge, publish,
+\ distribute, sublicense, and/or sell copies of the Software, and to
+\ permit persons to whom the Software is furnished to do so, subject to
+\ the following conditions:
+\
+\ The above copyright notice and this permission notice shall be
+\ included in all copies or substantial portions of the Software.
+\
+\ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+\ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+\ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+\ NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+\ LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+\ OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+\ WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+\
+\ LICENSE_END
Property changes on: cpu/arm/traps.fth
___________________________________________________________________
Added: svn:executable
+ *
Added: cpu/arm/version.fth
===================================================================
--- cpu/arm/version.fth (rev 0)
+++ cpu/arm/version.fth 2008-12-20 07:55:35 UTC (rev 1039)
@@ -0,0 +1,5 @@
+defer title
+: .copyright (s -- )
+ ." Forthmacs for ARM, Copyright (c) 1988-2008 FirmWorks" cr
+;
+' .copyright is title
Property changes on: cpu/arm/version.fth
___________________________________________________________________
Added: svn:executable
+ *
1
0
Author: wmb
Date: 2008-12-20 08:13:33 +0100 (Sat, 20 Dec 2008)
New Revision: 1038
Modified:
ofw/inet/http.fth
Log:
HTTP - Added "Connection: close" to turn off connection persistence,
thus saving several seconds at the end of a transfer (no waiting for
the server to give up and close the connection).
Modified: ofw/inet/http.fth
===================================================================
--- ofw/inet/http.fth 2008-12-20 06:28:02 UTC (rev 1037)
+++ ofw/inet/http.fth 2008-12-20 07:13:33 UTC (rev 1038)
@@ -260,7 +260,7 @@
" GET " tcp-write ( send$ prefix$ server$ )
2swap tcp-write 2swap tcp-write ( server$ )
- " HTTP/1.1"r"nUser-Agent: FirmWorks/1.1"r"nHost: " tcp-write
+ " HTTP/1.1"r"nUser-Agent: FirmWorks/1.1"r"nConnection: close"r"nHost: " tcp-write
tcp-write " "r"n"r"n" tcp-write
" flush-writes" $call-parent
1
0
Author: wmb
Date: 2008-12-20 07:28:02 +0100 (Sat, 20 Dec 2008)
New Revision: 1037
Modified:
ofw/inet/tcp.fth
Log:
TCP - fixed a longstanding problem with passive connection termination.
Modified: ofw/inet/tcp.fth
===================================================================
--- ofw/inet/tcp.fth 2008-12-19 19:06:16 UTC (rev 1036)
+++ ofw/inet/tcp.fth 2008-12-20 06:28:02 UTC (rev 1037)
@@ -542,6 +542,7 @@
0 value cantrcvmore?
: set-flag ( bitmask -- ) t_flags or to t_flags ;
+: clear-flag ( bitmask -- ) invert t_flags and to t_flags ;
: set-acknow ( -- ) acknow set-flag ;
: clear-iflag ( flag -- ) iflags swap invert and to iflags ;
: iflag? ( bitmask -- ) iflags and 0<> ;
@@ -961,7 +962,7 @@
win 0> rcv_nxt win + rcv_adv s> and if
rcv_nxt win + to rcv_adv
then
- t_flags acknow delack or invert and to t_flags
+ acknow delack or clear-flag
;
: tcp_output ( -- )
@@ -1063,8 +1064,8 @@
\ ACK for outgoing data
- iack snd_una - 0>
- iack snd_max - 0<= and
+ iack snd_una s>
+ iack snd_max s<= and
snd_cwnd snd_wnd >= and
t_dupacks tcprexmtthresh < and if
\ This is a pure ack for outstanding data
@@ -1541,6 +1542,7 @@
acked wbuf-actual > dup if ( flag )
snd_wnd wbuf-actual - to snd_wnd ( flag )
wbuf-actual wbuf-drop ( flag )
+ sentfin clear-flag
else ( flag )
acked wbuf-drop ( flag )
snd_wnd acked - to snd_wnd ( flag )
@@ -1635,7 +1637,7 @@
iack snd_max = if
tcpt_rexmt off
- 1 to needoutput
+ true to needoutput
else
tcpt_persist @ 0= if t_rxtcur tcpt_rexmt ! then
then
@@ -1994,7 +1996,7 @@
false instance value do-delack?
: do-delack ( -- )
do-delack? if
- t_flags delack invert and acknow or to t_flags
+ delack clear-flag acknow set-flag
tcp_output
false to do-delack?
then
1
0