home *** CD-ROM | disk | FTP | other *** search
/ GEMini Atari / GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso / files / language / forst / shell.s < prev    next >
Encoding:
Text File  |  1993-10-23  |  9.3 KB  |  340 lines
  1. ; SHELL.S: Forth kernel routines, version 1.22
  2. ; Copyright <C> John Redmond 1989,1990
  3. ; Public domain for non-commercial use.
  4. ;
  5.         section text
  6.         even
  7. ;
  8. ;
  9. ;system vectors:
  10. ;
  11. vectors:
  12. tonumber: offs  _number
  13.         dc.l    0
  14. todot:  offs    _dot
  15.         dc.l    0
  16. toadd:  offs    _add
  17.         dc.l    $e0042d00
  18. tosub:  offs    _sub
  19.         dc.l    $e0052d00
  20. tomult: offs    _mult
  21.         dc.l    0
  22. todiv:  offs    _div
  23.         dc.l    0
  24. tomod:  offs    _mod
  25.         dc.l    0
  26. toabs:  offs    _abs
  27.         dc.l    0
  28. tonegate: offs  _negate
  29.         dc.l    $a0032d00
  30. ;
  31. toexpect: offs  _expect
  32.         dc.l    0
  33. toword: offs    _word
  34.         dc.l    0
  35. tofind: offs    _bfind
  36.         dc.l    0
  37. ;
  38. doword: move.l  toword(pc),d0
  39.         jsr     (a5,d0.l)
  40.         rts
  41. dofind: move.l  tofind(pc),d0
  42.         jsr     (a5,d0.l)
  43.         rts
  44. ;
  45. ;*******************************************************;
  46. ;                                                       ;
  47. ;       The ForST outer interpreter                     ;
  48. ;                                                       ;
  49. ;*******************************************************;
  50. outer:  bsr     prompt
  51.         bsr     _query
  52.         bsr     _interpret
  53.         bra.s   outer
  54. ;
  55. _query: lea     dstack,a0       ;keyboard buffer above data stack
  56.         move.l  (a0),a0
  57.         lea     tib,a1
  58.         move.l  a0,(a1)
  59.         move.l  #(kbuffsiz-3),d0 ;avoid a line wrap for input
  60.         movem.l d0/a0,-(a6)
  61. .q5:    bsr     _ekey
  62.         cmp.w   #$4800,d0       ;an up arrow?
  63.         beq.s   .again
  64.         tst.l   d1
  65.         bmi.s   .q5             ;not a valid char
  66.         cmp.w   #$1c0d,d0
  67.         beq.s   .quit           ;carriage return
  68.         move.l  4(a6),a0
  69.         move.b  d0,(a0)         ;char into buffer
  70.         push    #1
  71.         bra.s   .in5
  72. .again: lea     oldlen,a0       ;same input as before
  73.         push    (a0)            ;#chars input before
  74. .in5:   bsr     re_expect
  75.         lea     span,a0
  76.         move.l  (a0),d0
  77. .in7:   lea     htib,a1
  78.         move.l  d0,(a1)         ;length of new input
  79.         lea     oldlen,a1       ;a reserve copy
  80.         move.l  d0,(a1)
  81.         lea    toin,a1
  82.         clr.l    (a1)        ;start with zero offset
  83.         rts
  84. .quit:  lea     8(a6),a6        ;drop parms
  85.         moveq.l #0,d0           ;no chars input
  86.         bra.s   .in7
  87. ;
  88. prompt: bsr     _cret
  89.         bsr     _getdrv
  90.         add.l   #'A',(a6)
  91.         bsr     _conout
  92.         push    #'>'
  93.         bsr     _conout
  94.         rts
  95. ;
  96. _interpret:
  97.         bsr.s   getword
  98.         move.l  (a6),a0
  99.         tst.b   (a0)
  100.         beq.s   .intx           ;stop on zero length
  101.         bsr.s   process_word
  102.         bra.s   _interpret
  103. .intx:  addq.l  #4,a6           ;drop ^pocket
  104.         bsr     popin           ;else denest files
  105.         bne.s   _interpret      ;if no keyboard input needed
  106. .inx:   rts
  107. ;
  108. getword: push   #32
  109.         bsr     doword
  110.         rts
  111. ;
  112. process_word:
  113.         bsr     dofind
  114.         pop     d0              ;test flag
  115.         beq.s   .not_there
  116.         push    d0              ;replace flag for sign test
  117.         bsr     action
  118.         rts
  119. .not_there:
  120.         move.l  tonumber(pc),d0
  121.         jsr     (a5,d0.l)
  122.         bsr     stateat
  123.         beq.s   .pwx
  124.         bsr     _literal
  125. .pwx:   rts
  126. ;
  127. ; _WORD: (char--addr) Fetch a word from the input stream and return
  128. ; it with a space terminator with address in POCKET.
  129. _word:  movem.l d2/a2-a3,-(a7)
  130.         bsr     _there
  131.         add.l   #$400,(a6)      ;scratch space above heads
  132.         lea     pocket,a1
  133.         move.l  (a6),a0
  134.         move.l  a0,(a1)         ;save pointer in pocket
  135.         clr.l   -(a6)           ;character count
  136.         addq.l  #1,a0           ;first address for a char
  137.         move.l  a0,-(a6)        ;pointer to next char in buffer
  138. .wd1:   bsr     inchar          ;get character from stream
  139.         pop     d1              ;fetch char
  140.         bmi.s   .wdx            ;finish if negative
  141.         move.l  12(a6),d2       ;copy delimiter
  142.         cmp.b   #32,d2          ;is delimiter a space?
  143.         bne.s   .wd2            ;if not, start assembling string
  144.         cmp.b   d1,d2
  145.         beq.s   .wd1            ;skip it if = delimiter
  146.         cmp.b   #13,d1
  147.         beq.s   .wd1            ;CR = white space
  148.         cmp.b   #10,d1
  149.         beq.s   .wd1            ;LF = white space
  150.         cmp.b   #9,d1
  151.         beq.s   .wd1            ;TAB = white space
  152. .wd2:   movem.l (a6)+,a0/a1     ;get pointer and count
  153.         move.b  d1,(a0)+        ;store in
  154.         addq.l  #1,a1           ;bump count
  155.         movem.l a0/a1,-(a6)     ;save pointer and count
  156.         bsr     inchar          ;another character
  157.         pop     d1              ;fetch char
  158.         bmi.s   .wdx            ;quit if no more chars
  159.         move.l  12(a6),d2       ;copy delimiter
  160.         cmp.b   d1,d2           ;is char = delimiter?
  161.         beq.s   .wdx
  162.         cmp.b   #32,d2          ;is delimiter a space?
  163.         bne.s   .wd2            ;if not, get another char
  164.         cmp.b   #9,d1           ;just fetched a TAB?
  165.         beq.s   .wdx
  166.         cmp.b   #10,d1          ;just fetched a CR?
  167.         beq.s   .wdx
  168.         cmp.b   #13,d1          ;just fetched a LF?
  169.         bne.s   .wd2
  170. .wdx:   movem.l (a6)+,a0-a3     ;a0=^nextch,a1=#chars,a2=^start,a3=delim
  171.         move.b  #32,(a0)+       ;space terminator
  172.         clr.b   (a0)            ;and a null!
  173.         move.l  a1,d0           ;word length
  174.         move.b  d0,(a2)         ;store it at string start
  175.         move.l  a2,-(a6)        ;return address of pocket
  176.         movem.l (a7)+,d2/a2-a3
  177.         rts
  178. ;
  179. _abort: move.l  dstack(pc),a6
  180.     bsr    _there
  181.     lea    entry,a0
  182.     pop    (a0)        ;give FIND a reasonable entry
  183. _quit:  move.l  stack(pc),a7
  184.         bsr     clrin           ;back to keyboard input
  185.         lea     lpstkptr,a0
  186.         move.l  a0,(a0)         ;clear system stacks
  187.         bra     warm
  188. ;
  189. _head:  bsr     name            ;returns cfa
  190.         bsr     dofind
  191.         pop     d0
  192.         bne.s   .ok
  193.         lea     werror,a0
  194.         bra     _error
  195. .ok:    rts
  196. ;
  197. _compcomma: bsr _head
  198.         pop     a0
  199.         push    -(a0)
  200.         push    8(a0)
  201.         bsr     _lcomma
  202.         bsr     _lcomma
  203.         rts
  204. ;
  205. _tick:  bsr     _head
  206.         pop     a0
  207.         bsr     codehead
  208.         beq.s   .t5
  209.         move.l  4(a0),d0
  210.         add.l   a5,d0           ;convert offset to address
  211.         bra.s   .tx
  212. .t5:    moveq   #0,d0           ;return zero for a constant's address
  213. .tx:    push    d0
  214.         rts
  215. ;
  216. _forget: bsr    _head
  217.         move.l  (a6),a0
  218.         lea     fence,a1
  219.         cmp.l   (a1),a0
  220.         bcc.s   .fgx
  221.         lea     fgerror,a0
  222.         bra     _error
  223. .fgx:   bsr     discard
  224.         rts
  225. ;
  226. ; _SKIP: (char--#chars)
  227. ; Fetch chars from the input stream until a specified char encountered.
  228. _skip:  push    #0              ;character count
  229. .sk1:   bsr     inchar          ;another character
  230.         pop     d0              ;fetch char
  231.         bmi.s   .skx            ;quit if no more chars
  232.         add.l   #1,(a6)         ;increase count
  233.         move.l  4(a6),d1        ;copy delimiter
  234.         cmp.b   d0,d1
  235.         bne.s   .sk1
  236. .skx:   move.l  (a6)+,(a6)      ;return #chars skipped
  237.         rts
  238. ;
  239. _rbra:  push    #41             ;')'
  240.         bsr     _skip
  241.         addq.l  #4,a6
  242.         rts
  243. ;
  244. _bslash: push   #10             ;LF
  245.         bsr     _skip
  246.         addq.l  #4,a6
  247. _noop:  rts
  248. ;
  249.         section data
  250.         even
  251. ;
  252.         dc.b    $86,'SYSTEM',$a0
  253.         ptrs    _system,20
  254. ;
  255.         dc.b    $84,'SAVE',$a0
  256.         ptrs    _save,18
  257. ;
  258.         dc.b    $85,'STAR','T'!$80
  259.         ptrs    _noop,18
  260. ;
  261.         dc.b    $89,'INTERPRE','T'!$80
  262.         ptrs    _interpret,22
  263. ;
  264.         dc.b    $85,'QUER','Y'!$80
  265.         ptrs    _query,18
  266. ;
  267.         dc.b    $85,'ABOR','T'!$80
  268.         ptrs    _abort,18
  269. ;
  270.         dc.b    $84,'UPTO',$a0
  271.         ptrs    _skip,18
  272. ;
  273.         dc.b    $c1,'('!$80
  274.         ptrs    _rbra,14
  275. ;
  276.         dc.b    $c1,'\'!$80
  277.         ptrs    _bslash,14
  278. ;
  279.         dc.b    $81,39!$80
  280.         ptrs    _tick,14
  281. ;
  282.         dc.b    $c5,"'HEA","D"!$80
  283.         ptrs    _head,18
  284. ;
  285.         dc.b    $c4,'HEAD',$a0
  286.         ptrs    _head,18
  287. ;
  288.         dc.b    $c5,"COMP",","!$80
  289.         ptrs    _compcomma,18
  290. ;
  291.         dc.b    $86,'FORGET',$a0
  292.         ptrs    _forget,20
  293. ;
  294.         dc.b    $84,'QUIT',$a0
  295.         ptrs    _quit,18
  296. ;
  297.         dc.b    $84,'NOOP',$a0
  298.         ptrs    _noop,18
  299. ;
  300.         dc.b    $c7,'VECTOR','S'!$80
  301.         vptrs   vectors,20
  302. ;
  303. ; vectored words:
  304. ;
  305.         dc.b    $c6,'EXPECT',$a0
  306.         vectptrs toexpect,20
  307. ;
  308.         dc.b    $c4,'WORD',$a0
  309.         vectptrs toword,18
  310. ;
  311.         dc.b    $c4,'FIND',$a0
  312.         vectptrs tofind,18
  313. ;
  314.         dc.b    $c6,'NUMBER',$a0
  315.         vectptrs tonumber,20
  316. ;
  317.         dc.b    $c1,'.'!$80
  318.         vectptrs todot,14
  319. ;
  320.         dc.b    $c1,'+'!$80
  321.         vectptrs toadd,14
  322. ;
  323.         dc.b    $c1,'-'!$80
  324.         vectptrs tosub,14
  325. ;
  326.         dc.b    $c1,'*'!$80
  327.         vectptrs tomult,14
  328. ;
  329.         dc.b    $c1,'/'!$80
  330.         vectptrs todiv,14
  331. ;
  332.         dc.b    $c3,'MO','D'!$80
  333.         vectptrs tomod,16
  334. ;
  335.         dc.b    $c3,'AB','S'!$80
  336.         vectptrs toabs,16
  337. ;
  338.         dc.b    $c6,'NEGATE',$a0
  339.         vectptrs tonegate,20
  340.