Annotation of gforth/kernal.fs, revision 1.2

1.1       anton       1: \ KERNAL.FS    ANS figFORTH kernal                     17dec92py
                      2: \ $ID:
                      3: \ Idea and implementation: Bernd Paysan (py)
                      4: \ Copyright 1992 by the ANSI figForth Development Group
                      5: 
                      6: \ Log:  ', '- usw. durch [char] ... ersetzt
                      7: \       man sollte die unterschiedlichen zahlensysteme
                      8: \       mit $ und & zumindest im interpreter weglassen
                      9: \       schon erledigt!
                     10: \       11may93jaw
                     11: \ name>         0= nicht vorhanden              17may93jaw
                     12: \               nfa can be lfa or nfa!
                     13: \ find          splited into find and (find)
                     14: \               (find) for later use            17may93jaw
                     15: \ search        replaced by lookup because
                     16: \               it is a word of the string wordset
                     17: \                                               20may93jaw
                     18: \ postpone      added immediate                 21may93jaw
                     19: \ to            added immediate                 07jun93jaw
                     20: \ cfa, header   put "here lastcfa !" in
                     21: \               cfa, this is more logical
                     22: \               and noname: works wothout
                     23: \               extra "here lastcfa !"          08jun93jaw
                     24: \ (parse-white) thrown out
                     25: \ refill        added outer trick
                     26: \               to show there is something
                     27: \               going on                        09jun93jaw
                     28: \ leave ?leave  somebody forgot UNLOOP!!!       09jun93jaw
                     29: \ leave ?leave  unloop thrown out
                     30: \               unloop after loop is used       10jun93jaw
                     31: 
                     32: HEX
                     33: 
                     34: \ Bit string manipulation                              06oct92py
                     35: 
                     36: Create bits  80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
                     37: DOES> ( n -- )  + c@ ;
                     38: 
                     39: : >bit  ( addr n -- c-addr mask )  8 /mod rot + swap bits ;
                     40: : +bit  ( addr n -- )  >bit over c@ or swap c! ;
                     41: 
                     42: : relinfo ( -- addr )  forthstart dup @ + ;
                     43: : >rel  ( addr -- n )  forthstart - ;
                     44: : relon ( addr -- )  relinfo swap >rel cell / +bit ;
                     45: 
                     46: \ here allot , c, A,                                   17dec92py
                     47: 
                     48: : here  ( -- here )  dp @ ;
                     49: : allot ( n -- )     dp +! ;
                     50: : c,    ( c -- )     here 1 chars allot c! ;
                     51: : ,     ( x -- )     here cell allot  ! ;
                     52: : 2,    ( w1 w2 -- ) \ general
                     53:     here 2 cells allot 2! ;
                     54: 
                     55: : aligned ( addr -- addr' )
                     56:   [ cell 1- ] Literal + [ -1 cells ] Literal and ;
                     57: : align ( -- )          here dup aligned swap ?DO  bl c,  LOOP ;
                     58: 
                     59: : A!    ( addr1 addr2 -- )  dup relon ! ;
                     60: : A,    ( addr -- )     here cell allot A! ;
                     61: 
                     62: \ on off                                               23feb93py
                     63: 
                     64: : on  ( addr -- )  true  swap ! ;
                     65: : off ( addr -- )  false swap ! ;
                     66: 
                     67: \ name> found                                          17dec92py
                     68: 
                     69: : (name>)  ( nfa -- cfa )    count  $1F and  +  aligned ;
                     70: : name>    ( nfa -- cfa )
                     71:   dup  (name>) swap  c@ $80 and 0= IF  @ THEN ;
                     72: 
                     73: : found ( nfa -- cfa n )  cell+
                     74:   dup c@ >r  (name>) r@ $80 and  0= IF  @       THEN
                     75: \                  -1 r@ $40 and     IF  1-      THEN
                     76:                   -1 r> $20 and     IF  negate  THEN  ;
                     77: 
                     78: \ (find)                                               17dec92py
                     79: 
                     80: \ : (find) ( addr count nfa1 -- nfa2 / false )
                     81: \   BEGIN  dup  WHILE  dup >r
                     82: \          cell+ count $1F and dup >r 2over r> =
                     83: \          IF  -text  0= IF  2drop r> EXIT  THEN
                     84: \          ELSE  2drop drop  THEN  r> @
                     85: \   REPEAT nip nip ;
                     86: 
                     87: \ place bounds                                         13feb93py
                     88: 
                     89: : place  ( addr len to -- ) over >r  rot over 1+  r> move c! ;
                     90: : bounds ( beg count -- end beg )  over + swap ;
                     91: 
                     92: \ input stream primitives                              23feb93py
                     93: 
                     94: : tib   >tib @ ;
                     95: Defer source
                     96: : (source) ( -- addr count ) tib #tib @ ;
                     97: ' (source) IS source
                     98: 
                     99: \ (word)                                               22feb93py
                    100: 
                    101: : scan   ( addr1 n1 char -- addr2 n2 )  >r
                    102:   BEGIN  dup  WHILE  over c@ r@ <>  WHILE  1 /string
                    103:   REPEAT  THEN  rdrop ;
                    104: : skip   ( addr1 n1 char -- addr2 n2 )  >r
                    105:   BEGIN  dup  WHILE  over c@ r@  =  WHILE  1 /string
                    106:   REPEAT  THEN  rdrop ;
                    107: 
                    108: : (word) ( addr1 n1 char -- addr2 n2 )
                    109:   dup >r skip 2dup r> scan  nip - ;
                    110: 
                    111: \ (word) should fold white spaces
                    112: \ this is what (parse-white) does
                    113: 
                    114: \ word parse                                           23feb93py
                    115: 
                    116: : parse-word  ( char -- addr len )
                    117:   source 2dup >r >r >in @ /string
                    118:   rot dup bl = IF  drop (parse-white)  ELSE  (word)  THEN
                    119:   2dup + r> - 1+ r> min >in ! ;
                    120: : word   ( char -- addr )
                    121:   parse-word here place  bl here count + c!  here ;
                    122: 
                    123: : parse    ( char -- addr len )
                    124:   >r  source  >in @ /string  over  swap r>  scan >r
                    125:   over - dup r> IF 1+ THEN  >in +! ;
                    126: 
                    127: \ name                                                 13feb93py
                    128: 
                    129: : capitalize ( addr -- addr )
                    130:   dup count chars bounds
                    131:   ?DO  I c@ toupper I c! 1 chars +LOOP ;
                    132: : (name)  ( -- addr )  bl word ;
                    133: 
                    134: \ Literal                                              17dec92py
                    135: 
                    136: : Literal  ( n -- )  state @ 0= ?EXIT  postpone lit  , ;
                    137:                                                       immediate
                    138: : ALiteral ( n -- )  state @ 0= ?EXIT  postpone lit A, ;
                    139:                                                       immediate
                    140: 
                    141: : char   ( 'char' -- n )  bl word char+ c@ ;
                    142: : [char] ( 'char' -- n )  char postpone Literal ; immediate
                    143: ' [char] Alias Ascii immediate
                    144: 
                    145: : (compile) ( -- )  r> dup cell+ >r @ A, ;
                    146: : postpone ( "name" -- )
                    147:   name find dup 0= abort" Can't compile "
                    148:   0> IF  A,  ELSE  postpone (compile) A,  THEN ;
                    149:                                              immediate restrict
                    150: 
                    151: \ Use (compile) for the old behavior of compile!
                    152: 
                    153: \ digit?                                               17dec92py
                    154: 
                    155: : digit?   ( char -- digit true/ false )
                    156:   base @ $100 = ?dup ?EXIT
                    157:   toupper [char] 0 - dup 9 u> IF
                    158:     [ 'A '9 1 + -  ] literal -
                    159:     dup 9 u<= IF
                    160:       drop false EXIT
                    161:     THEN
                    162:   THEN
                    163:   dup base @ u>= IF
                    164:     drop false EXIT
                    165:   THEN
                    166:   true ;
                    167: 
                    168: : accumulate ( +d0 addr digit - +d1 addr )
                    169:   swap >r swap  base @  um* drop rot  base @  um* d+ r> ;
                    170: : >number ( d addr count -- d addr count )
                    171:   0 ?DO  count digit? WHILE  accumulate  LOOP 0
                    172:   ELSE  1- I' I - UNLOOP  THEN ;
                    173: 
                    174: \ number? number                                       23feb93py
                    175: 
                    176: Create bases   10 ,   2 ,   A , 100 ,
                    177: \              16     2    10   Zeichen
                    178: \ !! this saving and restoring base is an abomination! - anton
                    179: : getbase ( addr u -- addr' u' )  over c@ [char] $ - dup 4 u<
                    180:   IF  cells bases + @ base ! 1 /string  ELSE  drop  THEN ;
                    181: : number?  ( string -- string 0 / n -1 )  base @ >r
                    182:   dup count over c@ [char] - = dup >r  IF 1 /string  THEN
                    183:   getbase  dpl on  0 0 2swap
                    184:   BEGIN  dup >r >number dup  WHILE  dup r> -  WHILE
                    185:          dup dpl ! over c@ [char] . =  WHILE
                    186:          1 /string
                    187:   REPEAT  THEN  2drop 2drop rdrop false r> base ! EXIT  THEN
                    188:   2drop rot drop rdrop r> IF dnegate THEN
                    189:   dpl @ dup 0< IF  nip  THEN  r> base ! ;
                    190: : s>d ( n -- d ) dup 0< ;
                    191: : number ( string -- d )
                    192:   number? ?dup 0= abort" ?"  0< IF s>d THEN ;
                    193: 
                    194: \ space spaces ud/mod                                  21mar93py
                    195: decimal
                    196: Create spaces  bl 80 times \ times from target compiler! 11may93jaw
                    197: DOES>   ( u -- )  swap
                    198:         0 max 0 ?DO  I' I - &80 min 2dup type  +LOOP  drop ;
                    199: hex
                    200: : space   1 spaces ;
                    201: 
                    202: : ud/mod ( ud1 u2 -- urem udquot )  >r 0 r@ um/mod r> swap >r
                    203:                                     um/mod r> ;
                    204: 
                    205: : pad    ( -- addr )
                    206:   here [ $20 8 2* cells + 2 + cell+ ] Literal + aligned ;
                    207: 
                    208: \ hold <# #> sign # #s                                 25jan92py
                    209: 
                    210: : hold    ( char -- )         pad cell - -1 chars over +! @ c! ;
                    211: 
                    212: : <#                          pad cell - dup ! ;
                    213: 
                    214: : #>      ( 64b -- addr +n )  2drop pad cell - dup @ tuck - ;
                    215: 
                    216: : sign    ( n -- )            0< IF  [char] - hold  THEN ;
                    217: 
                    218: : #       ( +d1 -- +d2 )    base @ 2 max ud/mod rot 9 over <
                    219:   IF [ char A char 9 - 1- ] Literal +  THEN  [char] 0 + hold ;
                    220: 
                    221: : #s      ( +d -- 0 0 )         BEGIN  # 2dup d0=  UNTIL ;
                    222: 
                    223: \ print numbers                                        07jun92py
                    224: 
                    225: : d.r      >r tuck  dabs  <# #s  rot sign #>
                    226:            r> over - spaces  type ;
                    227: 
                    228: : ud.r     >r <# #s #> r> over - spaces type ;
                    229: 
                    230: : .r       >r s>d r> d.r ;
                    231: : u.r      0 swap ud.r ;
                    232: 
                    233: : d.       0 d.r space ;
                    234: : ud.      0 ud.r space ;
                    235: 
                    236: : .        s>d d. ;
                    237: : u.       0 ud. ;
                    238: 
                    239: \ catch throw                                          23feb93py
                    240: \ bounce                                                08jun93jaw
                    241: 
                    242: \ !! what about the other stacks (FP, locals)  anton
                    243: \ !! allow the user to add rollback actions    anton
                    244: \ !! use a separate exception stack?           anton
                    245: 
                    246: : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error )
                    247:   >r sp@ r> swap        \ don't count xt! jaw
                    248:   >r handler @ >r rp@ handler ! execute
                    249:   r> handler ! rdrop 0 ;
                    250: : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn )
                    251:   dup 0= IF  drop EXIT  THEN
                    252:   handler @ rp!  r> handler ! r> swap >r sp! r> ;
                    253: \ Bouncing is very fine,
                    254: \ programming without wasting time...   jaw
                    255: : bounce ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn )
                    256: \ a throw without data stack restauration? anton !! stack diagram bad
                    257:   dup 0= IF  drop EXIT  THEN
                    258:   handler @ rp!  r> handler ! r> drop ;
                    259: 
                    260: \ ?stack                                               23feb93py
                    261: 
                    262: : ?stack ( ?? -- ?? )  sp@ s0 @ > IF  -4 throw  THEN ;
                    263: \ ?stack should be code -- it touches an empty stack!
                    264: 
                    265: \ interpret                                            10mar92py
                    266: 
                    267: Defer parser
                    268: Defer name      ' (name) IS name
                    269: Defer notfound
                    270: 
1.2     ! pazsan    271: : no.extensions  ( string -- )  IF  &-13 bounce  THEN ;
1.1       anton     272: 
                    273: ' no.extensions IS notfound
                    274: 
                    275: : interpret
                    276:   BEGIN  ?stack name dup c@  WHILE  parser  REPEAT drop ;
                    277: 
                    278: \ interpreter compiler                                 30apr92py
                    279: 
                    280: : interpreter  ( name -- ) find ?dup
                    281:   IF  1 and  IF execute  EXIT THEN  -&14 throw  THEN
                    282:   number? 0= IF  notfound THEN ;
                    283: 
                    284: ' interpreter  IS  parser
                    285: 
                    286: : compiler     ( name -- ) find  ?dup
                    287:   IF  0> IF  execute EXIT THEN compile, EXIT THEN number? dup
                    288:   IF  0> IF  swap postpone Literal  THEN  postpone Literal
1.2     ! pazsan    289:   ELSE  drop notfound  THEN ;
1.1       anton     290: 
                    291: : [     ['] interpreter  IS parser state off ; immediate
                    292: : ]     ['] compiler     IS parser state on  ;
                    293: 
                    294: \ Structural Conditionals                              12dec92py
                    295: 
                    296: : ?struc      ( flag -- )       abort" unstructured " ;
                    297: : sys?        ( sys -- )        dup 0= ?struc ;
                    298: : >mark       ( -- sys )        here  0 , ;
                    299: : >resolve    ( sys -- )        here over - swap ! ;
                    300: : <resolve    ( sys -- )        here - , ;
                    301: 
                    302: : BUT       sys? swap ;                      immediate restrict
                    303: : YET       sys? dup ;                       immediate restrict
                    304: 
                    305: \ Structural Conditionals                              12dec92py
                    306: 
                    307: : AHEAD     postpone branch >mark ;           immediate restrict
                    308: : IF        postpone ?branch >mark ;          immediate restrict
                    309: : ?DUP-IF \ general
                    310: \ This is the preferred alternative to the idiom "?DUP IF", since it can be
                    311: \ better handled by tools like stack checkers
                    312:     postpone ?dup postpone IF ;       immediate restrict
                    313: : ?DUP-NOT-IF \ general
                    314:     postpone ?dup postpone 0= postpone if ; immediate restrict
                    315: : THEN      sys? dup @ ?struc >resolve ;     immediate restrict
                    316: ' THEN alias ENDIF immediate restrict \ general
                    317: \ Same as "THEN". This is what you use if your program will be seen by
                    318: \ people who have not been brought up with Forth (or who have been
                    319: \ brought up with fig-Forth).
                    320: 
                    321: : ELSE      sys? postpone AHEAD swap postpone THEN ;
                    322:                                              immediate restrict
                    323: 
                    324: : BEGIN     here ;                           immediate restrict
                    325: : WHILE     sys? postpone IF swap ;           immediate restrict
                    326: : AGAIN     sys? postpone branch  <resolve ;  immediate restrict
                    327: : UNTIL     sys? postpone ?branch <resolve ;  immediate restrict
                    328: : REPEAT    over 0= ?struc postpone AGAIN postpone THEN ;
                    329:                                              immediate restrict
                    330: 
                    331: \ Structural Conditionals                              12dec92py
                    332: 
                    333: Variable leavings
                    334: 
                    335: : (leave)   here  leavings @ ,  leavings ! ;
                    336: : LEAVE     postpone branch  (leave) ;  immediate restrict
                    337: : ?LEAVE    postpone 0= postpone ?branch  (leave) ;
                    338:                                              immediate restrict
                    339: 
                    340: : DONE   ( addr -- )  leavings @
                    341:   BEGIN  2dup u<=  WHILE  dup @ swap >resolve  REPEAT
                    342:   leavings ! drop ;                          immediate restrict
                    343: 
                    344: \ Structural Conditionals                              12dec92py
                    345: 
                    346: : DO        postpone (do)   here ;            immediate restrict
                    347: 
                    348: : ?DO       postpone (?do)  (leave) here ;
                    349:                                              immediate restrict
                    350: : FOR       postpone (for)  here ;            immediate restrict
                    351: 
                    352: : loop]     dup <resolve 2 cells - postpone done postpone unloop ;
                    353: 
                    354: : LOOP      sys? postpone (loop)  loop] ;     immediate restrict
                    355: : +LOOP     sys? postpone (+loop) loop] ;     immediate restrict
                    356: : S+LOOP \ general
                    357: \ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP" will iterate as often as "high low ?DO inc S+LOOP". For positive increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for negative increments.
                    358:     sys? postpone (s+loop) loop] ;    immediate restrict
                    359: : NEXT      sys? postpone (next)  loop] ;     immediate restrict
                    360: 
                    361: \ Strings                                              22feb93py
                    362: 
                    363: : ," ( "string"<"> -- ) [char] " parse
                    364:   here over char+ allot  place align ;
                    365: : "lit ( -- addr )
                    366:   r> r> dup count + aligned >r swap >r ;               restrict
                    367: : (.")     "lit count type ;                           restrict
                    368: : (S")     "lit count ;                                restrict
                    369: : SLiteral postpone (S") here over char+ allot  place align ;
                    370:                                              immediate restrict
                    371: : S"       [char] " parse  state @ IF  postpone SLiteral  THEN ;
                    372:                                              immediate
                    373: : ."       state @  IF    postpone (.") ,"  align
                    374:                     ELSE  [char] " parse type  THEN  ;  immediate
                    375: : (        [char] ) parse 2drop ;                       immediate
                    376: : \        source >in ! drop ;                          immediate
                    377: 
                    378: \ error handling                                       22feb93py
                    379: \ 'abort thrown out!                                   11may93jaw
                    380: 
                    381: : (abort")      "lit >r IF  r> "error ! -2 throw  THEN
                    382:                 rdrop ;
                    383: : abort"        postpone (abort") ," ;        immediate restrict
                    384: 
                    385: \ Header states                                        23feb93py
                    386: 
                    387: : flag! ( 8b -- )   last @ cell+ tuck c@ xor swap c! ;
                    388: : immediate     $20 flag! ;
                    389: \ : restrict      $40 flag! ;
                    390: ' noop alias restrict
                    391: 
                    392: \ Header                                               23feb93py
                    393: 
                    394: \ input-stream, nextname and noname are quite ugly (passing
                    395: \ information through global variables), but they are useful for dealing
                    396: \ with existing/independent defining words
                    397: 
                    398: defer header
                    399: 
                    400: : name,  ( "name" -- )
                    401:     name c@ 1+ chars allot align ;
                    402: : input-stream-header ( "name" -- )
                    403:     \ !! this is f83-implementation-dependent
                    404:     align here last !  -1 A,
                    405:     name, $80 flag! ;
                    406: 
                    407: : input-stream ( -- )  \ general
                    408: \ switches back to getting the name from the input stream ;
                    409:     ['] input-stream-header IS header ;
                    410: 
                    411: ' input-stream-header IS header
                    412: 
                    413: \ !! make that a 2variable
                    414: create nextname-string 2 cells allot \ should we use a buffer that keeps the name?
                    415: 
                    416: : nextname-header ( -- )
                    417:     \ !! f83-implementation-dependent
                    418:     nextname-string 2@
                    419:     align here last ! -1 A,
                    420:     dup c,  here swap chars  dup allot  move  align
                    421:     $80 flag!
                    422:     input-stream ;
                    423: 
                    424: \ the next name is given in the string
                    425: : nextname ( c-addr u -- ) \ general
                    426:     nextname-string 2!
                    427:     ['] nextname-header IS header ;
                    428: 
                    429: : noname-header ( -- )
                    430:     0 last !
                    431:     input-stream ;
                    432: 
                    433: : noname ( -- ) \ general
                    434: \ the next defined word remains anonymous. The xt of that word is given by lastxt
                    435:     ['] noname-header IS header ;
                    436: 
                    437: : lastxt ( -- xt ) \ general
                    438: \ xt is the execution token of the last word defined. The main purpose of this word is to get the xt of words defined using noname
                    439:     lastcfa @ ;
                    440: 
                    441: : Alias    ( cfa "name" -- )
                    442:   Header reveal , $80 flag! ;
                    443: 
                    444: : name>string ( nfa -- addr count )
                    445:  cell+ count $1F and ;
                    446: 
                    447: Create ???  ," ???"
                    448: : >name ( cfa -- nfa )
                    449:  $21 cell do
                    450:    dup i - count $9F and + aligned over $80 + = if
                    451:      i - cell - unloop exit
                    452:    then
                    453:  cell +loop
                    454:  drop ??? ( wouldn't 0 be better? ) ;
                    455: 
                    456: \ indirect threading                                   17mar93py
                    457: 
                    458: : cfa,     ( code-address -- )
                    459:     here lastcfa !
                    460:     here  0 A, 0 ,  code-address! ;
                    461: : compile, ( xt -- )           A, ;
                    462: : !does    ( addr -- )         lastcfa @ does-code! ;
                    463: : (;code)  ( R: addr -- )      r> /does-handler + !does ;
                    464: : dodoes,  ( -- )
                    465:   here /does-handler allot does-handler! ;
                    466: 
                    467: \ direct threading is implementation dependent
                    468: 
                    469: : Create    Header reveal [ :dovar ] ALiteral cfa, ;
                    470: 
                    471: \ DOES>                                                17mar93py
                    472: 
                    473: : DOES>  state @ IF    postpone (;code) dodoes,
                    474:                  ELSE  dodoes, here !does 0 ] THEN ; immediate
                    475: 
                    476: \ Create Variable User Constant                        17mar93py
                    477: 
                    478: : Variable  Create 0 , ;
                    479: : AVariable Create 0 A, ;
                    480: : 2VARIABLE ( "name" -- ) \ double
                    481:     create 0 , 0 , ;
                    482:     
                    483: : User      Variable ;
                    484: : AUser     AVariable ;
                    485: 
                    486: : (Constant)  Header reveal [ :docon ] ALiteral cfa, ;
                    487: : Constant  (Constant) , ;
                    488: : AConstant (Constant) A, ;
1.2     ! pazsan    489: : 2Constant ( w1 w2 "name" -- ) \ double
        !           490:   Create 2, DOES> 2@ ;
1.1       anton     491:     
                    492: \ IS Defer What's Defers TO                            24feb93py
                    493: 
                    494: : Defer  Create ['] noop A,  DOES> @ execute ;
                    495: 
                    496: : IS ( addr "name" -- )
                    497:     ' >body
                    498:     state @
                    499:     IF    postpone ALiteral postpone !  
                    500:     ELSE  !
                    501:     THEN ;  immediate
                    502: ' IS Alias TO immediate
                    503: 
                    504: : What's ( "name" -- addr )  ' >body
                    505:   state @ IF  postpone ALiteral postpone @  ELSE  @  THEN ;
                    506:                                              immediate
                    507: : Defers ( "name" -- )  ' >body @ compile, ;
                    508:                                              immediate restrict
                    509: 
                    510: \ : ;                                                  24feb93py
                    511: 
                    512: : : ( -- colon-sys )  Header [ :docol ] ALiteral cfa, 0 ] ;
                    513: : ; ( colon-sys -- )  ?struc postpone exit reveal postpone [ ;
                    514:   immediate restrict
                    515: : :noname ( -- xt colon-sys )  here [ ' : @ ] ALiteral cfa, 0 ] ;
                    516: 
                    517: \ Search list handling                                 23feb93py
                    518: 
                    519: AVariable current
                    520: 
                    521: : last?   ( -- false / nfa nfa )    last @ ?dup ;
                    522: : (reveal) ( -- ) last?
                    523:   IF  dup @ 0<
                    524:       IF    current @ @ over ! current @ !
                    525:       ELSE  drop  THEN THEN ;
                    526: 
                    527: \ object oriented search list                          17mar93py
                    528: 
                    529: \ Search list table: find reveal
                    530: 
                    531: Create f83search    ' (f83find) A,  ' (reveal) A,
                    532: Create forth-wordlist  NIL A, G f83search T A, NIL A, NIL A,
                    533: AVariable search       G forth-wordlist search T !
                    534: G forth-wordlist current T !
                    535: 
                    536: : (search-wordlist)  ( addr count wid -- nfa / false )
                    537:   dup @ swap cell+ @ @ execute ;
                    538: 
                    539: : search-wordlist  ( addr count wid -- 0 / xt +-1 )
                    540:   (search-wordlist) dup  IF  found  THEN ;
                    541: 
                    542: Variable warnings  G -1 warnings T !
                    543: 
                    544: : check-shadow  ( addr count wid -- )
                    545: \ prints a warning if the string is already present in the wordlist
                    546: \ !! should be refined so the user can suppress the warnings
                    547:  >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if
                    548:    ." redefined " name>string 2dup type
                    549:    compare 0<> if
                    550:      ."  with " type
                    551:    else
                    552:      2drop
                    553:    then
                    554:    space space EXIT
                    555:  then
                    556:  2drop 2drop ;
                    557: 
                    558: : find   ( addr -- cfa +-1 / string false )  dup
                    559:   count search @ search-wordlist  dup IF  rot drop  THEN ;
                    560: 
                    561: : reveal ( -- )
                    562:  last? if
                    563:    name>string current @ check-shadow
                    564:  then
                    565:  current @ cell+ @ cell+ @ execute ;
                    566: 
                    567: : '    ( "name" -- addr )  name find 0= no.extensions ;
                    568: : [']  ( "name" -- addr )  ' postpone ALiteral ; immediate
                    569: \ Input                                                13feb93py
                    570: 
                    571: 07 constant #bell
                    572: 08 constant #bs
                    573: 7F constant #del
                    574: 0D constant #cr                \ the newline key code
                    575: 0A constant #lf
                    576: 
                    577: : bell  #bell emit ;
                    578: 
                    579: : backspaces  0 ?DO  #bs emit  LOOP ;
                    580: : >string  ( span addr pos1 -- span addr pos1 addr2 len )
                    581:   over 3 pick 2 pick chars /string ;
                    582: : type-rest ( span addr pos1 -- span addr pos1 back )
                    583:   >string tuck type ;
                    584: : (del)  ( max span addr pos1 -- max span addr pos2 )
                    585:   1- >string over 1+ -rot move
                    586:   rot 1- -rot  #bs emit  type-rest bl emit 1+ backspaces ;
                    587: : (ins)  ( max span addr pos1 char -- max span addr pos2 )
                    588:   >r >string over 1+ swap move 2dup chars + r> swap c!
                    589:   rot 1+ -rot type-rest 1- backspaces 1+ ;
                    590: : ?del ( max span addr pos1 -- max span addr pos2 0 )
                    591:   dup  IF  (del)  THEN  0 ;
                    592: : (ret)  type-rest drop true space ;
                    593: : back  dup  IF  1- #bs emit  ELSE  #bell emit  THEN 0 ;
                    594: : forw 2 pick over <> IF  2dup + c@ emit 1+  ELSE  #bell emit  THEN 0 ;
                    595: 
                    596: Create crtlkeys
                    597:   ] false false back  false  false false forw  false
                    598:     ?del  false (ret) false  false (ret) false false
                    599:     false false false false  false false false false
                    600:     false false false false  false false false false [
                    601: 
                    602: : decode ( max span addr pos1 key -- max span addr pos2 flag )
                    603:   dup #del = IF  drop #bs  THEN  \ del is rubout
                    604:   dup bl <   IF  cells crtlkeys + @ execute  EXIT  THEN
                    605:   >r 2over = IF  rdrop bell 0 EXIT  THEN
                    606:   r> (ins) 0 ;
                    607: 
                    608: \ decode should better use a table for control key actions
                    609: \ to define keyboard bindings later
                    610: 
                    611: : accept   ( addr len -- len )
                    612:   dup 0< IF    abs over dup 1 chars - c@ tuck type 
                    613: \ this allows to edit given strings
                    614:          ELSE  0  THEN rot over
                    615:   BEGIN  key decode  UNTIL
                    616:   2drop nip ;
                    617: 
                    618: \ Output                                               13feb93py
                    619: 
                    620: DEFER type      \ defer type for a output buffer or fast
                    621:                 \ screen write
                    622: 
                    623: : (type) ( addr len -- )
                    624:   bounds ?DO  I c@ emit  LOOP ;
                    625: 
                    626: ' (TYPE) IS Type
                    627: 
                    628: \ DEFER Emit
                    629: 
                    630: \ ' (Emit) IS Emit
                    631: 
                    632: \ : form  ( -- rows cols )  &24 &80 ;
                    633: \ form should be implemented using TERMCAPS or CURSES
                    634: \ : rows  form drop ;
                    635: \ : cols  form nip  ;
                    636: 
                    637: \ Query                                                07apr93py
                    638: 
                    639: : refill ( -- flag )
                    640:   tib /line
                    641:   loadfile @ ?dup
                    642:   IF    dup file-position throw linestart 2!
                    643:         read-line throw
                    644:   ELSE  linestart @ IF 2drop false EXIT THEN
                    645:         accept true
                    646:   THEN
                    647:   1 loadline +!
                    648:   swap #tib ! >in off ;
                    649: 
                    650: : Query  ( -- )  loadfile off refill drop ;
                    651: 
                    652: \ File specifiers                                       11jun93jaw
                    653: 
                    654: 
                    655: \ 1 c, here char r c, 0 c,                0 c, 0 c, char b c, 0 c,
                    656: \ 2 c, here char r c, char + c, 0 c,
                    657: \ 2 c, here char w c, char + c, 0 c, align
                    658: 4 Constant w/o
                    659: 2 Constant r/w
                    660: 0 Constant r/o
                    661: 
                    662: \ BIN WRITE-LINE                                        11jun93jaw
                    663: 
                    664: \ : bin           dup 1 chars - c@
                    665: \                 r/o 4 chars + over - dup >r swap move r> ;
                    666: 
                    667: : bin  1+ ;
                    668: 
                    669: create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos
                    670:                            \ or not unix environments if
                    671:                            \ bin is not selected
                    672: 
                    673: : write-line    dup >r write-file ?dup IF r> drop EXIT THEN
                    674:                 nl$ count r> write-file ;
                    675: 
                    676: \ include-file                                         07apr93py
                    677: 
                    678: : include-file ( i*x fid -- j*x )
                    679:   linestart @ >r loadline @ >r loadfile @ >r
                    680:   blk @ >r >tib @ >r  #tib @ dup >r  >in @ >r
                    681: 
                    682:   >tib +! loadfile !
                    683:   0 loadline ! blk off
                    684:   BEGIN  refill  WHILE  interpret  REPEAT
                    685:   loadfile @ close-file throw
                    686: 
                    687:   r> >in !  r> #tib !  r> >tib ! r> blk !
                    688:   r> loadfile ! r> loadline ! r> linestart ! ;
                    689: 
                    690: : included ( i*x addr u -- j*x )
                    691:   r/o open-file throw include-file ;
                    692: 
                    693: \ HEX DECIMAL                                           2may93jaw
                    694: 
                    695: : decimal a base ! ;
                    696: : hex     10 base ! ;
                    697: 
                    698: \ DEPTH                                                 9may93jaw
                    699: 
                    700: : depth ( -- +n )  sp@ s0 @ swap - cell / ;
                    701: 
                    702: \ INCLUDE                                               9may93jaw
                    703: 
                    704: : include
                    705:         bl word count included ;
                    706: 
                    707: \ RECURSE                                               17may93jaw
                    708: 
                    709: : recurse  last @ cell+ name> a, ; immediate restrict
                    710: \ !! does not work with anonymous words; use lastxt compile,
                    711: 
                    712: \ */MOD */                                              17may93jaw
                    713: 
                    714: : */mod >r m* r> sm/rem ;
                    715: 
                    716: : */ */mod nip ;
                    717: 
                    718: \ EVALUATE                                              17may93jaw
                    719: 
                    720: : evaluate ( c-addr len -- )
                    721:   linestart @ >r loadline @ >r loadfile @ >r
                    722:   blk @ >r >tib @ >r  #tib @ dup >r  >in @ >r
                    723: 
                    724:   >tib +! dup #tib ! >tib @ swap move
                    725:   >in off blk off loadfile off -1 linestart !
                    726: 
                    727:   BEGIN  interpret  >in @ #tib @ u>= UNTIL
                    728: 
                    729:   r> >in !  r> #tib !  r> >tib ! r> blk !
                    730:   r> loadfile ! r> loadline ! r> linestart ! ;
                    731: 
                    732: 
                    733: : abort -1 throw ;
                    734: 
                    735: \+ environment? true ENV" CORE"
                    736: \ core wordset is now complete!
                    737: 
                    738: \ Quit                                                 13feb93py
                    739: 
                    740: Defer 'quit
                    741: Defer .status
                    742: : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;
                    743: : (quit)        BEGIN .status cr query interpret prompt AGAIN ;
                    744: ' (quit) IS 'quit
                    745: 
                    746: \ DOERROR (DOERROR)                                     13jun93jaw
                    747: 
                    748: DEFER DOERROR
                    749: 
                    750: : (DoError) ( throw-code -- )
                    751:          LoadFile @ IF ." Error in line: " Loadline @ . cr THEN
                    752:          cr source type cr
                    753:          source drop >in @ -trailing
                    754:          here c@ 1F min dup >r - 1- 0 max nip
                    755:          dup spaces IF ." ^" THEN r> 0 ?DO ." -" LOOP ." ^"
                    756:          dup -2 =
                    757:          IF "error @ ?dup IF cr count type THEN drop
                    758:          ELSE .error THEN ;
                    759: 
                    760: ' (DoError) IS DoError
                    761: 
                    762: : quit   r0 @ rp! handler off >tib @ >r
                    763:   BEGIN  postpone [  ['] 'quit catch dup  WHILE
                    764:          DoError r@ >tib !
                    765:   REPEAT  drop r> >tib ! ;
                    766: 
                    767: \ Cold                                                 13feb93py
                    768: 
                    769: \ : .name ( name -- ) cell+ count $1F and type space ;
                    770: \ : words  listwords @
                    771: \          BEGIN  @ dup  WHILE  dup .name  REPEAT drop ;
                    772: 
                    773: : >len  ( cstring -- addr n )  100 0 scan 0 swap 100 - /string ;
                    774: : arg ( n -- addr count )  cells argv @ + @ >len ;
                    775: : #!       postpone \ ;  immediate
                    776: 
                    777: Variable env
                    778: Variable argv
                    779: Variable argc
                    780: 
                    781: : get-args ( -- )  #tib off
                    782:   argc @ 1 ?DO  I arg 2dup source + swap move
                    783:                 #tib +! drop  bl source + c! 1 #tib +!  LOOP
                    784:   >in off #tib @ 0<> #tib +! ;
                    785: 
                    786: : script? ( -- flag )  0 arg 1 arg dup 3 pick - /string compare 0= ;
                    787: 
                    788: : cold ( -- )  argc @ 1 >
                    789:   IF  script?
                    790:       IF  1 arg ['] included  ELSE   get-args ['] interpret  THEN
                    791:       catch ?dup IF  dup >r DoError cr r> (bye)  THEN THEN
                    792:   ." ANS FORTH-93 (c) 1993 by the ANS FORTH-93 Team" cr quit ;
                    793: 
                    794: : boot ( **env **argv argc -- )
                    795:   argc ! argv ! env !
                    796:   sp@ dup s0 ! $10 + >tib ! rp@ r0 !  fp@ f0 !  cold ;
                    797: 
                    798: : bye  cr 0 (bye) ;
                    799: 
                    800: \ **argv may be scanned by the C starter to get some important
                    801: \ information, as -display and -geometry for an X client FORTH
                    802: \ or space and stackspace overrides
                    803: 
                    804: \ 0 arg contains, however, the name of the program.

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>