openfirmware

openfirmware@openfirmware.info

3007 discussions

r1039 - in cpu: . arm arm/Linux arm/build
by svn＠openfirmware.info 20 Dec '08

20 Dec '08

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

r1038 - ofw/inet
by svn＠openfirmware.info 20 Dec '08

20 Dec '08

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

r1037 - ofw/inet
by svn＠openfirmware.info 20 Dec '08

20 Dec '08

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

r1036 - forth/wrapper
by svn＠openfirmware.info 19 Dec '08

19 Dec '08

Author: wmb Date: 2008-12-19 20:06:16 +0100 (Fri, 19 Dec 2008) New Revision: 1036 Modified: forth/wrapper/wrapper.c Log: Tweaks to wrapper.c for compilation on ARM. Modified: forth/wrapper/wrapper.c =================================================================== --- forth/wrapper/wrapper.c 2008-12-19 07:55:27 UTC (rev 1035) +++ forth/wrapper/wrapper.c 2008-12-19 19:06:16 UTC (rev 1036) @@ -130,7 +130,7 @@ char *host_os = "freebsd"; #endif -#ifdef HOSTARM +#ifdef __arm__ char *host_cpu = "arm"; #define HOST_LITTLE_ENDIAN #endif @@ -158,7 +158,6 @@ #ifdef ARM char *target_cpu = "arm"; -char *host_cpu = "arm"; #define CPU_MAGIC 0xe1a00000 #define START_OFFSET 8 #endif @@ -937,7 +936,7 @@ #else -# if defined(HOST_LITTLE_ENDIAN) +# if defined(TARGET_POWERPC) && defined(HOST_LITTLE_ENDIAN) lbflips((long *)&header, sizeof(header)); # endif @@ -1549,6 +1548,7 @@ 1200, B1200, 1800, B1800, 2400, B2400, 4800, B4800, 9600, B9600, 19200, B19200, 38400, B38400, 57600, B57600, 115200, B115200, +#ifdef B230400 230400, B230400, #ifdef B4000000 @@ -1558,6 +1558,7 @@ 2500000, B2500000, 3000000, B3000000, 3500000, B3500000, 4000000, B4000000, #endif +#endif -1, -1, };

1 0

r1035 - cpu/x86/pc/olpc
by svn＠openfirmware.info 19 Dec '08

19 Dec '08

Author: wmb Date: 2008-12-19 08:55:27 +0100 (Fri, 19 Dec 2008) New Revision: 1035 Modified: cpu/x86/pc/olpc/fw.bth Log: OLPC trac 9135 - allow re-execution of EMACS without resetting. Modified: cpu/x86/pc/olpc/fw.bth =================================================================== --- cpu/x86/pc/olpc/fw.bth 2008-12-16 19:43:19 UTC (rev 1034) +++ cpu/x86/pc/olpc/fw.bth 2008-12-19 07:55:27 UTC (rev 1035) @@ -333,7 +333,10 @@ fload ${BP}/cpu/x86/pc/olpc/gamekeys.fth fload ${BP}/cpu/x86/pc/olpc/memtest.fth -: emacs ( -- ) boot-getline to boot-file " rom:emacs" $boot ; +: emacs ( -- ) + false to already-go? + boot-getline to boot-file " rom:emacs" $boot +; fload ${BP}/cpu/x86/pc/rmtools.fth fload ${BP}/dev/geode/smi.fth

1 0

r1034 - ofw/fs/ufs
by svn＠openfirmware.info 16 Dec '08

16 Dec '08

Author: wmb Date: 2008-12-16 20:43:19 +0100 (Tue, 16 Dec 2008) New Revision: 1034 Added: ofw/fs/ufs/ufs.fth Log: Added ufs.fth Added: ofw/fs/ufs/ufs.fth =================================================================== --- ofw/fs/ufs/ufs.fth (rev 0) +++ ofw/fs/ufs/ufs.fth 2008-12-16 19:43:19 UTC (rev 1034) @@ -0,0 +1,431 @@ +purpose: UFS file system support package +\ See license at end of file + +0 0 " support" property + +decimal + +\ +\ UFS low-level block routines +\ + +512 constant ublock +2048 constant /super-block +8 constant ndaddr +16 constant super-block# ( -- n ) +h# 11954 constant fs-magic + +0 instance value temp-block +0 instance value dir-block +0 instance value indirect-block +0 instance value inode +0 instance value dir-inode +0 instance value super-block +0 instance value linkpath + +defer short@ ( adr -- w ) ' be-w@ to short@ +defer int@ ( adr -- l ) ' be-l@ to int@ +: le-quad@ ( adr -- l ) int@ ; +: be-quad@ ( adr -- l ) la1+ int@ ; +defer quad@ ( adr -- l ) ' be-quad@ to quad@ + +\ Unfortunately, 4.4BSD-derived systems use a char field for the +\ name length in the directory entry structure, while most other +\ systems use a short. +: 1+c@ ( adr -- n ) 1+ c@ ; +defer namlen@ ( adr -- n ) ' short@ to namlen@ + +: +sb ( index -- value ) super-block swap la+ int@ ; +: iblkno ( -- n ) 4 +sb ; +: cgoffset ( -- n ) 6 +sb ; +: cgmask ( -- n ) 7 +sb ; +: bsize ( -- n ) 12 +sb ; +: fragshift ( -- n ) 24 +sb ; +: fsbtodbc ( -- n ) 25 +sb ; +: inopb ( -- n ) 30 +sb ; +: ipg ( -- n ) 46 +sb ; +: fpg ( -- n ) 47 +sb ; +: inodefmt ( -- n ) 331 +sb ; \ Reserved (=0) in SunOS, =2 in BSD +: magic ( -- n ) 343 +sb ; + +: /frag ( -- fragsize ) bsize fragshift >> ; + +: read-ublocks ( adr len dev-block# -- error? ) + ublock * 0 " seek" $call-parent ?dup if exit then + ( adr len ) tuck " read" $call-parent <> +; + +: get-super-block ( -- error? ) + super-block /super-block super-block# read-ublocks ?dup if exit then + + ['] le-l@ to int@ ['] le-w@ to short@ ['] le-quad@ to quad@ + magic fs-magic = if false exit then + + ['] be-l@ to int@ ['] be-w@ to short@ ['] be-quad@ to quad@ + magic fs-magic <> +; + +: cgstart ( cg -- block# ) + dup cgmask not and cgoffset * swap fpg * + +; +: cgimin ( cg -- block# ) cgstart iblkno + ; + +: blkstofrags ( #blocks -- #frags ) fragshift << ; + +: fsbtodb ( fs-blk# -- dev-blk# ) fsbtodbc << ; + +: read-fs-blocks ( adr len fs-blk# -- error? ) fsbtodb read-ublocks ; + +\ +\ UFS inode routines +\ + +h# 80 constant /inode + +instance variable blkptr +instance variable blklim +instance variable indirptr +0 instance value lblk# + +: itoo ( i# -- offset ) inopb mod ; +: itog ( i# -- group ) ipg / ; +: itod ( i# -- block# ) + dup itog cgimin swap ipg mod inopb / blkstofrags + +; + +: +i ( n -- ) inode + ; +: file-attr ( -- attributes ) 0 +i short@ ; +: dir? ( -- flag ) file-attr h# 4000 and 0<> ; \ **** +: file-sec ( -- seconds ) 24 +i int@ ; +: file-size ( -- n ) 8 +i quad@ ; \ **** +: direct0 ( -- adr ) 40 +i ; +: indirect0 ( -- adr ) 88 +i ; +: #blks-held ( -- n ) 104 +i int@ ; + +: symlink? ( -- symlink? ) 0 +i short@ o# 0120000 tuck and = ; + +\ **** Select the indicated file for subsequent accesses +: rewind ( -- ) + direct0 blkptr ! indirect0 blklim ! indirect0 indirptr ! + 0 to lblk# +; + +: l@++ ( ptr -- value ) dup @ int@ /l rot +! ; + +\ **** Locate the next block within the current file +: next-block# ( -- n ) + blkptr @ blklim @ = if + indirect-block bsize indirptr l@++ + read-fs-blocks drop ( XXX - what about the error? ) + indirect-block blkptr ! indirect-block bsize + blklim ! + then + lblk# 1+ to lblk# + blkptr l@++ ( blk# ) +; + +: get-dirblk ( -- error? ) dir-block bsize next-block# read-fs-blocks ; + +\ +\ UFS directory routines +\ + +variable diroff +variable totoff +variable current-dir + +\ **** Return the address of the current directory entry +: dirent ( -- adr ) dir-block diroff @ + ; + +\ **** Select the next directory entry +: next-dirent ( -- end? ) + dirent la1+ short@ dup diroff +! totoff +! + totoff @ file-size >= if true exit then + diroff @ bsize = if + get-dirblk ?dup if exit then + diroff off + then + false +; + +\ **** From directory, get handle of the file or subdir that it references +\ For Unix, file handle is the inode # +: file-handle ( -- i# ) dirent int@ ; + +\ **** From directory, get name of file +: file-name ( -- adr len ) + dirent la1+ wa1+ dup wa1+ ( len-adr name-adr ) + swap namlen@ h# ff and ( adr len ) +; + +\ +\ UFS high-level routines +\ +\ After this point, the code should be independent of the disk format! + +: lookup ( adr len -- not-found? ) + begin + 2dup file-name $= if 2drop false exit then + next-dirent + until + 2drop true +; + +: >OFW-path ( adr len -- ) + \ replace / with \ + bounds do i c@ ascii / = if ascii \ i c! then loop +; +: (select-file) ( i# -- error? ) + dup temp-block bsize rot itod ( i# adr len fs-block# ) + read-fs-blocks if drop true exit then ( i# ) + itoo /inode * temp-block + inode /inode move + false +; +defer chdir ' noop is chdir +defer (init-dir) ' noop is (init-dir) +: select-file ( i# -- error? ) + (select-file) ?dup if exit then + symlink? if + #blks-held 0= if \ short symbolic link path + direct0 linkpath over cstrlen 1+ move + else \ long symbolic link path + linkpath bsize direct0 @ + read-fs-blocks ?dup if exit then + then + linkpath dup cstrlen 2dup >OFW-path ascii \ split-after + ?dup if + chdir if 2drop true exit then + else + drop current-dir @ (init-dir) ?dup if exit then + then + dup 0= if 2drop false exit then + lookup ?dup if exit then + file-handle recurse + else + rewind false + then +; + +\ **** Select the directory file +: init-dir ( i# -- error? ) + dup current-dir ! + select-file ?dup if exit then + get-dirblk ?dup if exit then + 0 diroff ! 0 totoff ! + false +; +' init-dir to (init-dir) + +\ **** Select the root directory +: froot ( -- error? ) 2 init-dir ; + +: $chdir ( adr len -- error? ) \ Fail if path is file, not dir + ?dup 0= if drop true exit then + froot if 2drop true exit then + begin ( path-$ ) + over c@ ascii \ = if 1 /string then + ascii \ split-before ( \tail-$ head-$ ) + dup while + lookup if 2drop true exit then + dir? 0= if 2drop true exit then + file-handle init-dir if 2drop true exit then + repeat ( tail-$ head-$ ) + 2drop 2drop false +; +' $chdir to chdir + +\ +\ UFS installation routines +\ + + +\ **** Allocate memory for necessary data structures +: allocate-ufs-buffers ( -- error? ) + /super-block alloc-mem is super-block + get-super-block dup if + super-block /super-block free-mem exit + then + inodefmt 2 = if ['] 1+c@ else ['] short@ then to namlen@ + bsize alloc-mem is temp-block + bsize alloc-mem is dir-block + bsize alloc-mem is indirect-block + bsize alloc-mem is linkpath + /inode alloc-mem is inode + /inode alloc-mem is dir-inode +; + +: release ( -- ) + inode /inode free-mem + dir-inode /inode free-mem + indirect-block bsize free-mem + temp-block bsize free-mem + dir-block bsize free-mem + linkpath bsize free-mem + super-block /super-block free-mem +; + +false instance value file-open? +/fd instance buffer: ufs-fd + +\ UFS DIR routines +\ date&time is number of seconds since 1970 +create days/month +\ Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec + 31 c, 28 c, 31 c, 30 c, 31 c, 30 c, 31 c, 31 c, 30 c, 31 c, 30 c, 31 c, + +: >d/m ( day-in-year -- day month ) + 12 0 do + days/month i ca+ c@ 2dup < if + drop 1+ i 1+ leave + then + - + loop +; +: sec>time&date ( seconds -- s m h d m y ) + 60 u/mod 60 u/mod 24 u/mod ( s m h days ) + [ 365 4 * 1+ ] literal /mod >r ( s m h day-in-cycle ) ( r: cycles ) + dup [ 365 365 + 31 + 29 + ] literal + 2dup = if \ exactly leap year Feb 29 + 3drop 2 29 2 ( s m h year-in-cycle d m ) + else + > if 1- then \ after leap year + 365 u/mod ( s m h day-in-year year-in-cycle ) + swap >d/m ( s m h year-in-cycle d m ) + then + rot r> 4 * + 1970 + ( s m h d m y ) +; +: >dir-inode ( -- ) inode dir-inode /inode move ; +: dir-inode> ( -- ) dir-inode inode /inode move ; +: file-info ( id -- false | id' s m h d m y len attributes name$ true ) + file-handle >dir-inode (select-file) if ( id ) + drop false ( false ) + else ( id ) + 1+ file-sec sec>time&date file-size file-attr file-name ( id' .. ) + true ( id' .. name$ true ) + then + dir-inode> +; +: next-file-info ( id -- false | id' s m h d m y len attributes name$ true ) + dup if + next-dirent if drop false else file-info then + else + file-info + then +; + +\ UFS file interface + +: ufsdflen ( 'fhandle -- d.size ) drop file-size 0 ; + +: ufsdfalign ( d.byte# 'fh -- d.aligned ) + drop swap bsize 1- invert and swap +; + +: ufsfclose ( 'fh -- ) + drop bfbase @ bsize free-mem \ Registered with initbuf +; + +: ufsdfseek ( d.byte# 'fh -- ) + drop + bsize um/mod nip ( target-blk# ) + dup lblk# < if rewind then + begin dup lblk# <> while next-block# drop repeat + drop +; + +: ufsfread ( addr count 'fh -- #read ) + drop + file-size lblk# bsize * - ( addr count rem ) + over min -rot ( actual addr count ) + next-block# read-fs-blocks + abort" ufsfread failed" +; + +: $ufsopen ( adr len mode -- fid fmode size align close seek write read ) + >r lookup ( error? ) if + false + else + file-handle select-file if + false + else + bsize alloc-mem bsize initbuf + file-handle r@ + ['] ufsdflen ['] ufsdfalign ['] ufsfclose ['] ufsdfseek ['] nullwrite + r@ write = if ['] nullread else ['] ufsfread then + true + then + then + r> drop +; + +external + +: open ( -- okay? ) + allocate-ufs-buffers if false exit then + + my-args " <NoFile>" $= if true exit then + + my-args ascii \ split-after ( file$ path$ ) + $chdir if 2drop release false exit then ( file$ ) + + \ Filename ends in "\"; select the directory and exit with success + dup 0= if 2drop true exit then ( file$ ) + + file @ >r ufs-fd file ! ( file$ ) + + 2dup r/w $ufsopen 0= if + 2dup r/o $ufsopen 0= if + release 2drop false r> file ! exit + then + then ( file$ file-ops ... ) + + setupfd + 2drop + true to file-open? + true + r> file ! +; + +: close ( -- ) + file-open? if + ufs-fd ['] fclose catch ?dup if .error drop then + then + release +; +: read ( adr len -- actual ) + ufs-fd ['] fgets catch if 3drop 0 then +; +: write ( adr len -- actual ) + tuck ufs-fd ['] fputs catch if 2drop 2drop -1 then +; +: seek ( offset.low offset.high -- error? ) + ufs-fd ['] dfseek catch if 2drop true else false then +; +: size ( -- d ) file-size 0 ; +: load ( adr -- size ) file-size read ; +: files ( -- ) begin file-name type cr next-dirent until ; + +hex + +\ 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

1 0

r1033 - cpu/x86/pc/olpc ofw/wifi
by svn＠openfirmware.info 14 Dec '08

14 Dec '08

Author: wmb Date: 2008-12-14 18:43:28 +0100 (Sun, 14 Dec 2008) New Revision: 1033 Modified: cpu/x86/pc/olpc/nandcastui.fth cpu/x86/pc/olpc/versions.fth cpu/x86/pc/olpc/wifichannel.fth ofw/wifi/eapol.fth Log: OLPC - Improved NANDblaster WIFI spectrum analysis, with ".wifi" command. Modified: cpu/x86/pc/olpc/nandcastui.fth =================================================================== --- cpu/x86/pc/olpc/nandcastui.fth 2008-12-12 00:13:49 UTC (rev 1032) +++ cpu/x86/pc/olpc/nandcastui.fth 2008-12-14 17:43:28 UTC (rev 1033) @@ -101,3 +101,27 @@ false to already-go? " boot rom:nb_rx 10.20.0.16,,10.20.0.44" eval ; + +\ 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: cpu/x86/pc/olpc/versions.fth =================================================================== --- cpu/x86/pc/olpc/versions.fth 2008-12-12 00:13:49 UTC (rev 1032) +++ cpu/x86/pc/olpc/versions.fth 2008-12-14 17:43:28 UTC (rev 1033) @@ -2,7 +2,7 @@ \ The overall firmware revision macro: FW_MAJOR E -macro: FW_MINOR 24 +macro: FW_MINOR 24b \ The EC microcode macro: EC_VERSION e21 Modified: cpu/x86/pc/olpc/wifichannel.fth =================================================================== --- cpu/x86/pc/olpc/wifichannel.fth 2008-12-12 00:13:49 UTC (rev 1032) +++ cpu/x86/pc/olpc/wifichannel.fth 2008-12-14 17:43:28 UTC (rev 1033) @@ -1,13 +1,22 @@ +purpose: Analyze WIFI spectrum to find good channels for NANDblaster +\ See license at end of file - 0 value wlan-ih d# 2048 buffer: scan-buf +: $call-wlan ( args method$ -- res ) wlan-ih $call-method ; +: stop-mesh ( -- ) " mesh-stop" $call-wlan drop ; +: start-mesh ( channel# -- ) + " mesh-start" $call-wlan drop + d# 100 0 " set-beacon" $call-wlan +; + : open-wlan ( -- ) " /wlan:force" open-dev to wlan-ih wlan-ih 0= abort" Can't open wireless LAN" - " " " set-ssid" wlan-ih $call-method + " " " set-ssid" $call-wlan ; +: close-wlan ( -- ) wlan-ih ?dup if close-dev 0 to wlan-ih then ; : analyze-beacons ( -- total-rssi max-rssi #beacons ) 0 0 ( tot-rssi max-rssi ) @@ -39,18 +48,64 @@ drop r> ( tot-rssi max-rssi #beacons ) ; +0 value this-rssi +0 0 2value this-ssid +0 value this-channel +: brief-.ap ( adr -- adr' ) + dup 8 + c@ to this-rssi ( adr ) + dup le-w@ ( adr len ) + swap 2 + swap d# 19 /string ( adr' len' ) + begin dup 0> while ( adr len ) + over c@ case ( adr len ) + 0 of over 2+ dup 1- c@ to this-ssid endof + 3 of over 2+ c@ to this-channel endof + endcase ( adr len ) + over 1+ c@ 2 + /string ( adr' len' ) + repeat drop ( adr ) + + push-decimal + ." Channel: " this-channel 2 u.r ( adr ) + ." Strength: " this-rssi 2 u.r ( adr ) + pop-base + ." SSID: " this-ssid type ( adr ) + cr ( adr ) +; + +0 value this-#beacons + +d# 14 constant max-channel# +max-channel# 1+ array >#beacons +max-channel# 1+ array >channel-speed + +1 1 lshift 1 6 lshift or 1 d# 11 lshift or constant def-channel-mask + +: channel-bounds ( -- limit start ) max-channel# 1+ 1 ; + +: channel-avail? ( channel# -- flag ) 1 swap lshift def-channel-mask and ; + +: show-beacons ( -- #beacons ) + \ The first AP structure begins at offset 3 within the scan result + scan-buf 3 + ( 'ap ) + scan-buf 2 + c@ dup >r ( 'ap #beacons ) + 0 ?do ( 'ap ) \ Byte 2 is number of beacons + brief-.ap ( 'ap' ) + loop ( 'ap ) + drop r> ( #beacons ) +; + +: scan-channel ( channel# -- actual ) + 1 swap lshift " set-channel-mask" $call-wlan + scan-buf d# 2048 " scan" $call-wlan ( actual ) +; + : channel-stats ( channel# -- total-rssi max-rssi #beacons ) - 1 swap lshift " set-channel-mask" wlan-ih $call-method - scan-buf d# 2048 " scan" wlan-ih $call-method ( actual ) - if + scan-channel if analyze-beacons else 0 0 0 then ; -d# 15 constant rssi-limit - \ Keep the rssi,chan pair with the lowest max-rssi value : lowest-rssi ( max-rssiN chanN max-rssiM chanM -- max-rssiP P ) 3 pick 2 pick ( max-rssiN chanN max-rssiM chanM max-rssiN max-rssiM ) @@ -67,46 +122,59 @@ then ( max-rssiN' N' no-beacons? ) ; -: scan-mesh-channels ( -- max-rssi chan# ) - h# ffffffff 0 ( max-rssi0 0 ) \ This high rssi always loses - d# 11 try-channel if exit then ( max-rssiN chanN ) - d# 6 try-channel if exit then ( max-rssiN chanN ) - d# 1 try-channel drop ( max-rssi chan# ) -; - : quietest-mesh-channel ( -- max-rssi chan# ) open-wlan - scan-mesh-channels - wlan-ih close-dev + h# ffffffff 0 \ High RSSI for starters ( max-rssi0 0 ) + channel-bounds do ( max-rssiN chanN ) + i channel-avail? if ( max-rssiN chanN ) + i try-channel ?leave ( max-rssiN chanN ) + then + loop + close-wlan ; +d# 10 constant rssi-threshold +: quietest-auto-channel ( -- chan# ) + quietest-mesh-channel ( rssi chan# ) + swap rssi-threshold > if ( chan# ) + ." No wireless channels are quiet. The quietest is channel " dup .d cr ( chan# ) + " Do you want to use that channel" confirmedn? ( chan# proceed? ) + 0= abort" Stopping." + then ( chan# ) +; + : multinand-traffic? ( channel# -- flag ) - " mesh-start" wlan-ih $call-method drop - d# 100 0 " set-beacon" wlan-ih $call-method - " "(01 00 5e 7e 01 02)" " set-multicast" wlan-ih $call-method + start-mesh + " "(01 00 5e 7e 01 02)" " set-multicast" $call-wlan d# 300 0 do - scan-buf d# 2048 " read" wlan-ih $call-method ( actual ) + scan-buf d# 2048 " read" $call-wlan ( actual ) 0> if ( ) scan-buf d# 12 + " XO" comp 0= if ( ) - " mesh-stop" wlan-ih $call-method drop ( ) + stop-mesh ( ) true unloop exit then then 1 ms loop - " mesh-stop" wlan-ih $call-method drop + stop-mesh false ; + : search-channels ( -- true | chan# false ) - d# 11 multinand-traffic? if d# 11 false exit then - d# 6 multinand-traffic? if d# 6 false exit then - d# 1 multinand-traffic? if d# 1 false exit then + channel-bounds do ( ) + i channel-avail? if ( ) + i multinand-traffic? if ( ) + i unloop false exit + then ( ) + then ( ) + loop ( ) true ; + : find-multinand-server ( -- true | chan# false ) open-wlan search-channels - wlan-ih close-dev + close-wlan ; : nandblaster ( -- ) find-multinand-server abort" No multicast NAND server" ( chan# ) @@ -114,16 +182,146 @@ ; alias nb nandblaster -d# 10 constant rssi-threshold +d# 1514 buffer: mesh-test-buf + +: (channel-speed) ( channel# -- kb/sec ) + dup >r start-mesh + " enable-multicast" $call-wlan + 1 " mesh-set-ttl" $call-wlan + h# b " mesh-set-bcast" $call-wlan + + " "(00 00 00 00 00 00 01 00 5e 7e 01 01)XO" mesh-test-buf swap move + + tsc@ + d# 1000 0 do + mesh-test-buf d# 1514 " write" $call-wlan drop + loop + tsc@ 2swap d- ms-factor um/mod nip ( ms ) + d# 1,514,000 swap / ( kb/sec ) + stop-mesh ( kb/sec ) + dup r> >channel-speed ! ( kb/sec ) +; +: channel-speed ( channel# -- kb/sec ) + open-wlan (channel-speed) close-wlan +; + +: ?faster ( chan# kb/sec this-chan# -- chan#' kb/sec ) + dup (channel-speed) ( chan# kb/sec this-chan# this-kb/sec ) + 2 pick over u< if 2swap then ( chan# kb/sec this-chan# this-kb/sec ) + 2drop +; + +: (.channel-speed) ( channel# -- ) + push-decimal + ." Channel: " dup 2 u.r ." " + (channel-speed) + <# u# u# u# [char] . hold u# u#> type ." Mbytes/sec" cr + pop-base +; + +: .wifi-speeds ( -- ) + open-wlan + channel-bounds do + i channel-avail? if + i (.channel-speed) + then + loop + close-wlan +; + +: (.channel-beacons) ( channel# -- ) + dup >r ( r: channel# ) + scan-channel if ( r: channel# ) + show-beacons ( #beacons r: channel# ) + else ( r: channel# ) + 0 ( #beacons r: channel# ) + then ( #beacons r: channel# ) + r> >#beacons ! ( ) +; + +: .wifi-beacons ( -- ) + open-wlan + channel-bounds do + i channel-avail? if + i (.channel-beacons) + then + loop + close-wlan +; + +: .wifi ( -- ) + ." Beacons: " cr + .wifi-beacons + cr + ." Max transmit speeds: (congestion dependent)" cr + .wifi-speeds +; + +d# 2000 constant wifi-speed-threshold +: quiet&fast? ( channel# -- flag ) + dup >#beacons @ if drop false exit then ( channel# ) + >channel-speed @ wifi-speed-threshold > +; + +: quiet-channel-mask ( -- mask ) + 0 ( mask ) + channel-bounds do ( mask ) + i channel-avail? if ( mask ) + i >#beacons @ 0= if ( mask ) + 1 i lshift or ( mask' ) + then ( mask ) + then ( mask ) + loop ( mask ) +; + +: fastest-of ( mask -- chan# ) + 0 0 + channel-bounds do ( mask chan# speed ) + 2 pick 1 i lshift and if ( mask chan# speed ) + dup i >channel-speed @ < if ( mask chan# speed ) + 2drop i i >channel-speed @ ( mask chan#' speed' ) + then ( mask chan# speed ) + then ( mask chan# speed ) + loop ( mask chan# speed ) + rot 2drop +; + : nb-auto-channel ( -- chan# ) - quietest-mesh-channel ( rssi chan# ) - swap rssi-threshold > if ( chan# ) - ." No wireless channels are quiet. The quietest is channel " dup .d cr ( chan# ) - " Do you want to use that channel" confirmedn? ( chan# proceed? ) - 0= abort" Stopping." - then ( chan# ) + ." Analyzing WIFI spectrum" cr + cr + .wifi + + quiet-channel-mask ?dup 0= if def-channel-mask then + fastest-of + cr + ." Using channel " dup .d cr + d# 4000 ms ; : nb-clone ( -- ) nb-auto-channel #nb-clone ; : nb-secure ( -- ) nb-auto-channel #nb-secure-def ; : nb-update ( -- ) nb-auto-channel #nb-update-def ; + +\ 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: ofw/wifi/eapol.fth =================================================================== --- ofw/wifi/eapol.fth 2008-12-12 00:13:49 UTC (rev 1032) +++ ofw/wifi/eapol.fth 2008-12-14 17:43:28 UTC (rev 1033) @@ -500,7 +500,7 @@ : .ap ( adr -- ) ." Address: " dup 2 + .enaddr cr - ." RSSI: " dup 8 + c@ u. cr + ." RSSI: " dup 8 + c@ .d cr ." Beacon interval: " dup d# 17 + le-w@ .d cr ." Capabilities: " dup d# 19 + le-w@ cr .cap dup le-w@ swap 2 + swap d# 19 /string ( adr' len' )

1 0

r1032 - cpu/x86/pc/olpc
by svn＠openfirmware.info 12 Dec '08

12 Dec '08

Author: wmb Date: 2008-12-12 01:13:49 +0100 (Fri, 12 Dec 2008) New Revision: 1032 Modified: cpu/x86/pc/olpc/versions.fth Log: OLPC - explicit git commit ID for NANDblaster, also fix Divide Error in NANDblaster status reports. Modified: cpu/x86/pc/olpc/versions.fth =================================================================== --- cpu/x86/pc/olpc/versions.fth 2008-12-11 22:49:49 UTC (rev 1031) +++ cpu/x86/pc/olpc/versions.fth 2008-12-12 00:13:49 UTC (rev 1032) @@ -26,6 +26,6 @@ \ With a specific ID, mcastnand.bth will download a tarball without .git stuff. \ With "test", mcastnand.bth will clone the git head if build/multicast-nand/ \ is not already present, then you can modify the git subtree as needed. -\ macro: MCNAND_VERSION 5f202b05147826ad69fcb849b92290681a56c70c +macro: MCNAND_VERSION 0c73b4a084a27f0687b152dd0395c67fdf54b10f \ macro: MCNAND_VERSION test -macro: MCNAND_VERSION HEAD +\ macro: MCNAND_VERSION HEAD

1 0

r1031 - cpu/x86/pc/olpc
by svn＠openfirmware.info 11 Dec '08

11 Dec '08

Author: wmb Date: 2008-12-11 23:49:49 +0100 (Thu, 11 Dec 2008) New Revision: 1031 Modified: cpu/x86/pc/olpc/versions.fth Log: Q2E24 Modified: cpu/x86/pc/olpc/versions.fth =================================================================== --- cpu/x86/pc/olpc/versions.fth 2008-12-11 22:46:49 UTC (rev 1030) +++ cpu/x86/pc/olpc/versions.fth 2008-12-11 22:49:49 UTC (rev 1031) @@ -2,7 +2,7 @@ \ The overall firmware revision macro: FW_MAJOR E -macro: FW_MINOR 23 +macro: FW_MINOR 24 \ The EC microcode macro: EC_VERSION e21

1 0

r1030 - cpu/x86/pc/olpc
by svn＠openfirmware.info 11 Dec '08

11 Dec '08

Author: wmb Date: 2008-12-11 23:46:49 +0100 (Thu, 11 Dec 2008) New Revision: 1030 Modified: cpu/x86/pc/olpc/nandcastui.fth cpu/x86/pc/olpc/wifichannel.fth Log: OLPC NANDblaster - fixed some UI problems found in early testing. Modified: cpu/x86/pc/olpc/nandcastui.fth =================================================================== --- cpu/x86/pc/olpc/nandcastui.fth 2008-12-11 20:00:00 UTC (rev 1029) +++ cpu/x86/pc/olpc/nandcastui.fth 2008-12-11 22:46:49 UTC (rev 1030) @@ -62,20 +62,23 @@ " rom:nb_tx ether:%d %s %d 131072 %d %d %d %d" sprintf boot-load go ; -: nb-clone1 ( -- ) 1 #nb-clone ; -: nb-clone6 ( -- ) 6 #nb-clone ; +: #nb-update-def ( channel# -- ) >r " u:\fs.plc" " u:\fs.img" r> #nb-update ; +: #nb-secure-def ( channel# -- ) >r " u:\fs.zip" " u:\fs.img" r> #nb-secure ; + +: nb-clone1 ( -- ) 1 #nb-clone ; +: nb-clone6 ( -- ) 6 #nb-clone ; : nb-clone11 ( -- ) d# 11 #nb-clone ; -: nb-update1 ( -- ) 1 #nb-update ; -: nb-update6 ( -- ) 6 #nb-update ; -: nb-update11 ( -- ) d# 11 #nb-update ; +: nb-update1 ( -- ) 1 #nb-update-def ; +: nb-update6 ( -- ) 6 #nb-update-def ; +: nb-update11 ( -- ) d# 11 #nb-update-def ; -: nb-secure1 ( -- ) 1 #nb-secure ; -: nb-secure6 ( -- ) 6 #nb-secure ; -: nb-secure11 ( -- ) d# 11 #nb-secure ; +: nb-secure1 ( -- ) 1 #nb-secure-def ; +: nb-secure6 ( -- ) 6 #nb-secure-def ; +: nb-secure11 ( -- ) d# 11 #nb-secure-def ; -: nb1 ( -- ) 1 #nb ; -: nb6 ( -- ) 6 #nb ; +: nb1 ( -- ) 1 #nb ; +: nb6 ( -- ) 6 #nb ; : nb11 ( -- ) d# 11 #nb ; : mesh-clone Modified: cpu/x86/pc/olpc/wifichannel.fth =================================================================== --- cpu/x86/pc/olpc/wifichannel.fth 2008-12-11 20:00:00 UTC (rev 1029) +++ cpu/x86/pc/olpc/wifichannel.fth 2008-12-11 22:46:49 UTC (rev 1030) @@ -116,11 +116,14 @@ d# 10 constant rssi-threshold : nb-auto-channel ( -- chan# ) - quietest-mesh-channel ( rssi chan# ) - swap rssi-threshold > abort" No quiet channels" ( chan# ) + quietest-mesh-channel ( rssi chan# ) + swap rssi-threshold > if ( chan# ) + ." No wireless channels are quiet. The quietest is channel " dup .d cr ( chan# ) + " Do you want to use that channel" confirmedn? ( chan# proceed? ) + 0= abort" Stopping." + then ( chan# ) ; -: nb-clone ( -- ) nb-auto-channel #nb-clone ; - -: nb-update " u:\fs.plc" " u:\fs.img" nb-auto-channel #nb-update ; -: nb-secure " u:\fs.zip" " u:\fs.img" nb-auto-channel #nb-secure ; +: nb-clone ( -- ) nb-auto-channel #nb-clone ; +: nb-secure ( -- ) nb-auto-channel #nb-secure-def ; +: nb-update ( -- ) nb-auto-channel #nb-update-def ;

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

openfirmware