home *** CD-ROM | disk | FTP | other *** search
/ Dream 52 / Amiga_Dream_52.iso / RiscOS / APP / DEVS / FORTH / WIMPFO.ZIP / !WimpForth / pasm < prev    next >
Text File  |  1996-03-21  |  16KB  |  597 lines
  1. \ ARM-Assembler
  2.  
  3. cr .( Loading the ARM Assembler...)
  4.  
  5. \ for usage see end of this file and the file fkernel
  6.  
  7. 8 #vocabulary assembler
  8.  
  9. defer setassem
  10.  
  11. only forth also assembler definitions also
  12.  
  13. variable <CC>         variable <P>          variable <T>
  14. variable <SH>         variable <^>          variable <#>
  15. variable <S>          variable <[>          variable <],>
  16. variable <!>          variable <X>
  17. variable <OIS>        variable <typ>        variable <#REGS>
  18. create <REGS> 18 allot
  19. variable <DOIT1>      variable <DOIT2>
  20. variable <ADOPCODE1>  variable <ADOPCODE2>
  21.  
  22. ' drop <DOIT1> !  ' drop <DOIT2> !
  23.  
  24. : <a;>
  25.     <ADOPCODE1> @  <DOIT1> @ execute
  26.     <ADOPCODE2> @  <ADOPCODE1> !
  27.     <DOIT2> @      <DOIT1> !
  28.     ['] drop <DOIT2> ! ;
  29.  
  30. : <a;!>  ( a1 a2 -- )
  31.     <DOIT2> !
  32.     <ADOPCODE2> ! ;
  33.  
  34. : reset
  35.     <#REGS> off  <CC> off  <SH> off  <#> off  <],> off
  36.     <REGS> 12 erase
  37.     <S> off  <T> off  <P> off <[> off  <!> off  <X> off
  38.     <^> off  <OIS> off  <typ> off ;
  39.  
  40. variable postvar                        \ is this post fix notation?
  41.  
  42. forth definitions
  43.  
  44. defer a;!       ' <a;!>    is a;!
  45. defer a;        ' <a;>     is a;
  46.  
  47. : prefix        ( --- )
  48.                 ['] <a;!>    is a;!
  49.                 ['] <a;>     is a;
  50.                 postvar off ;
  51. : postfix       ( --- )
  52.                 ['] execute  is a;!
  53.                 ['] noop     is a;
  54.                 postvar on ;
  55.  
  56. prefix          \ default is prefix assembler.
  57.  
  58. : >pre          2r> postvar @ >r 2>r prefix ;    \ save and set prefix
  59. : pre>          2r> r> if postfix then 2>r ;     \ restore previous fix
  60.  
  61. assembler definitions
  62.  
  63. defer c,        forth ' c,      assembler is c,
  64. defer ,         forth ' ,       assembler is ,
  65. defer here      forth ' here    assembler is here
  66. defer t,        forth ' ,       assembler is t,
  67. defer t@        forth ' @       assembler is t@
  68. defer t!        forth ' !       assembler is t!
  69.  
  70. defer ?>mark            defer ?>resolve
  71. defer ?<mark            defer ?<resolve
  72.  
  73. : br>ad  ( here op -- ad )  
  74.     8 lshift dup 0< if 6 rshift &fc000000 or else 6 rshift then + 8 + ;
  75.  
  76. : ad>of  ( to from -- of )
  77.     8 + - 2 rshift &ffffff and ;
  78.  
  79. &c0 value max-llabs
  80.  12 value b/llab
  81. false value ll-global?     \ are local labels available globally?
  82.  
  83. create %llab[] max-llabs b/llab * allot
  84.  
  85. %llab[] value llab[]            \ default to %llab[] array
  86.  
  87. false value ll-used?
  88.  
  89. : llab-init  ( -- )     \ initializes local labels
  90.   llab[]  max-llabs b/llab * erase
  91.   false is ll-used? ;
  92.  
  93. : llab>line  ( n -- ^line )
  94.   dup max-llabs 1- u> abort" Bad Label"
  95.   b/llab * llab[] + ;
  96.  
  97. : $  ( n1 -- n2 )
  98.   true is ll-used?          \ set "labels used?" flag
  99.   llab>line 1 over 8 + c!   \ set "ever referenced?" flag
  100.   dup @ IF      \ if the label is already defined:
  101.     @           \   then return it for resolution
  102.   ELSE          \ otherwise:
  103.     cell+       \   move to head of list pointer
  104.     dup @ >r    \   save old head of list on rstack
  105.     here swap ! \   set new head of list
  106.     r>          \   retrieve old head of list
  107.     dup 0= IF   \   if list is empty:
  108.       here +    \     pass current dictionary location
  109.     THEN        \   end-if
  110.   THEN ;        \ end-if
  111.  
  112. : >res  ( ^line -- )
  113.   cell+ @ dup 0= IF \ if nothing to resolve
  114.     drop exit       \   then exit
  115.   THEN
  116.   BEGIN             \ stack contains directory address of 
  117.                     \   displacement to be resolved
  118.     dup t@ >r 
  119.     here over ad>of
  120.     r@ &ff000000 and or
  121.     over t!
  122.     r> &ff000000 or dup -2 <>
  123.   WHILE
  124.     br>ad
  125.   REPEAT 2drop ;
  126.  
  127. : $:f  ( n -- )     \ defines a local label
  128.   true to ll-used?  \ set "labels used?" flag
  129.   llab>line
  130.   dup @ 0<> abort" Label can't be multiply defined"
  131.   dup >res          \ resolve forward references if needed
  132.   here swap ! ;     \ and set label for subsequent refs
  133.  
  134. : $:  ( n -- )      \ allow use as prefix/postfix
  135.   ['] $:f a;! a; ;
  136.  
  137. : _ll-errs?  ( -- )  \ final error checking for local labels
  138.   false max-llabs 0 DO  \ check each label
  139.     i b/llab * llab[] +
  140.     dup 8 + c@ 0<> IF   \ if jumps to label
  141.       @ 0= IF           \   and no label to jump to
  142.         cr ." jump(s) to label " i .
  143.           ." and label not defined"
  144.         drop true       \ set error flag
  145.       THEN
  146.     ELSE                \ if no jumps to label
  147.       @ 0<> IF          \   and label defined
  148.         cr ." warning - label " i .
  149.            ." defined, but no jumps to it"
  150.       THEN
  151.     THEN
  152.   LOOP
  153.   IF abort THEN ;       \ abort if fatal error
  154.  
  155. : ll-errs?  ( -- )      \ final error checking for local labels
  156.   ll-used? IF _ll-errs? THEN ;
  157.  
  158. : L$            ( --- a1 )              \ Pass a1 to L$:
  159.                 0 A; HERE ;
  160.  
  161. : L$:           ( a1 --- )              \ a1 = addr passed by L$
  162.                 A; HERE OVER 8 + - over t@ &ff000000 and or swap T! ;
  163.  
  164. FORTH DEFINITIONS
  165.  
  166. : DOASSEM       ( --- ) 
  167.                 0 ['] DROP A;!
  168.                 <ADOPCODE2> @ <ADOPCODE1> !
  169.                 <DOIT2> @ <DOIT1> !
  170.                 reset
  171.                 ll-global? 0=
  172.                 if      llab-init               \ in case labels used
  173.                 then
  174.                 ALSO assembler ;
  175.  
  176. ' DOASSEM IS SETASSEM
  177.  
  178. synonym CLEAR_LABELS LLAB-INIT
  179.  
  180. : LOCAL_REF     ( --- )
  181.                 0 is LL-GLOBAL? ;       LOCAL_REF
  182.                                         \ default to LOCAL references only
  183.  
  184. : GLOBAL_REF    ( --- )
  185.                 -1 is LL-GLOBAL? ;
  186.  
  187. : LABEL         ( NAME --- )            \ Really just a constant addr
  188.                 SETASSEM CREATE ; 
  189.  
  190. : CODE          ( NAME --- )
  191.                 LABEL -4 DP +! HIDE ;
  192.  
  193. assembler DEFINITIONS
  194.  
  195. : END-CODE
  196.                 ll-global? 0=
  197.                 if      ll-errs?        \ check for local label errors
  198.                 then
  199.                 PREVIOUS A; REVEAL ;
  200.  
  201. synonym C; END-CODE
  202.  
  203. : Rn &10 or <#REGS> @ <REGS> + c! 1 <#REGS> +! ;
  204. : reg
  205.     create c,
  206.     does> c@ Rn ;
  207.  
  208.  0 reg R0             1 reg R1          2 reg R2          3 reg R3
  209.  4 reg R4             5 reg R5          6 reg R6          7 reg R7
  210.  8 reg R8             9 reg R9         10 reg R10        11 reg R11
  211. 12 reg R12           13 reg R13        14 reg R14        15 reg R15
  212. synonym R0,  R0     synonym R1,  R1    synonym R2,  R2   synonym R3,   R3  
  213. synonym R4,  R4     synonym R5,  R5    synonym R6,  R6   synonym R7,   R7  
  214. synonym R8,  R8     synonym R9,  R9    synonym R10, R10  synonym R11,  R11 
  215. synonym R12, R12    synonym R13, R13   synonym R14, R14  synonym R15,  R15 
  216. synonym PC   R15    synonym PC,  R15   synonym LINK R14  synonym LINK, R14 
  217. synonym SP   R13    synonym SP,  R13   synonym RP   R12  synonym RP,   R12 
  218. synonym IP   R11    synonym IP,  R11   synonym TOS  R10  synonym TOS,  R10 
  219. synonym OP   R9     synonym OP,  R9  
  220. synonym Rn,  Rn
  221.  
  222. : ccode
  223.     create ,
  224.     does> @ <CC> ! ;
  225.  
  226.         1 ccode EQ &10000000 ccode NE &20000000 ccode CS &30000000 ccode CC
  227. &40000000 ccode MI &50000000 ccode PL &60000000 ccode VS &70000000 ccode VC
  228. &80000000 ccode HI &90000000 ccode LS &a0000000 ccode GE &b0000000 ccode LT
  229. &c0000000 ccode GT &d0000000 ccode LE &e0000000 ccode AL &f0000000 ccode NV
  230.  
  231. : scode
  232.     create ,
  233.     does> @ <SH> ! ;
  234.  
  235.  &01 scode ASL     &41 scode ASR     &21 scode LSR     &61 scode ROR
  236. &160 scode RRX   synonym LSL ASL
  237.  
  238. synonym o[ [    synonym o] ]
  239. : S &100000 <S> ! ;
  240. : P   &f000 <P> ! ;
  241. : T &200000 <T> ! ;
  242. : X  &20000 <X> ! ;
  243. : ^ &400000 <^> ! ;
  244. : [ <[> on ;
  245. : ], <#> @ 0= <#REGS> @ 2 = and if <],> on then ;
  246. : ] noop ; immediate
  247. : !, &200000 <!> ! ;
  248. synonym ]! !,
  249. : # <#> on ;
  250. : { noop ; immediate
  251. : } noop ; immediate
  252.  
  253. : <assabort> ." Assembler-Fehler " . abort ;
  254. \ 0=immediate or register expected
  255. \ 1=falscher Shift
  256. \ 2=register expected
  257. \ 3=immediate shifted
  258. \ 4=bad immediate
  259. \ 5=do not multiply to PC
  260. \ 6=Registerfehler bei MUL
  261. : assabort ( f code -- ) \ flag=0, dann Abbruch
  262.     swap 0= if <assabort> then drop ;
  263.  
  264. : align begin here 3 and while 0 c, repeat ;
  265.  
  266. : lastreg ( -- reg )
  267.     -1 <#REGS> +!
  268.     <#REGS> @  dup 0>= 2 assabort
  269.     <REGS> + c@ &f and ;
  270.  
  271. : shift> ( opcode -- opcode' )
  272.     <SH> @ ?dup
  273.     if dup &160 <>
  274.       if &f0 and or
  275.         <#> @
  276.         if swap dup 0> over 33 < and 1 assabort
  277.           &1f and 7 lshift or 
  278.         else <OIS> @ 0= 1 assabort
  279.           lastreg 4 lshift 1+ 4 lshift or
  280.         then
  281.       else &ff and or
  282.       then
  283.     then ;
  284.  
  285. : cc> ( opcode -- opcode')
  286.     <CC> @ ?dup
  287.     if >r &0fffffff and r> &f0000000 and or
  288.     then ;
  289.  
  290. : rel#> ( opcode d -- opcode' )
  291.     dup 0<
  292.     if negate swap &ff7fffff and swap then
  293.     dup 4096 < 4 assabort
  294.     or ;
  295.  
  296. : rotl
  297.    0 do dup 31 rshift swap 1 lshift or loop ; 
  298.  
  299. : valid? ( imm -- imm' )
  300.    false swap 16 0 
  301.    do dup &ffffff00 and 0= 
  302.      if nip i true rot leave 
  303.      then  2 rotl 
  304.    loop swap 4 assabort
  305.    &20000 rot or 8 lshift or ; 
  306.  
  307. create adop
  308.   &e3a00000 , &e3800000 , \ mov rh, # x     \ orr rd, rh, # x
  309.   &e3e00000 , &e3c00000 , \ mvn rh, # x     \ bic rd, rh, # x
  310.   &e28f0000 , &e2800000 , \ add rh, pc, # x \ add rd, rh, # x
  311.   &e24f0000 , &e2400000 , \ sub rh, pc, # x \ sub rd, rh, # x
  312. 0 value adind
  313. 0 value adcc   0 value adnr
  314.  
  315. variable adregf    0 value adreg
  316.  
  317. : in1 ( nr bof -- nr false | true )
  318.     adcc <cc> !
  319.     false rot 16 0
  320.     do dup &ffffff00 and 0=
  321.       if nip swap i + 15 and 8 lshift or
  322.         adop adind + @ or adreg c@ 12 lshift or cc> , true dup leave
  323.       then 2 rotl
  324.     loop over if drop reset else rot drop swap then ;
  325.  
  326. : in2 ( nr bof -- nr false | true )
  327.     false rot 16 0
  328.     do dup &ffffff00 and i in1  adcc <cc> !
  329.       if nip &ff and
  330.         swap i + 15 and 8 lshift or
  331.         adop adind + cell+ @ or adreg 1+ c@ 12 lshift or adreg c@ 16 lshift or
  332.         cc> , true dup leave
  333.       then drop 2 rotl
  334.     loop over if drop reset else rot drop swap then ;
  335.  
  336. comment ÷
  337. : in3 ( nr bof -- nr false | true )
  338.     false rot 16 0
  339.     do dup &ffffff00 and i in2
  340.       if nip &ff and
  341.         swap i + 15 and 8 lshift or 
  342.         adop adind + cell+ @ or adreg 2+ c@ 12 lshift or adreg 1+ c@ 16 lshift or
  343.         , true dup leave
  344.       then drop 2 rotl
  345.     loop over if drop reset else rot drop swap then ;
  346.  
  347. : in4 ( nr bof -- true )
  348.  
  349. ;
  350. ÷
  351.  
  352.  
  353. : (adr)  ( nr 0 -- )
  354.    align
  355.    drop <cc> @ to adcc
  356.    to adnr
  357.    lastreg
  358.    <#REGS> @ 1 =
  359.    if &10101 * lastreg 24 lshift or else &1010101 * then adregf !
  360.    adregf 3 + to adreg
  361.     0 to adind  adnr            0 in1  ?exit
  362.     8 to adind       negate 1-  0 in1  ?exit drop
  363.    16 to adind  adnr here 8 + - 0 in1  ?exit
  364.    24 to adind       negate     0 in1  ?exit drop
  365.    adregf 2 +  to adreg
  366.     0 to adind  adnr            0 in2  ?exit
  367.     8 to adind       negate 1-  0 in2  ?exit drop
  368.    16 to adind  adnr here 8 + - 0 in2  ?exit
  369.    24 to adind       negate     0 in2  ?exit drop
  370.    true abort" HMPH" ; 
  371.  
  372. : 1m ( ad -- ) 
  373.     align
  374.     @ dup &f and dup <typ> ! 2 =
  375.     if &100000 or <P> @ or then
  376.     &fffffff0 and
  377.     <S> @ or
  378.     cc>
  379.     <OIS> off  shift> 
  380.     <#REGS> @ 2 <typ> @ 0= - >=    \ ? Register als letzter Operand
  381.     if lastreg or
  382.     else <SH> @ 0= 3 assabort
  383.       <#> @ 0 assabort swap valid? or
  384.     then
  385.     <typ> @ 0=
  386.     if lastreg 16 lshift or
  387.     then
  388.     lastreg <typ> @ 2 =
  389.     if 16 lshift
  390.     else 12 lshift
  391.     then or
  392.     , reset ;
  393.  
  394. : 1mi
  395.     create ,
  396.     does> ['] 1m a;! a; ;
  397.  
  398. : 2m
  399.     align
  400.     @
  401.     <S> @ or
  402.     cc>
  403.     dup &200000 and
  404.     if lastreg 12 lshift or then
  405.     lastreg 8 lshift or
  406.     lastreg dup >r or
  407.     lastreg dup 15 <> 5 assabort
  408.     dup r> <> 6 assabort
  409.     16 lshift or
  410.     , reset ;
  411.  
  412. : 2mi
  413.     align
  414.     create ,
  415.     does> ['] 2m a;! a; ;
  416.  
  417. : 3m
  418.     align
  419.     @
  420.     cc>
  421.     swap here ad>of or
  422.     , reset ;
  423.  
  424. : 3mi
  425.     create ,
  426.     does> ['] 3m a;! a; ;
  427.  
  428. : 4m
  429.     align
  430.     @
  431.     cc>
  432.     <#REGS> @ 1- 0 do
  433.       lastreg dup 15 =
  434.       if swap <^> @ or swap then
  435.       1 swap lshift or
  436.     loop
  437.     lastreg 16 lshift or
  438.     <!> @ or
  439.     , reset ;
  440.  
  441. : 4mi
  442.     create ,
  443.     does> ['] 4m a;! a; ;
  444.  
  445. : 5m
  446.     align
  447.     @
  448.     cc>
  449.     <REGS> c@ &f and 12 lshift or
  450.     <[> @
  451.     if <REGS> 1+ c@ &f and 16 lshift or
  452.       <OIS> on
  453.       <],> @
  454.       if <T> @ or &feffffff and
  455.       else <!> @ or
  456.       then
  457.       <#REGS> @ 2 >
  458.       if &2000000 or
  459.         <REGS> 2 + c@ &f and or
  460.         shift>
  461.       else <#> @
  462.         if swap rel#>
  463.         then
  464.       then
  465.     else <!> @ 0<>  <SH> @ 0<> or 0= 7 assabort
  466.       &10f0000 or
  467.       swap here 8 + -
  468.       dup 0< if negate swap &ff7fffff and swap then
  469.       dup &1000 < 4 assabort
  470.       or 
  471.     then
  472.     , reset ;
  473.  
  474. : 5mi
  475.     create ,
  476.     does> ['] 5m a;! a; ;
  477.  
  478. code 6m1
  479.   &e1a0100a , \ mov r1, tos
  480.   &ef000039 , \ swi " OS_NameToNumber"
  481.   &e1a0a000 , \ mov tos, r0
  482.   &e49bf004 , \ ldr pc, [ ip ], # 4
  483. c;
  484.  
  485. : "f>c ( ad len -- ad' )
  486.     >r pad r@ cmove 0 pad r> + c! pad ;
  487.  
  488. : 6m
  489.     align
  490.     @ 
  491.     cc>
  492.     <X> @ or
  493.     dup 1 and swap &fffffffe and swap 
  494.     if swap 
  495.     else -rot "f>c 6m1
  496.     then
  497.     &ffffff and or , reset ;
  498.  
  499. : 6mi
  500.     create ,
  501.     does> ['] 6m a;! a; ;
  502.  
  503. &e0000000 1mi AND            &e0200000 1mi EOR
  504. &e0400000 1mi SUB            &e0600000 1mi RSB
  505. &e0800000 1mi ADD            &e0a00000 1mi ADC
  506. &e0c00000 1mi SBC            &e0e00000 1mi RSC
  507. &e1100002 1mi TST            &e1300002 1mi TEQ
  508. &e1500002 1mi CMP            &e1700002 1mi CMN
  509. &e1800000 1mi ORR            &e1a00001 1mi MOV
  510. &e1C00000 1mi BIC            &e1e00001 1mi MVN
  511. &e0000090 2mi MUL            &e0200090 2mi MLA
  512. &eb000000 3mi BL             &ea000000 3mi B
  513. &e9000000 4mi STMFD          &e8900000 4mi LDMFD
  514. &e9800000 4mi STMFA          &e8100000 4mi LDMFA
  515. &e8000000 4mi STMED          &e9900000 4mi LDMED
  516. &e8800000 4mi STMEA          &e9100000 4mi LDMEA
  517. &e5900000 5mi LDR            &e5d00000 5mi LDRB
  518. &e5800000 5mi STR            &e5c00000 5mi STRB
  519. &ef000000 6mi SWI            &ef000001 6mi SWI#
  520. : adr 0 ['] (adr) a;! a; ;
  521.  
  522. : ?condition
  523.     not abort" Conditionals Wrong!" ;
  524.  
  525. : A?>MARK    ( n -- f addr ) true here rot t, ;
  526. : A?>RESOLVE ( f addr -- )   HERE OVER ad>of over t@ or SWAP T! ?CONDITION ;
  527. : A?<MARK    ( -- f addr )   TRUE   HERE   ;
  528. : A?<RESOLVE ( f addr n -- ) swap HERE ad>of or t, ?CONDITION ;
  529.  
  530. ' A?>MARK    assembler IS ?>MARK
  531. ' A?>RESOLVE assembler IS ?>RESOLVE
  532. ' A?<MARK    assembler IS ?<MARK
  533. ' A?<RESOLVE assembler IS ?<RESOLVE
  534.  
  535. &1a000000 CONSTANT 0=   &0a000000 CONSTANT 0<>   &5a000000 CONSTANT 0<
  536. &4a000000 CONSTANT 0>=  &aa000000 CONSTANT <     &ba000000 CONSTANT >=
  537. &ca000000 CONSTANT <=   &da000000 CONSTANT >     &2a000000 CONSTANT U<
  538. &3a000000 CONSTANT U>=  &8a000000 CONSTANT U<=   &9a000000 CONSTANT U>
  539. &6a000000 CONSTANT OV<> &7a000000 CONSTANT OV
  540.  
  541. : BEGIN ( - f a )           A; ?<MARK ;
  542. : UNTIL ( f a n - )         >R A; R> ?<RESOLVE A; ;  
  543. : AGAIN ( f a - )           &ea000000 UNTIL ;
  544. : IF ( n - f A )            >R A; R> ?>MARK A; ;        
  545. : THEN ( f A - )            A; ?>RESOLVE ;
  546. : ELSE ( f A - f A )        &ea000000 IF 2SWAP THEN ;
  547. : REPEAT ( f A f a - )      A; AGAIN THEN ;
  548. : WHILE ( f a n - f A f a ) IF 2SWAP ;
  549.  
  550. : next
  551.     >pre ldr pc, [ ip ], # 4
  552.     pre> ;
  553.  
  554. FORTH DEFINITIONS
  555.  
  556. : INLINE        [COMPILE] [ SETASSEM HERE cell+ , ; IMMEDIATE
  557.  
  558. assembler DEFINITIONS
  559.  
  560. : END-INLINE    o[ assembler o]
  561.   >pre
  562.     add ip, pc, # 0
  563.     ldr pc, [ ip ], # 4
  564.   pre>
  565.   END-CODE o] ;
  566.  
  567. \ behead
  568.  
  569. ONLY FORTH DEFINITIONS ALSO
  570.  
  571. DECIMAL
  572.  
  573. \s
  574. \  And here is how to use the Assembler words:
  575.  
  576. code nn
  577.   adr r2, ' interpret 3 +
  578.   adr r1, ' inline
  579.   mov tos, # 5
  580.   adc pl r0, r1, r2
  581.   sbc eq r0, r1, r2 lsl # 5
  582.   rsb al r0, r1, r2 ror r3
  583.   add nv r0, r1, # &e700000
  584.   ldr r0, [ r1 ], r2
  585.   str r0, [ rp ], # 1024
  586.   ldrb r0, [ r1, # 10 ]
  587.   strb r0, [ r1, r2, asr # 7 ]!
  588.   ldr r0, [ r1 ], r2 asl # 21 T
  589.   str r0, [ r1 ]
  590.   stmfd sp !, { tos, r5, r3, r13, link, pc }
  591.   0= if
  592.     swi " OS_WriteC"
  593.   else
  594.     swi " OS_Write0"
  595.   then
  596.   bl &13004
  597. next c;