home *** CD-ROM | disk | FTP | other *** search
/ Magazyn Exec 3 / CD_Magazyn_EXEC_nr_3.iso / Recent / misc / emu / evax11.lha / evax / forth.asm < prev    next >
Assembly Source File  |  2000-01-28  |  39KB  |  1,545 lines
  1.  
  2.  
  3. ; Vforth--a 32 bit forth system using subroutine threading for
  4. ;   increased speed.
  5. ;
  6. ;   By Andy Valencia, 1984
  7. ;
  8. ;   Minor tweaks and changes to make this work with eVAX
  9. ;   By Tom Cole, 1999
  10. ;
  11. ;
  12. ; Registers with fixed uses:
  13. ;   PC - Since we're using direct threading, this operates as the actual
  14. ;       execution vector for each instruction.
  15. ;   SP - Maintains the return stack
  16. ;   R11 - The operand stack
  17. ;   R10 - Next open byte in the dictionary--"HERE"
  18. ;   R9  - Index into current input line
  19. ;   R8  - Points to last entry in the dictionary chain
  20. ;
  21.  
  22.     .console set radix dec
  23.     .region s0
  24.     .align 512
  25. ;
  26. ; These are the constants which are compiled into the executable code
  27. ;
  28.     .set    jsb_header,0x9F16   ; jsb @#...
  29.     .set    lit_header,0x8FD0   ; pushl #...
  30.     .set    lit_tailer,0x7B
  31.     .set    rsb_header,0x5      ; rsb
  32.     .set    Again_header,0x9F17 ; jmp @#...
  33.     .set    Skipt,0x6128BD5     ; tstl (r11)+; bnequ .+6
  34.  
  35. ;
  36. ; These are the other constants
  37. ;
  38.     .set    XRecursive,1        ; SFA bits: recursive function
  39.     .set    XSmudged,2      ;   SMUDGE bit
  40.     .set    Priority,4      ;   IMMEDIATE
  41.     .set    Primitive,8     ;   PRIMITIVE--is a code macro
  42.  
  43.     .set    NL,10           ; Newline
  44.     .set    Spc,32          ; Space
  45.     .set    Tab,9           ; Tab
  46.  
  47.     .set    Mrkcolon,1      ; For control structure matching
  48.     .set    Mrkif,2
  49.     .set    Mrkdo,3
  50.     .set    Mrkbegin,4
  51.     .set    Mrkwhile,5
  52.  
  53.     ; .data 0
  54.  
  55.     .entry  exe$forth,^m<r2,r3,r4,r5,r6,r7,r8,r9,r10,r11>       ; Procedure entry mask
  56.         
  57. go1:    movl    @#dictend,r10       ; r10 is end of dictionary
  58.     movl    sp,sp_hold      ; For resetting SP later
  59.     movl    @#latest,r8     ; Setup R8 to end of dict.
  60. abort:  movl    sp_hold,sp      ; Start SP from its initial value
  61.     subl3   #80,sp,r11      ; Leave 80 bytes for opstack
  62.     movl    r11,stacklim        ; For underflow checking
  63.     movl    #inline,r9      ; Set up input line as empty
  64.     clrb    (r9)
  65.     clrl    @#state         ; Turn off compile mode
  66.     movl    #istk,isp       ; Reset I/O system
  67.     clrl    istk
  68.     clrl    iunit
  69.     movl    #ostk,osp
  70.     cvtbl   #1,ostk
  71.     cvtbl   #1,ounit
  72.     jbr interp          ; Start up the interpretive loop
  73.  
  74. ;
  75. ; Some data area
  76. ;
  77. sp_hold: .space 4           ; Holds return stack base
  78. stacklim: .space 4          ; Holds bottom of stack
  79. inline: .space  1025            ; Room for a block of input
  80. wrd:    .space  81          ;  and up to 80-char word
  81. latest:                 ; Last intrinsic word in dictionary
  82.     .long   interp1
  83.  
  84. ;
  85. ; Pushdown list of input & output file descriptors
  86. istk:   .long   0,0,0,0,0,0,0,0
  87. isp:    .long   istk
  88. ideep:  .long   0
  89. iunit:  .long   0
  90. ostk:   .long   1,1,1,1,1,1,1,1
  91. osp:    .long   ostk
  92. odeep:  .long   0
  93. ounit:  .long   1
  94.  
  95. ;
  96. ; KLUDGE city! When we push down an input file, we have to save the buffer,
  97. ;   otherwise the new input file will abuse it in various undesireable
  98. ;   ways. So we make room for a save image of each input unit.
  99. ibufs:  .space  1024@8  ; The input buffers
  100. ibufx:  .space  4@8 ;  and the current position within them
  101.  
  102. ;
  103. ; Open the given file for output; add it to the pushdown stack. Error
  104. ;   if it can't be opened.
  105. ;
  106. outfcb: .long   3
  107. outname: .space 4
  108.     .long   0x201,0x1FF
  109. outopen:
  110.     movl    r0,outname
  111.     movl    #outfcb,ap
  112.     chmk    #5
  113.     bcs outop1
  114.     movl    osp,r1
  115.     addl2   #4,r1
  116.     movl    r0,(r1)
  117.     movl    r0,ounit
  118.     movl    r1,osp
  119.     incl    odeep
  120.     rsb
  121. outop1: movl    #outop2,r0  ; Couldn't open--complain
  122.     jsb prstr
  123.     jbr abort
  124. outop2: .asciz  " Could not open output file\n"
  125.  
  126. ;
  127. ; Open the given file for input; add it to the pushdown stack. Error
  128. ;   if it can't be opened.
  129. ;
  130. infcb:  .long   3       ; parms to do a OPEN for READ syscall
  131. inname: .space  4
  132.     .long   0,0x1FF
  133.  
  134. inopen: movl    r0,inname   ; Set up name for open
  135.     movl    #infcb,ap
  136.     chmk    #5
  137.     bcs inop1
  138.  
  139.                 ; Open successful, save previous buffer
  140.     movl    #256,r2     ; R2 is the number of bytes to move
  141.     movl    ideep,r3
  142.     mull2   #1024,r3
  143.     addl2   #ibufs,r3   ; R3 now points to our save location
  144.     movl    #inline,r1  ; R1 points to the buffer to save
  145. inop3:  movl    (r1)+,(r3)+ ; Move the bytes
  146.     sobgtr  r2,inop3
  147.     movl    ideep,r3    ; Now save the input index
  148.     movl    r9,ibufx[r3]
  149.     movl    #inline,r9  ; Clear the input buffer
  150.     clrb    (r9)
  151.  
  152.     movl    isp,r1      ; Push down the old file descriptor
  153.     addl2   #4,r1
  154.     movl    r0,(r1)
  155.     movl    r0,iunit
  156.     movl    r1,isp
  157.     incl    ideep
  158.     rsb
  159. inop1:  movl    #inop2,r0   ; Bad open, complain & abort
  160.     jsb prstr
  161.     jbr abort
  162. inop2:  .asciz  " Could not open input file.\n"
  163.  
  164. ;
  165. ; ----Start of FORTH dictionary
  166. ;
  167.  
  168. ;
  169. ; over--copy second to new top
  170. ;
  171. over2:  .long   0,over1
  172.     .word   4,Primitive
  173.     .asciz  "over"
  174. over1:  movl    4(r11),-(r11)
  175.     rsb
  176.  
  177. ;
  178. ; abs,fabs--get absolute value
  179. ;
  180. abs2:   .long   over2,abs1,0
  181.     .asciz  "abs"
  182. abs1:   tstl    (r11)
  183.     bgeq    abs3
  184.     mnegl   (r11),(r11)
  185. abs3:   rsb
  186. fabs2:  .long   abs2,fabs1,0
  187.     .asciz  "fabs"
  188. fabs1:  tstf    (r11)
  189.     bgeq    abs3
  190.     mnegf   (r11),(r11)
  191.     rsb
  192.  
  193. ;
  194. ; max,fmax--get maximum value
  195. ;
  196. max2:   .long   fabs2,max1,0
  197.     .asciz  "max"
  198. max1:   movl    (r11)+,r0
  199.     cmpl    r0,(r11)
  200.     bleq    max3
  201.     movl    r0,(r11)
  202. max3:   rsb
  203. fmax2:  .long   max2,fmax1,0
  204.     .asciz  "fmax"
  205. fmax1:  movf    (r11)+,r0
  206.     cmpf    r0,(r11)
  207.     bleq    max3
  208.     movf    r0,(r11)
  209. fmax3:  rsb
  210.  
  211. ;
  212. ; min,fmin--get minimum value
  213. ;
  214. min2:   .long   fmax2,min1,0
  215.     .asciz  "min"
  216. min1:   movl    (r11)+,r0
  217.     cmpl    r0,(r11)
  218.     bgeq    min3
  219.     movl    r0,(r11)
  220. min3:   rsb
  221. fmin2:  .long   min2,fmin1,0
  222.     .asciz  "fmin"
  223. fmin1:  movf    (r11)+,r0
  224.     cmpf    r0,(r11)
  225.     bgeq    min3
  226.     movf    r0,(r11)
  227. fmin3:  rsb
  228.  
  229. ;
  230. ; c@, c!--byte fetch/store operators
  231. ;
  232. cfet2:  .long   fmin2,cfet1
  233.     .word   6,Primitive
  234.     .asciz  "c@"
  235. cfet1:  movl    (r11),r0
  236.     cvtbl   (r0),(r11)
  237.     rsb
  238. csto2:  .long   cfet2,csto1
  239.     .word   6,Primitive
  240.     .asciz  "c!"
  241. csto1:  movl    (r11)+,r0
  242.     cvtlb   (r11)+,(r0)
  243.     rsb
  244.  
  245. ;
  246. ; negate & fnegate
  247. ;
  248. neg2:   .long   csto2,neg1
  249.     .word   3,Primitive
  250.     .asciz  "negate"
  251. neg1:   mnegl   (r11),(r11)
  252.     rsb
  253. fneg2:  .long   neg2,fneg1
  254.     .word   3,Primitive
  255.     .asciz  "fnegate"
  256. fneg1:  mnegf   (r11),(r11)
  257.     rsb
  258.  
  259. ;
  260. ; HERE--provide the address of the next open byte in the dictionary
  261. ;
  262. here2:  .long   fneg2,here1
  263.     .word   3,Primitive
  264.     .asciz  "here"
  265. here1:  movl    r10,-(r11)
  266.     rsb
  267.  
  268. ;
  269. ; "r>" & ">r"--move a word between op & return stacks
  270. ;
  271. to_r2:  .long   here2,to_r1
  272.     .word   2,Primitive
  273.     .asciz  ">r"
  274. to_r1:  pushl   (r11)+
  275.     rsb
  276. from_r2:
  277.     .long   to_r2,from_r1
  278.     .word   3,Primitive
  279.     .asciz  "r>"
  280. from_r1:
  281.     movl    (sp)+,-(r11)
  282.     rsb
  283.  
  284. ;
  285. ; fill--fill an area of memory with a constant
  286. ;
  287. fill2:  .long   from_r2,fill1,0
  288.     .asciz  "fill"
  289. fill1:  cvtlb   (r11)+,r0
  290.     movl    (r11)+,r1
  291.     movl    (r11)+,r2
  292. fill3:  movb    r0,(r2)+
  293.     sobgtr  r1,fill3
  294. fill4:  rsb
  295.  
  296. ;
  297. ; pick--get a word in the stack
  298. ;
  299. pick2:  .long   fill2,pick1,0
  300.     .asciz  "pick"
  301. pick1:  movl    (r11)+,r0
  302.     movl    (r11)[r0],-(r11)
  303.     rsb
  304.  
  305. ;
  306. ; 'c,' & ','--push word to HERE
  307. ;
  308. comma2: .long   pick2,comma1
  309.     .word   3,Primitive
  310.     .asciz  ","
  311. comma1: movl    (r11)+,(r10)+
  312.     rsb
  313. ccomm2: .long   comma2,ccomm1
  314.     .word   3,Primitive
  315.     .asciz  "c,"
  316. ccomm1: cvtlb   (r11)+,(r10)+
  317.     rsb
  318.  
  319. ;
  320. ; rot,-rot --the rotational operators
  321. ;
  322. rot2:   .long   ccomm2,rot1,0
  323.     .asciz  "rot"
  324. rot1:   movl    (r11)+,r0
  325.     movl    (r11)+,r1
  326.     movl    (r11),r2
  327.     movl    r1,(r11)
  328.     movl    r0,-(r11)
  329.     movl    r2,-(r11)
  330.     rsb
  331. drot2:  .long   rot2,drot1,0
  332.     .asciz  "-rot"
  333. drot1:  movl    (r11)+,r0
  334.     movl    (r11)+,r1
  335.     movl    (r11),r2
  336.     movl    r0,(r11)
  337.     movl    r2,-(r11)
  338.     movl    r1,-(r11)
  339.     rsb
  340.  
  341. ;
  342. ; allot--move the end of the dictionary forward a number of bytes
  343. ;
  344. allot2: .long   drot2,allot1
  345.     .word   3,Primitive
  346.     .asciz  "allot"
  347. allot1: addl2   (r11)+,r10
  348.     rsb
  349.  
  350. ;
  351. ; 2dup, 2swap--double-int stack operators
  352. ;
  353. tdup2:  .long   allot2,tdup1,0
  354.     .asciz  "2dup"
  355. tdup1:  movl    (r11)+,r0
  356.     movl    (r11),r1
  357.     movl    r0,-(r11)
  358.     movl    r1,-(r11)
  359.     movl    r0,-(r11)
  360.     rsb
  361. tswap2: .long   tdup2,tswap1,0
  362.     .asciz  "2swap"
  363. tswap1: movl    (r11)+,r0
  364.     movl    (r11)+,r1
  365.     movl    (r11)+,r2
  366.     movl    (r11),r3
  367.     movl    r1,(r11)
  368.     movl    r0,-(r11)
  369.     movl    r3,-(r11)
  370.     movl    r2,-(r11)
  371.     rsb
  372.  
  373. ;
  374. ; "("--handle forth comments
  375. ;
  376. comm2:  .long   tswap2,comm1
  377.     .word   0,Priority
  378.     .asciz  "("
  379. comm1:  movb    (r9)+,r0    ; Get next byte of input
  380.     cmpb    r0,0        ; Get another buffer-full if hit end of cur.
  381.     beql    comm3
  382.     cmpb    r0,#10      ; End comment on newline or close paren
  383.     beql    comm4
  384.     cmpb    r0,#41
  385.     bneq    comm1
  386. comm4:  rsb
  387. comm3:  jsb getlin      ; Get another buffer
  388.     brb comm1
  389.  
  390. ;
  391. ; "abort"--calls the forth abort code
  392. ;
  393. abo2:   .long   comm2,abo1,0
  394.     .asciz  "abort"
  395. abo1:   jbr abort
  396.  
  397. ;
  398. ; "halt"--cause forth to exit
  399. ;
  400. halt3:  .long   1,0
  401. halt2:  .long   abo2,halt1,0
  402.     .asciz  "halt"
  403. exit:
  404. halt1:  movl    #halt3,ap
  405.     movl    r10, @#dictend  ; save end of dictionary storage area
  406.     movl    r8, @#latest;   ; end of dictionary linked list
  407.     ret ; chmk  #1
  408.  
  409. ;
  410. ; "outpop"--do for the output list what EOF does for the input list;
  411. ;   close the current output file & pop back a level
  412. ;
  413. outp4:  .long   1
  414. outp3:  .space  4
  415. outp2:  .long   halt2,outp1,0
  416.     .asciz  "outpop"
  417. outp1:  movl    osp,r0      ; Get the stack pointer to R0
  418.     cmpl    r0,#ostk    ; Don't pop off end of stack
  419.     beql    outp5
  420.     movl    ounit,outp3 ; Close the current unit
  421.     moval   outp4,ap
  422.     chmk    #6
  423.     movl    osp,r0
  424.     subl2   #4,r0       ; Move back a position
  425.     movl    (r0),ounit  ;  and set output to that file descriptor
  426.     movl    r0,osp
  427.     decl    odeep       ; Decrement nesting count
  428. outp5:  rsb
  429.  
  430. ;
  431. ; "output"--open the named output file & make it the new output unit
  432. ;
  433. out2:   .long   outp2,out1,0
  434.     .asciz  "output"
  435. out1:   jsb getw
  436.     movl    #wrd,r0
  437.     jsb outopen
  438.     rsb
  439.  
  440. ;
  441. ; "input"--open the named file & make it the new input unit
  442. ;
  443. inp2:   .long   out2,inp1,0
  444.     .asciz  "input"
  445. inp1:   jsb getw        ; Get the name of the file
  446.     movl    #wrd,r0
  447.     jsb inopen
  448.     rsb
  449.  
  450. ;
  451. ; Push logical constants to stack
  452. ;
  453. false2: .long   inp2,false1
  454.     .word   2,Primitive
  455.     .asciz  "false"
  456. false1: clrl    -(r11)
  457.     rsb
  458. true2:  .long   false2,true1
  459.     .word   4,Primitive
  460.     .asciz  "true"
  461. true1:  cvtbl   #-1,-(r11)
  462.     rsb
  463.  
  464. ;
  465. ; the logical operators. Note that they serve for both logical and
  466. ;   bitwise purposes, as "true" is defined as -1.
  467. ;
  468. lor2:   .long   true2,lor1
  469.     .word   3,Primitive
  470.     .asciz  "or"
  471. lor1:   bisl2   (r11)+,(r11)
  472.     rsb
  473. land2:  .long   lor2,land1,0
  474.     .asciz  "and"
  475. land1:  bitl    (r11)+,(r11)
  476.     bneq    land3
  477.     clrl    (r11)
  478.     rsb
  479. land3:  cvtbl   #-1,(r11)
  480.     rsb
  481.  
  482. ;
  483. ; the floating relational operators
  484. ;
  485. feq2:   .long   land2,feq1,0
  486.     .asciz  "f="
  487. feq1:   cmpf    (r11)+,(r11)
  488.     beql    feq3
  489.     clrl    (r11)
  490.     rsb
  491. feq3:   cvtbl   #-1,(r11)
  492.     rsb
  493. fgt2:   .long   feq2,fgt1,0 ; Greater than
  494.     .asciz  "f>"
  495. fgt1:   cmpf    (r11)+,(r11)
  496.     blss    fgt3
  497.     clrl    (r11)
  498.     rsb
  499. fgt3:   cvtbl   #-1,(r11)
  500.     rsb
  501. flt2:   .long   fgt2,flt1,0 ; Less than
  502.     .asciz  "f<"
  503. flt1:   cmpf    (r11)+,(r11)
  504.     bgtr    flt3
  505.     clrl    (r11)
  506.     rsb
  507. flt3:   cvtbl   #-1,(r11)
  508.     rsb
  509.  
  510. ;
  511. ; the relational operators
  512. ;
  513. eq2:    .long   flt2,eq1,0
  514.     .asciz  "="
  515. eq1:    cmpl    (r11)+,(r11)
  516.     beql    eq3
  517.     clrl    (r11)
  518.     rsb
  519. eq3:    cvtbl   #-1,(r11)
  520.     rsb
  521. gt2:    .long   eq2,gt1,0   ; Greater than
  522.     .asciz  ">"
  523. gt1:    cmpl    (r11)+,(r11)
  524.     blss    gt3
  525.     clrl    (r11)
  526.     rsb
  527. gt3:    cvtbl   #-1,(r11)
  528.     rsb
  529. lt2:    .long   gt2,lt1,0   ; Less than
  530.     .asciz  "<"
  531. lt1:    cmpl    (r11)+,(r11)
  532.     bgtr    lt3
  533.     clrl    (r11)
  534.     rsb
  535. lt3:    cvtbl   #-1,(r11)
  536.     rsb
  537.  
  538. ;
  539. ; drop,2drop--get rid of top item(s)
  540. ;
  541. tdrop2: .long   lt2,tdrop1
  542.     .word   3,Primitive
  543.     .asciz  "2drop"
  544. tdrop1: addl2   #8,r11
  545.     rsb
  546. drop2:  .long   tdrop2,drop1
  547.     .word   3,Primitive
  548.     .asciz  "drop"
  549. drop1:  movl    (r11)+,r0
  550.     rsb
  551.  
  552. ;
  553. ; swap--exchange top & second
  554. ;
  555. swap2:  .long   drop2,swap1
  556.     .word   12,Primitive
  557.     .asciz  "swap"
  558. swap1:  movl    (r11)+,r0
  559.     movl    (r11),r1
  560.     movl    r0,(r11)
  561.     movl    r1,-(r11)
  562.     rsb
  563.  
  564. ;
  565. ; dup--duplicate top
  566. ;
  567. dup2:   .long   swap2,dup1
  568.     .word   3,Primitive
  569.     .asciz  "dup"
  570. dup1:   movl    (r11),-(r11)
  571.     rsb
  572.  
  573. ;
  574. ; "if"--conditional control structure
  575. ;
  576. if2:    .long   dup2,if1
  577.     .word   0,Priority
  578.     .asciz  "if"
  579. if1:    movl    #0x6128BD5,(r10)+   ; tstl (r11)+; bneq .+6
  580.     movw    #0x9F17,(r10)+      ; jmp @#...
  581.     movl    r10,-(r11)
  582.     addl2   #4,r10
  583.     movl    #Mrkif,-(r11)       ; Mark the control structure
  584.     rsb
  585.  
  586. ;
  587. ; "else"
  588. ;
  589. else2:  .long   if2,else1
  590.     .word   0,Priority
  591.     .asciz  "else"
  592. else1:  cmpl    #Mrkif,(r11)+       ; Check for matching 'if'
  593.     bneq    else3
  594.     movw    #0x9F17,(r10)+      ; jmp @#...
  595.     movl    r10,r0
  596.     addl2   #4,r10          ; Leave room for the jump address
  597.     movl    r10,@(r11)+     ; Have 'false' branch here
  598.     movl    r0,-(r11)       ; Put our fill-in addr.
  599.     movl    #Mrkif,-(r11)       ;  and put back the marker
  600.     rsb
  601. else3:  movl    #else4,r0       ; Complain
  602.     jsb prstr
  603.     jbr abort
  604. else4:  .asciz  " 'else' does not match an 'if'\n"
  605.  
  606. ;
  607. ; endif--finish off the conditional
  608. ;
  609. endif2: .long   else2,endif1
  610.     .word   0,Priority
  611.     .asciz  "endif"
  612. endif1: cmpl    (r11)+,#Mrkif       ; Check match
  613.     bneq    endif3
  614.     movl    r10,@(r11)+
  615.     rsb
  616. endif3: movl    #endif4,r0      ; Complain on no match
  617.     jsb prstr
  618.     jbr abort
  619. endif4: .asciz  " 'endif' does not match 'else'/'if'\n"
  620.  
  621. ;
  622. ; begin--start of all looping conditionals
  623. ;
  624. beg2:   .long   endif2,beg1
  625.     .word   0,Priority
  626.     .asciz  "begin"
  627. beg1:   movl    r10,-(r11)      ; Save current address
  628.     cvtbl   #Mrkbegin,-(r11)    ;  and control structure marker
  629.     rsb
  630.  
  631. ;
  632. ; "while".."repeat" looping construct
  633. ;
  634. while4: .asciz  "'while' does not match a 'begin'\n"
  635. while2: .long   beg2,while1
  636.     .word   0,Priority
  637.     .asciz  "while"
  638. while1: cmpl    #Mrkbegin,(r11)+    ; Check match
  639.     bneq    while3
  640.     movl    #0x6128BD5,(r10)+   ; tstl (r11)+; bequ @#<forward>
  641.     movw    #0x9F17,(r10)+
  642.     movl    r10,-(r11)      ; Mark where to plug in
  643.     addl2   #4,r10          ; Leave room for the patch
  644.     movl    #Mrkwhile,-(r11)
  645.     rsb
  646. while3: movl    #while4,r0      ; Bad match, complain
  647.     jsb prstr
  648.     jbr abort
  649.  
  650. rep4:   .asciz  "'repeat' does not match a 'while'\n"
  651. rep2:   .long   while2,rep1
  652.     .word   0,Priority
  653.     .asciz  "repeat"
  654. rep1:   cmpl    #Mrkwhile,(r11)+    ; Check match
  655.     bneq    rep3
  656.     movl    (r11)+,r0       ; Save where to patch
  657.     movw    #0x9F17,(r10)+      ; jmp @#<back>
  658.     movl    (r11)+,(r10)+
  659.     movl    r10,(r0)        ; Backpatch
  660.     rsb
  661. rep3:   movl    #rep4,r0        ; Complain
  662.     jsb prstr
  663.     jbr abort
  664.  
  665. ;
  666. ; again--unconditional back branch
  667. ;
  668. again4: .asciz  "'again' does not match with a 'begin'\n"
  669. again2: .long   rep2,again1
  670.     .word   0,Priority
  671.     .asciz  "again"
  672. again1: cmpl    #Mrkbegin,(r11)+    ; verify match of control structures
  673.     bnequ   again3
  674.     movw    #Again_header,(r10)+    ; compile in back branch
  675.     movl    (r11)+,(r10)+
  676.     rsb
  677. again3: movl    #again4,r0      ; Complain
  678.     jsb prstr
  679.     jbr abort
  680.  
  681. ;
  682. ; until--loop until condition becomes true
  683. ;
  684. until4: .asciz  "'until' doesn not match a 'begin'\n"
  685. until2: .long   again2,until1
  686.     .word   0,Priority
  687.     .asciz  "until"
  688. until1: cmpl    #Mrkbegin,(r11)+    ; Verify match
  689.     bnequ   until3
  690.     movl    #Skipt,(r10)+       ; Branch over backbranch if true
  691.     movw    #Again_header,(r10)+    ; compile in backbranch
  692.     movl    (r11)+,(r10)+
  693.     rsb
  694. until3: movl    #until4,r0      ; Complain
  695.     jsb prstr
  696.     jbr abort
  697.  
  698. ;
  699. ; leave--setup innermost loop so it will exit at next iteration
  700. ;
  701. leave2: .long   until2,leave1
  702.     .word   4,Primitive
  703.     .asciz  "leave"
  704. leave1: movl    (sp),4(sp)
  705.     rsb
  706.  
  707. ;
  708. ; "k"--return index of third loop
  709. ;
  710. k_idx2: .long   leave2,k_idx1
  711.     .word   4,Primitive
  712.     .asciz  "k"
  713. k_idx1: movl    20(sp),-(r11)
  714.     rsb
  715.  
  716. ;
  717. ; "j"--return index of second loop
  718. ;
  719. j_idx2: .long   k_idx2,j_idx1
  720.     .word   4,Primitive
  721.     .asciz  "j"
  722. j_idx1: movl    12(sp),-(r11)
  723.     rsb
  724.  
  725. ;
  726. ; "i"--return index of innermost loop
  727. ;
  728. i_idx2: .long   j_idx2,i_idx1
  729.     .word   4,Primitive
  730.     .asciz  "i"
  731. i_idx1: movl    4(sp),-(r11)
  732.     rsb
  733.  
  734. ;
  735. ; "do"--start a loop
  736. ;
  737.     .set    XDo1,0xD07E8BD0 ; movl (r11)+,-(sp); movl (r11)+,-(sp)
  738.     .set    XDo2,0x7E8B
  739.  
  740.     .set    XDo3,0xD0508ED0 ; movl (sp)+,r0; movl (sp)+,r1
  741.     .set    XDo4,0x51D1518E ;   cmpl r1,r0; blss .+6
  742.     .set    XDo5,0x17061950 ;   jmp @#<forward>
  743.     .set    XDo6,0x9F
  744.  
  745.     .set    XDo7,0xD07E51D0 ; movl r1,-(sp); movl r1,-(sp)
  746.     .set    XDo8,0x7E50
  747.  
  748. do2:    .long   i_idx2,do1
  749.     .word   0,Priority
  750.     .asciz  "do"
  751. do1:    movl    #XDo1,(r10)+
  752.     movw    #XDo2,(r10)+
  753.     movl    r10,-(r11)  ; Save current pos. for back branch
  754.     movl    #XDo3,(r10)+
  755.     movl    #XDo4,(r10)+
  756.     movl    #XDo5,(r10)+
  757.     movb    #XDo6,(r10)+
  758.     movl    r10,-(r11)  ; Save this loc for fill-in as forward branch
  759.     addl2   #4,r10
  760.     movl    #XDo7,(r10)+
  761.     movw    #XDo8,(r10)+
  762.  
  763.     movl    #Mrkdo,-(r11)   ; Flag our control structure
  764.     rsb
  765.  
  766. ;
  767. ; loop--branch back to the opening "DO"
  768. ;
  769.     .set    XLoop1,0x1704AED6   ; incl 4(sp); jmp @#<back>
  770.     .set    XLoop2,0x9F
  771. loop3:  .asciz  "'loop' does not match a 'do'\n"
  772. loop2:  .long   do2,loop1
  773.     .word   0,Priority
  774.     .asciz  "loop"
  775. loop1:  cmpl    #Mrkdo,(r11)+   ; Check for match of control structures
  776.     bnequ   loop4
  777.     movl    (r11)+,r0   ; Keep where to fill in forward branch addr.
  778.     movl    #XLoop1,(r10)+  ; Build code to increment loop
  779.     movb    #XLoop2,(r10)+
  780.     movl    (r11)+,(r10)+
  781.     movl    r10,(r0)    ; Fill in this location as loop exit addr.
  782.     rsb
  783. loop4:  movl    #loop3,r0   ; Bad match--complain
  784.     jsb prstr
  785.     jbr abort
  786.  
  787. ;
  788. ; +loop--like loop, but add by the top item instead of 1
  789. ;
  790.     .set    XLoop1,0x4AE8BC0        ; incl 4(sp); jmp @#<back>
  791.     .set    XLoop2,0x9F17
  792. poop3:  .asciz  "'+loop' does not match a 'do'\n"
  793. poop2:  .long   loop2,poop1
  794.     .word   0,Priority
  795.     .asciz  "+loop"
  796. poop1:  cmpl    #Mrkdo,(r11)+   ; Check for match of control structures
  797.     bnequ   poop4
  798.     movl    (r11)+,r0   ; Keep where to fill in forward branch addr.
  799.     movl    #XLoop1,(r10)+  ; Build code to increment loop
  800.     movw    #XLoop2,(r10)+
  801.     movl    (r11)+,(r10)+
  802.     movl    r10,(r0)    ; Fill in this location as loop exit addr.
  803.     rsb
  804. poop4:  movl    #poop3,r0   ; Bad match--complain
  805.     jsb prstr
  806.     jbr abort
  807.  
  808. ;
  809. ; "@"--fetch the contents of the addressed word
  810. ;
  811. fetch2: .long   poop2,fetch1
  812.     .word   4,Primitive
  813.     .asciz  "@"
  814. fetch1: movl    @(r11),(r11)
  815.     rsb
  816.  
  817. ;
  818. ; "!"--store the word (second) to address (top)
  819. ;
  820. store2: .long   fetch2,store1
  821.     .word   6,Primitive
  822.     .asciz  "!"
  823. store1: movl    (r11)+,r0
  824.     movl    (r11)+,(r0)
  825.     rsb
  826.  
  827. ;
  828. ; "variable"--build a variable
  829. ;
  830.     .set    XVar1,0x8FD0        ; movl #<addr>,-(r11)
  831.     .set    XVar2,0x7B
  832. var2:   .long   store2,var1,0
  833.     .asciz  "variable"
  834. var1:   jsb getw            ; Build the header
  835.     movl    r8,r2           ; Add this word to the chain
  836.     movl    r10,r8
  837.     movl    r2,(r10)+
  838.     movl    r10,r0          ; Save this position (PFA)
  839.     clrl    (r10)+
  840.     cvtbw   #7,(r10)+       ; SFP = 7
  841.     cvtbw   #Primitive,(r10)+   ; SFA = "primitive"
  842.     movl    #wrd,r1         ; Now copy the name in
  843. var3:   movb    (r1)+,(r10)
  844.     tstb    (r10)+
  845.     bnequ   var3
  846.     movl    r10,(r0)        ; Update the PFA
  847.     movw    #XVar1,(r10)+       ; Our in-line code
  848.     addl3   #6,r10,(r10)+
  849.     movb    #XVar2,(r10)+
  850.     movb    #rsb_header,(r10)+
  851.     clrl    (r10)+          ; The first word of space (= 0)
  852.     rsb
  853.  
  854. ;
  855. ; "constant"--build a constant value
  856. ;
  857. const2: .long   var2,const1,0
  858.     .asciz  "constant"
  859. const1: jsb getw            ; Build the header
  860.     movl    r8,r2           ; Add this word to the chain
  861.     movl    r10,r8
  862.     movl    r2,(r10)+
  863.     movl    r10,r0          ; Save this position (PFA)
  864.     clrl    (r10)+
  865.     cvtbw   #7,(r10)+       ; SFP = 7
  866.     cvtbw   #Primitive,(r10)+   ; SFA = "primitive"
  867.     movl    #wrd,r1         ; Now copy the name in
  868. const3: movb    (r1)+,(r10)
  869.     tstb    (r10)+
  870.     bnequ   const3
  871.     movl    r10,(r0)        ; Update the PFA
  872.     movw    #XVar1,(r10)+       ; Our in-line code
  873.     movl    (r11)+,(r10)+       ; the value to push
  874.     movb    #XVar2,(r10)+
  875.     movb    #rsb_header,(r10)+
  876.     rsb
  877.  
  878.  
  879. ;
  880. ; ":"--start a colon definition
  881. ;
  882. colon2: .long   const2,colon1,0
  883.     .asciz  ":"
  884. colon1: cvtbl   #1,state        ; Set our state to "compile"
  885.     jsb getw            ; Get the name of the new word
  886.     movl    r8,r2           ; Add this word to the chain
  887.     movl    r10,r8
  888.     movl    r2,(r10)+
  889.     movl    r10,r0          ; Save this position (PFA)
  890.     clrl    (r10)+
  891.     clrw    (r10)+          ; SFP = 0
  892.     cvtbw   #XSmudged,(r10)+        ; SFA = "smudged"
  893.     movl    #wrd,r1         ; Now copy the name in
  894. colon3: movb    (r1)+,(r10)
  895.     tstb    (r10)+
  896.     bnequ   colon3
  897.     movl    r10,(r0)        ; Finally, update the PFA
  898.     movl    #Mrkcolon,-(r11)    ; and leave our mark on the stack
  899.     rsb
  900.  
  901. ;
  902. ; ";"--end compile mode
  903. ;
  904. semi4:  .asciz  "; not matched to ':'\n"
  905. semi2:  .long   colon2,semi1
  906.     .word   0,Priority
  907.     .asciz  ";"
  908. semi1:  clrl    state           ; Reset compile state
  909.     cmpl    #Mrkcolon,(r11)+    ; Check the mark
  910.     beql    semi3           ;  Uh-oh, bad match
  911.     movl    #semi4,r0       ; Complain
  912.     jsb prstr
  913.     rsb
  914. semi3:  clrw    10(r8)      ; All OK, so clear the smudge
  915.     movb    #rsb_header,(r10)+ ; Add the closing RSB
  916.     rsb
  917.  
  918. ;
  919. ; "mod"--get remainder of division
  920. ;
  921. mod2:   .long   semi2,mod1,0
  922.     .asciz  "mod"
  923. mod1:   movl    (r11)+,r0
  924.     movl    (r11),r2
  925.     clrl    r3
  926.     ediv    r0,r2,r2,(r11)
  927.     rsb
  928.  
  929. ;
  930. ; "/"--divide second by top
  931. ;
  932. div2:   .long   mod2,div1
  933.     .word   3,Primitive
  934.     .asciz  "/"
  935. div1:   divl2   (r11)+,(r11)
  936.     rsb
  937.  
  938. ;
  939. ; "*"--multiply top two items on stack
  940. ;
  941. mul2:   .long   div2,mul1
  942.     .word   3,Primitive
  943.     .asciz  "*"
  944. mul1:   mull2   (r11)+,(r11)
  945.     rsb
  946.  
  947. ;
  948. ; "-"--subtract top two integers, push result
  949. ;
  950. minus2: .long   mul2,minus1
  951.     .word   3,Primitive
  952.     .asciz  "-"
  953. minus1: subl2   (r11)+,(r11)
  954.     rsb
  955.  
  956. ;
  957. ; "f+"--add floating
  958. ;
  959. fplus2: .long   minus2,fplus1
  960.     .word   3,Primitive
  961.     .asciz  "f+"
  962. fplus1: addf2   (r11)+,(r11)
  963.     rsb
  964.  
  965. ;
  966. ; "f-"--subtract floating
  967. ;
  968. fminus2:
  969.     .long   fplus2,fminus1
  970.     .word   3,Primitive
  971.     .asciz  "f-"
  972. fminus1:
  973.     subf2   (r11)+,(r11)
  974.     rsb
  975.  
  976. ;
  977. ; "f*"--multiply floating
  978. ;
  979. fmul2:  .long   fminus2,fmul1
  980.     .word   3,Primitive
  981.     .asciz  "f*"
  982. fmul1:  mulf2   (r11)+,(r11)
  983.     rsb
  984.  
  985. ;
  986. ; "f/"--divide floating
  987. ;
  988. fdiv2:  .long   fmul2,fdiv1
  989.     .word   3,Primitive
  990.     .asciz  "f/"
  991. fdiv1:  divf2   (r11)+,(r11)
  992.     rsb
  993.  
  994. ;
  995. ; "i->f"--convert int to float
  996. ;
  997. i2f2:   .long   fdiv2,i2f1
  998.     .word   3,Primitive
  999.     .asciz  "i->f"
  1000. i2f1:   cvtlf   (r11),(r11)
  1001.     rsb
  1002.  
  1003. ;
  1004. ; "f->i"--convert float to int
  1005. ;
  1006. f2i2:   .long   i2f2,f2i1
  1007.     .word   3,Primitive
  1008.     .asciz  "f->i"
  1009. f2i1:   cvtfl   (r11),(r11)
  1010.     rsb
  1011.  
  1012. ;
  1013. ; "+"--add top two integers, push result back to stack
  1014. ;
  1015. plus2:  .long   f2i2,plus1
  1016.     .word   3,Primitive
  1017.     .asciz  "+"
  1018. plus1:  addl2   (r11)+,(r11)
  1019.     rsb
  1020.  
  1021. ;
  1022. ; emit--print the specified character
  1023. ;
  1024. emit5:  .space  1
  1025. emit3:  .long   3
  1026. emit4:  .space  4
  1027.     .long   emit5,1
  1028. emit2:  .long   plus2,emit1,0
  1029.     .asciz  "emit"
  1030. emit1:  cvtlb   (r11)+,emit5        ; Put the desired char into the buffer
  1031.     movl    #emit3,ap       ; Print the buffer
  1032.     movl    ounit,emit4
  1033.     chmk    #4
  1034.     rsb
  1035.  
  1036. ;
  1037. ; cr--print newline
  1038. ;
  1039. cr5:    .asciz  "\n"
  1040. cr3:    .long   3
  1041. cr4:    .space  4
  1042.     .long   cr5,1
  1043. cr2:    .long   emit2,cr1,0
  1044.     .asciz  "cr"
  1045. cr1:    movl    #cr3,ap
  1046.     movl    ounit,cr4
  1047.     chmk    #4
  1048.     rsb
  1049.  
  1050. ;
  1051. ; "f."--print a floating point number
  1052. ;
  1053. fprbuf: .space  10          ; Output buffer for fractional part
  1054.  
  1055. fprn2:  .long   cr2,fprn1,0
  1056.     .asciz  "f."
  1057. fprn1:  movf    (r11),r2        ; Handle negative numbers
  1058.     cmpf    r2,#0.0     ; If it's negative...
  1059.     bgeq    fprn9
  1060.     movl    #fprbuf,r0      ;  Print a '-'
  1061.     movl    r0,r1
  1062.     movb    #'-',(r1)+
  1063.     clrb    (r1)
  1064.     jsb prstr
  1065.     mnegf   (r11),(r11)     ;  And negate it
  1066. fprn9:  cvtfl   (r11),-(r11)        ; Dup the number for "."
  1067.     jsb prnum1
  1068.     movl    #fprbuf,r3      ; R3 points to buffer position
  1069.     movf    (r11)+,r0       ; Get the number
  1070.     cvtfl   r0,r1           ; Get the integer part
  1071.     cvtlf   r1,r1
  1072.     subf2   r1,r0           ; And take it off the number
  1073.     movb    #'.',(r3)+      ; The decimal point
  1074.     cvtbl   #6,r4           ; We always print 6 places
  1075.  
  1076. fprn3:  mulf2   #10.0,r0        ; Get the next digit
  1077.     cvtfl   r0,r1           ; R1 is the next digit
  1078.     cvtlf   r1,r5           ; Take this digit off the number
  1079.     subf2   r5,r0
  1080.     cvtlb   r1,r1           ; Turn it into the ASCII byte
  1081.     addb3   #'0',r1,(r3)+
  1082.     sobgtr  r4,fprn3        ; Loop 6 times
  1083.  
  1084.     clrb    (r3)
  1085.     movl    #fprbuf,r0      ; Now print it
  1086.     jsb prstr
  1087.  
  1088.     rsb
  1089.  
  1090. ;
  1091. ; ." --if compiling, generate code to print a string, otherwise just
  1092. ;   print the string
  1093. ;
  1094. dotqbuf:
  1095.     .space  133
  1096. dotq2:  .long   fprn2,dotq1
  1097.     .word   0,Priority
  1098.     .byte   '.','"', 0
  1099.     
  1100. dotq1:  movl    #dotqbuf,r1
  1101.     cmpb    (r9),#32    ; Skip char if it's the separating blank
  1102.     bneq    dotq7
  1103.     incl    r9
  1104. dotq7:  movb    (r9)+,r0    ; get the next char of the string
  1105.     cmpb    #'"',r0     ; End string on newline or '"'
  1106.     beql    dotq4
  1107.     cmpb    #10,r0
  1108.     beql    dotq4
  1109.     tstb    r0      ; At end of current input buffer?
  1110.     beql    dotq5
  1111.     movb    r0,(r1)+    ;  No. Add this char to our output line
  1112.     brb dotq7
  1113. dotq5:  jsb getlin      ;  Yes. Get another buffer
  1114.     brb dotq7
  1115.  
  1116. dotq4:  clrb    (r1)        ; Make the resulting string NULL-terminated
  1117.     movl    #dotqbuf,r0 ; Point R0 to head of this string
  1118.     tstl    @#state     ; Check state
  1119.     beql    dotq3
  1120.  
  1121.     movw    #jsb_header,(r10)+ ; Compile in reference to (.")
  1122.     movl    #pdotq1,(r10)+
  1123. dotq6:  movb    (r0)+,(r10)+    ; Copy in the string
  1124.     bneq    dotq6
  1125.     rsb
  1126.  
  1127. dotq3:  jsb prstr       ; Print the string
  1128.     rsb
  1129.  
  1130. ;
  1131. ; (.")--run-time code to print a string
  1132. ;
  1133. pdotq2: .long   dotq2,pdotq1,0
  1134.     .byte    '(','.', '"',')', 0
  1135. pdotq1: movl    (sp)+,r0    ; Get the address of our return loc.
  1136.     jsb prstr       ; Print the string
  1137.     pushl   r2      ; Return to addr following string
  1138.     rsb
  1139.  
  1140. ;
  1141. ; "."--pop and print the top number on the stack
  1142. ;
  1143.     .space  14          ; Null-terminated string buffer
  1144. prnbuf: .byte   0
  1145. prnum2: .long   pdotq2,prnum1,0
  1146.     .asciz  "."
  1147. prnum1: movl    base,r5         ; Get the base
  1148.     movl    (r11)+,r0       ; R0 holds the number
  1149.     movl    #prnbuf,r1      ; R1 points to the char positions
  1150.     movl    r0,r2           ; Keep a copy to do the sign
  1151.     tstl    r0          ; Negate if negative
  1152.     bgeq    prnum3
  1153.     mnegl   r0,r0
  1154. prnum3: divl3   r5,r0,r3        ; R3 holds new number
  1155.     mull3   r5,r3,r4        ; Calculate remainder the hard way
  1156.     subl3   r4,r0,r4
  1157.     cmpl    r4,#9           ; See if it's a HEX digit
  1158.     bleq    prnu5
  1159.     .set a_offset 'a'-10
  1160.     addb3   #a_offset,r4,-(r1)
  1161.     brb prnu6
  1162. prnu5:  addb3   #'0',r4,-(r1)       ; Put it in as the next digit
  1163. prnu6:  movl    r3,r0           ; Update number
  1164.     tstl    r0
  1165.     bnequ   prnum3
  1166.     tstl    r2          ; Now check sign
  1167.     bgeq    prnum4
  1168.     movb    #'-',-(r1)
  1169. prnum4: movl    r1,r0           ; print the number
  1170.     jsb prstr
  1171.     rsb
  1172.  
  1173. ;
  1174. ; sin & cos (and the corresponding fsin & fcos)
  1175. ;
  1176. sintab:
  1177.     .long 0, 174, 348, 523, 697, 871, 1045, 1218, 1391, 1564, 1736
  1178.     .long 1908, 2079, 2249, 2419, 2588, 2756, 2923, 3090, 3255, 3420
  1179.     .long 3583, 3746, 3907, 4067, 4226, 4383, 4539, 4694, 4848, 5000
  1180.     .long 5150, 5299, 5446, 5591, 5735, 5877, 6018, 6156, 6293, 6427
  1181.     .long 6560, 6691, 6819, 6946, 7071, 7193, 7313, 7431, 7547, 7660
  1182.     .long 7771, 7880, 7986, 8090, 8191, 8290, 8386, 8480, 8571, 8660
  1183.     .long 8746, 8829, 8910, 8987, 9063, 9135, 9205, 9271, 9335, 9396
  1184.     .long 9455, 9510, 9563, 9612, 9659, 9702, 9743, 9781, 9816, 9848
  1185.     .long 9876, 9902, 9925, 9945, 9961, 9975, 9986, 9993, 9998, 10000
  1186.  
  1187. sin2:   .long   prnum2,sin1,0
  1188.     .asciz  "sin"
  1189. sin1:   movl    (r11)+,r0       ; Get angle
  1190.     clrl    r1          ; Negative quadrant flag
  1191. sin3:   tstl    r0          ; Fold negative angles
  1192.     bgeq    sin4
  1193.     addl2   #360,r0
  1194.     brb sin3
  1195. sin4:   cmpl    r0,#360         ; Fold angles > 360
  1196.     blss    sin5
  1197.     subl2   #360,r0
  1198.     brb sin4
  1199. sin5:   cmpl    r0,#181         ; Flag & fold negative quadrant vals
  1200.     blss    sin6
  1201.     movb    #-1,r1
  1202.     subl3   r0,#360,r0
  1203. sin6:   cmpl    r0,#91          ; Fold equivalent 2nd quadrant
  1204.     blss    sin7
  1205.     subl3   r0,#180,r0
  1206. sin7:   movl    sintab[r0],r0       ; Get the value
  1207.     tstl    r1          ; Negate if needed
  1208.     beql    sin8
  1209.     mnegl   r0,r0
  1210. sin8:   movl    r0,-(r11)       ; Push result
  1211.     rsb
  1212.  
  1213. cos2:   .long   sin2,cos1,0
  1214.     .asciz  "cos"
  1215. cos1:   subl3   (r11),#90,(r11)     ; sin(90-a) = cos(a)
  1216.     jsb sin1
  1217.     rsb
  1218.  
  1219. fsin2:  .long   cos2,fsin1,0
  1220.     .asciz  "fsin"
  1221. fsin1:  cvtfl   (r11),(r11)     ; Change to int & call sin
  1222.     jsb sin1
  1223.     cvtlf   (r11),r0
  1224.     divf3   #10000.0,r0,(r11)   ; Scale down to true float
  1225.     rsb
  1226.  
  1227. fcos2:  .long   fsin2,fcos1,0
  1228.     .asciz  "fcos"
  1229. fcos1:  cvtfl   (r11),(r11)     ; Change to int & call sin
  1230.     jsb cos1
  1231.     cvtlf   (r11),r0
  1232.     divf3   #10000.0,r0,(r11)   ; Scale down to true float
  1233.     rsb
  1234.  
  1235. ;
  1236. ; decimal--set FORTH's base to decimal
  1237. ;
  1238. decim2: .long   fcos2,decim1,0
  1239.     .asciz  "decimal"
  1240. decim1: cvtbl   #10,base
  1241.     rsb
  1242.  
  1243. ;
  1244. ; hex--set FORTH's base to hexadecimal
  1245. ;
  1246. hex2:   .long   decim2,hex1,0
  1247.     .asciz  "hex"
  1248. hex1:   cvtbl   #16,base
  1249.     rsb
  1250.  
  1251. ;
  1252. ; BASE variable--holds the current base
  1253. ;
  1254. base2:  .long   hex2,base1,0
  1255.     .asciz  "base"
  1256. base1:  movl    #base,-(r11)
  1257.     rsb
  1258. base:   .long   10
  1259.  
  1260. ;
  1261. ; STATE variable--0=interp, 1=compiling
  1262. ;
  1263. state2: .long   base2,state1,0
  1264.     .asciz  "state"
  1265. state1: movl    #state,-(r11)
  1266.     rsb
  1267. state:  .long   0
  1268.  
  1269. ;
  1270. ; isdig--return whether the first character in the current word is
  1271. ;   a numeric digit (watch out for HEX!)
  1272. ;
  1273. isdig:  movb    (r7),r3         ; Put the char in question into R3
  1274.     cmpb    r3,#48          ; Check for 0..9
  1275.     blss    isdig1
  1276.     cmpb    r3,#58
  1277.     blss    isdig2
  1278.     movl    r6,r4           ; The base comes into us in R6
  1279.     cmpl    r4,#11          ; For higher bases, check A..?
  1280.     blss    isdig1
  1281.     addl2   #54,r4          ; Change the base into the highest char
  1282.     cmpb    r3,#97          ; Map a..? to A..?
  1283.     blss    isdig3
  1284.     subb2   #32,r3
  1285. isdig3: cmpb    r3,#65          ; Check against 'A'
  1286.     blss    isdig1
  1287.     cmpb    r4,r3           ; Check against highest char
  1288.     blss    isdig1
  1289.     brb isdig2
  1290.  
  1291. isdig1: clrb    r3          ; KLUDGE to return NZ
  1292.     decb    r3
  1293.     rsb
  1294.  
  1295. isdig2: clrb    r3          ; Likewise for Z
  1296.     tstb    r3
  1297.     rsb
  1298.  
  1299. interp6: .asciz " ?Stack empty\n"
  1300. interp1:
  1301.     .long   state2,interp,0
  1302.     .asciz  "interp"
  1303. interp: cmpl    r11,stacklim        ; Check for underflow
  1304.     bleq    interp5
  1305.     movl    #interp6,r0     ; Underflowed. Complain & abort
  1306.     jsb prstr
  1307.     jbr abort
  1308. interp5:
  1309.     jsb getw            ; Get next word
  1310.     jsb lookup          ; In the dictionary?
  1311.     bneq    cknum           ;  No, see if it's a number
  1312.     tstb    state           ; Yes, either compile or execute
  1313.     bneq    interp2
  1314. interp4:
  1315.     jsb (r0)            ; execute via its address
  1316.     brb interp
  1317. interp2:
  1318.     bitl    #Priority,r1        ; See if it's immediate
  1319.     jnequ   interp4
  1320.     bitl    #Primitive,r1       ; See if it generates in-line code
  1321.     bnequ   interp7
  1322.     movw    #jsb_header,(r10)+  ; compile it with a "jsb" header
  1323.     movl    r0,(r10)+
  1324.     jbr interp 
  1325. interp7:
  1326.     cvtwl   8(r2),r1        ; Get number of bytes in def.
  1327. interp8:
  1328.     movb    (r0)+,(r10)+        ; Copy bytes of insructions
  1329.     decl    r1          ; See if done
  1330.     bnequ   interp8
  1331.     jbr interp
  1332.  
  1333. sign:   .space  1           ; Flags the sign
  1334. cknum:  movl    #wrd,r7         ; R7 is our index to the line
  1335.     clrb    sign            ; Take care of negative ;'s here
  1336.     cmpb    (r7),#'-'
  1337.     bneq    cknu1
  1338.     movb    #-1,sign
  1339.     incl    r7
  1340. cknu1:  movl    base,r6         ; Keep base in R6
  1341.     jsb isdig           ; Is this a number?
  1342.     jneq    badwrd          ;  No, complain
  1343.  
  1344.     clrl    r1
  1345. ckn1:   cvtbl   (r7)+,r0        ; Loop. Get next digit
  1346.     subl2   #'0',r0
  1347.     cmpl    r0,#10          ; Fix things up for HEX
  1348.     blss    ckn2
  1349.     subl2   #17,r0
  1350.     cmpl    r0,#6
  1351.     blss    ckn8            ; Turn R0 into the hex value
  1352.     subl2   #32,r0
  1353. ckn8:   addl2   #10,r0
  1354. ckn2:   mull2   r6,r1           ; Scale up R1, add in R0
  1355.     addl2   r0,r1
  1356.     jsb isdig           ; Loop if have more chars
  1357.     
  1358.     bneq    _1001
  1359.     jmp     ckn1
  1360. _1001:
  1361.  
  1362.     cmpb    #'.',(r7)+      ; If has decimal point, is floating pt.
  1363.     bneq    ckn4
  1364.     cvtlf   r1,r1
  1365.     movf    #0.1,r0     ; R0 is our scaling factor
  1366. ckn5:   jsb isdig           ; See if more digits
  1367.     bneq    ckn6
  1368.     subb3   #48,(r7)+,r2        ; Get next digit, convert to float num
  1369.     cvtbf   r2,r2
  1370.     mulf2   r0,r2           ; Scale by current factor
  1371.     addf2   r2,r1           ; Add it in to the current number
  1372.     divf2   #10.0,r0        ; Move our factor down one place
  1373.     brb ckn5
  1374. ckn6:   tstb    sign            ; Do negation if needed
  1375.     beql    cknu2
  1376.     mnegf   r1,r1
  1377.     brb cknu2
  1378.  
  1379. ckn4:   tstb    sign            ; negate if it started with '-'
  1380.     beql    cknu2
  1381.     mnegl   r1,r1
  1382.  
  1383. cknu2:  tstb    state           ; Compile or push this number
  1384.     .jneq   ckn3
  1385.     movl    r1,-(r11)
  1386.     jbr interp
  1387. ckn3:   movw    #lit_header,(r10)+  ; pushl #...
  1388.     movl    r1,(r10)+
  1389.     movb    #lit_tailer,(r10)+
  1390.     jbr interp
  1391.  
  1392. ;
  1393. ; badwrd--print the offending word, then call abort to restart the
  1394. ;   interpreter.
  1395. ;
  1396. dunno:  .asciz  ": not found\n"
  1397. badwrd: movl    #wrd,r0         ; First print the offending word
  1398.     jsb prstr
  1399.     movl    #dunno,r0       ; then, ": not found"
  1400.     jsb prstr
  1401.     jbr abort
  1402.  
  1403. ;
  1404. ; prstr--print the null-terminated string pointed to by r0 on STDOUT
  1405. ;
  1406. wrprm:  .long   3           ; Parm block for WRITE syscall
  1407. wrunit: .space  4   ; Output unit
  1408. wradr:  .space  4   ; BufAddr
  1409. wrcnt:  .space  4   ; Nbytes
  1410.  
  1411. prstr:  movl    ounit,wrunit        ; Set the output descriptor
  1412.     clrl    r1          ; Count the bytes -> R1
  1413.     movl    r0,wradr
  1414. prst1:  tstb    (r0)+
  1415.     .jeql   prst2
  1416.     incl    r1
  1417.     jbr prst1
  1418. prst2:  movl    r0,r2           ; Make next open addr. available in R2
  1419.     movl    r1,wrcnt
  1420.     movl    #wrprm,ap       ; Now do the syscall
  1421.     chmk    #4
  1422.     rsb
  1423.  
  1424. ;
  1425. ; lookup--take the current word in "wrd" and see if it's in the dictionary
  1426. ;   chain. If it is, return with address in R0 and Z; otherwise
  1427. ;   return with NZ. If it is found, R1 will contain the SF.
  1428. ;
  1429. lookup: movl    #wrd,r0         ; R0 -> word
  1430.     movl    r8,r1           ; R1 -> next entry to check against
  1431. look1:  addl3   #12,r1,r2       ; R2 -> cur entry's name
  1432.     movl    r0,r3           ; R3 -> our word
  1433.     bitw    #XSmudged,10(r1)        ; XSmudged?
  1434.     bnequ   look3
  1435.  
  1436. look2:  cmpb    (r3)+,(r2)      ; Compare the names
  1437.     bnequ   look3           ;  they didn't match
  1438.     tstb    (r2)+           ; They did; at end of names?
  1439.     bnequ   look2           ; No, keep going
  1440.  
  1441.     movl    4(r1),r0        ; We have a match. R0 -> entry
  1442.     movl    r1,r2           ; R2 -> top of entry
  1443.     cvtwl   10(r1),r1       ; R1 = (SFA)
  1444.     clrb    r3          ; Return Z
  1445.     tstb    r3
  1446.     rsb
  1447. look3:  movl    (r1),r1         ; Move to next entry
  1448.     tstl    r1
  1449.     bnequ   look1
  1450.     clrb    r0          ; No match, return NZ
  1451.     decb    r0
  1452.     rsb
  1453.  
  1454. ;
  1455. ; iswhite--return whether the character pointed to by R9 is a white
  1456. ;   space character
  1457. ;
  1458. iswhite:
  1459.     movb    (r9),r3         ; Keep this char in register
  1460.     cmpb    #Tab,r3     ; Tab
  1461.     jeql    iswh1
  1462.     cmpb    #Spc,r3     ; Space
  1463.     jeql    iswh1
  1464.     cmpb    #NL,r3      ; Newline
  1465.     jeql    iswh1
  1466.     tstb    r3      ; NULL
  1467. iswh1:  rsb
  1468.  
  1469. ;
  1470. ; getlin--read another line of input from the current input file descriptor.
  1471. ;   Note that we do some fancy things here to allow either a file or a TTY
  1472. ;   to be read equivalently (and with reasonable efficiency). Namely,
  1473. ;   installing NULLS at the end of buffers, and reading (potentially) a
  1474. ;   full disk block from the input file descriptor.
  1475. ;
  1476. rdprm:  .long   3
  1477. rdunit: .space  4
  1478.     .long   inline,1024
  1479. prompt: .asciz  "> "
  1480. getlin: movl    iunit,r0        ; Get the input unit, put it in the
  1481.     movl    r0,rdunit       ;  the read area, prompt if ==0
  1482.     tstl    r0
  1483.     bneq    getl2
  1484.     movl    #prompt,r0
  1485.     jsb prstr
  1486. getl2:  movl    #rdprm,ap       ; Read a block
  1487.     chmk    #3
  1488.     tstl    r0          ; Test for EOF
  1489.     .jeql   getl1
  1490.     clrb    inline(r0)      ; Terminate the buffer with NULL
  1491.     movl    #inline,r9      ; Set the input line pointer
  1492.     rsb
  1493.  
  1494. getl1:  decl    ideep       ; Decrement nesting depth count
  1495.     movl    #256,r2     ; R2 is the number of bytes to move
  1496.     movl    ideep,r0
  1497.     mull2   #1024,r0
  1498.     addl2   #ibufs,r0   ; R0 now points to our save location
  1499.     movl    #inline,r1  ; R1 points to the buffer to restore
  1500. getl3:  movl    (r0)+,(r1)+ ; Move the bytes
  1501.     sobgtr  r2,getl3
  1502.     movl    ideep,r0    ; Now save the input index
  1503.     movl    ibufx[r0],r9
  1504.  
  1505.     movl    iunit,outp3     ; EOF--Close the unit
  1506.     movl    #outp4,ap
  1507.     chmk    #6
  1508.     movl    isp,r0          ; If we're not at top, pop item
  1509.     cmpl    r0,#istk
  1510.     .jeql   exit            ; If at top, forth exits
  1511.     subl2   #4,r0
  1512.     movl    r0,isp
  1513.     movl    (r0),iunit
  1514.     rsb             ; Return with the restored input buffer
  1515.  
  1516. ;
  1517. ; getw--get the next word in the current input line. If there are no
  1518. ;   more words in this line, get another from the input
  1519. ;
  1520. getw:   jsb iswhite         ; Skip initial white space
  1521.     bnequ   getw1
  1522.     tstb    (r9)+           ; Is white. If NULL, need new line
  1523.     bnequ   getw
  1524.     jsb getlin
  1525.     brb getw
  1526. getw1:  movl    #wrd,r0         ; Found word. Copy into "wrd"
  1527. getw2:  movb    (r9)+,(r0)+
  1528. getw4:  jsb iswhite
  1529.     bnequ   getw2
  1530.     tstb    (r9)            ; Read new buffer if at end
  1531.     bneq    getw5
  1532.     pushl   r0          ; Save R0, then call "getlin"
  1533.     jsb getlin
  1534.     movl    (sp)+,r0
  1535.     brb getw4
  1536. getw5:  clrb    (r0)            ; add NULL at end of word
  1537.     rsb
  1538. dictend:    .long   exe$forth_dict  ; Initially here
  1539. exe$forth_dict:
  1540.     .space  30000           ; Dictionary space
  1541.     .console clear sym/temp
  1542.     .console set radix hex
  1543. ;    .region p0
  1544.     
  1545.