Annotation of gforth/kernal.fs, revision 1.3

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: 
1.3     ! pazsan    512: : EXIT  ( -- )  postpone ;s ;  immediate
        !           513: 
1.1       anton     514: : : ( -- colon-sys )  Header [ :docol ] ALiteral cfa, 0 ] ;
                    515: : ; ( colon-sys -- )  ?struc postpone exit reveal postpone [ ;
                    516:   immediate restrict
                    517: : :noname ( -- xt colon-sys )  here [ ' : @ ] ALiteral cfa, 0 ] ;
                    518: 
                    519: \ Search list handling                                 23feb93py
                    520: 
                    521: AVariable current
                    522: 
                    523: : last?   ( -- false / nfa nfa )    last @ ?dup ;
                    524: : (reveal) ( -- ) last?
                    525:   IF  dup @ 0<
                    526:       IF    current @ @ over ! current @ !
                    527:       ELSE  drop  THEN THEN ;
                    528: 
                    529: \ object oriented search list                          17mar93py
                    530: 
                    531: \ Search list table: find reveal
                    532: 
                    533: Create f83search    ' (f83find) A,  ' (reveal) A,
                    534: Create forth-wordlist  NIL A, G f83search T A, NIL A, NIL A,
                    535: AVariable search       G forth-wordlist search T !
                    536: G forth-wordlist current T !
                    537: 
                    538: : (search-wordlist)  ( addr count wid -- nfa / false )
                    539:   dup @ swap cell+ @ @ execute ;
                    540: 
                    541: : search-wordlist  ( addr count wid -- 0 / xt +-1 )
                    542:   (search-wordlist) dup  IF  found  THEN ;
                    543: 
                    544: Variable warnings  G -1 warnings T !
                    545: 
                    546: : check-shadow  ( addr count wid -- )
                    547: \ prints a warning if the string is already present in the wordlist
                    548: \ !! should be refined so the user can suppress the warnings
                    549:  >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if
                    550:    ." redefined " name>string 2dup type
                    551:    compare 0<> if
                    552:      ."  with " type
                    553:    else
                    554:      2drop
                    555:    then
                    556:    space space EXIT
                    557:  then
                    558:  2drop 2drop ;
                    559: 
                    560: : find   ( addr -- cfa +-1 / string false )  dup
                    561:   count search @ search-wordlist  dup IF  rot drop  THEN ;
                    562: 
                    563: : reveal ( -- )
                    564:  last? if
                    565:    name>string current @ check-shadow
                    566:  then
                    567:  current @ cell+ @ cell+ @ execute ;
                    568: 
                    569: : '    ( "name" -- addr )  name find 0= no.extensions ;
                    570: : [']  ( "name" -- addr )  ' postpone ALiteral ; immediate
                    571: \ Input                                                13feb93py
                    572: 
                    573: 07 constant #bell
                    574: 08 constant #bs
                    575: 7F constant #del
                    576: 0D constant #cr                \ the newline key code
                    577: 0A constant #lf
                    578: 
                    579: : bell  #bell emit ;
                    580: 
                    581: : backspaces  0 ?DO  #bs emit  LOOP ;
                    582: : >string  ( span addr pos1 -- span addr pos1 addr2 len )
                    583:   over 3 pick 2 pick chars /string ;
                    584: : type-rest ( span addr pos1 -- span addr pos1 back )
                    585:   >string tuck type ;
                    586: : (del)  ( max span addr pos1 -- max span addr pos2 )
                    587:   1- >string over 1+ -rot move
                    588:   rot 1- -rot  #bs emit  type-rest bl emit 1+ backspaces ;
                    589: : (ins)  ( max span addr pos1 char -- max span addr pos2 )
                    590:   >r >string over 1+ swap move 2dup chars + r> swap c!
                    591:   rot 1+ -rot type-rest 1- backspaces 1+ ;
                    592: : ?del ( max span addr pos1 -- max span addr pos2 0 )
                    593:   dup  IF  (del)  THEN  0 ;
                    594: : (ret)  type-rest drop true space ;
                    595: : back  dup  IF  1- #bs emit  ELSE  #bell emit  THEN 0 ;
                    596: : forw 2 pick over <> IF  2dup + c@ emit 1+  ELSE  #bell emit  THEN 0 ;
                    597: 
                    598: Create crtlkeys
                    599:   ] false false back  false  false false forw  false
                    600:     ?del  false (ret) false  false (ret) false false
                    601:     false false false false  false false false false
                    602:     false false false false  false false false false [
                    603: 
                    604: : decode ( max span addr pos1 key -- max span addr pos2 flag )
                    605:   dup #del = IF  drop #bs  THEN  \ del is rubout
                    606:   dup bl <   IF  cells crtlkeys + @ execute  EXIT  THEN
                    607:   >r 2over = IF  rdrop bell 0 EXIT  THEN
                    608:   r> (ins) 0 ;
                    609: 
                    610: \ decode should better use a table for control key actions
                    611: \ to define keyboard bindings later
                    612: 
                    613: : accept   ( addr len -- len )
                    614:   dup 0< IF    abs over dup 1 chars - c@ tuck type 
                    615: \ this allows to edit given strings
                    616:          ELSE  0  THEN rot over
                    617:   BEGIN  key decode  UNTIL
                    618:   2drop nip ;
                    619: 
                    620: \ Output                                               13feb93py
                    621: 
                    622: DEFER type      \ defer type for a output buffer or fast
                    623:                 \ screen write
                    624: 
                    625: : (type) ( addr len -- )
                    626:   bounds ?DO  I c@ emit  LOOP ;
                    627: 
                    628: ' (TYPE) IS Type
                    629: 
                    630: \ DEFER Emit
                    631: 
                    632: \ ' (Emit) IS Emit
                    633: 
                    634: \ : form  ( -- rows cols )  &24 &80 ;
                    635: \ form should be implemented using TERMCAPS or CURSES
                    636: \ : rows  form drop ;
                    637: \ : cols  form nip  ;
                    638: 
                    639: \ Query                                                07apr93py
                    640: 
                    641: : refill ( -- flag )
                    642:   tib /line
                    643:   loadfile @ ?dup
                    644:   IF    dup file-position throw linestart 2!
                    645:         read-line throw
                    646:   ELSE  linestart @ IF 2drop false EXIT THEN
                    647:         accept true
                    648:   THEN
                    649:   1 loadline +!
                    650:   swap #tib ! >in off ;
                    651: 
                    652: : Query  ( -- )  loadfile off refill drop ;
                    653: 
                    654: \ File specifiers                                       11jun93jaw
                    655: 
                    656: 
                    657: \ 1 c, here char r c, 0 c,                0 c, 0 c, char b c, 0 c,
                    658: \ 2 c, here char r c, char + c, 0 c,
                    659: \ 2 c, here char w c, char + c, 0 c, align
                    660: 4 Constant w/o
                    661: 2 Constant r/w
                    662: 0 Constant r/o
                    663: 
                    664: \ BIN WRITE-LINE                                        11jun93jaw
                    665: 
                    666: \ : bin           dup 1 chars - c@
                    667: \                 r/o 4 chars + over - dup >r swap move r> ;
                    668: 
                    669: : bin  1+ ;
                    670: 
                    671: create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos
                    672:                            \ or not unix environments if
                    673:                            \ bin is not selected
                    674: 
                    675: : write-line    dup >r write-file ?dup IF r> drop EXIT THEN
                    676:                 nl$ count r> write-file ;
                    677: 
                    678: \ include-file                                         07apr93py
                    679: 
                    680: : include-file ( i*x fid -- j*x )
                    681:   linestart @ >r loadline @ >r loadfile @ >r
                    682:   blk @ >r >tib @ >r  #tib @ dup >r  >in @ >r
                    683: 
                    684:   >tib +! loadfile !
                    685:   0 loadline ! blk off
                    686:   BEGIN  refill  WHILE  interpret  REPEAT
                    687:   loadfile @ close-file throw
                    688: 
                    689:   r> >in !  r> #tib !  r> >tib ! r> blk !
                    690:   r> loadfile ! r> loadline ! r> linestart ! ;
                    691: 
                    692: : included ( i*x addr u -- j*x )
                    693:   r/o open-file throw include-file ;
                    694: 
                    695: \ HEX DECIMAL                                           2may93jaw
                    696: 
                    697: : decimal a base ! ;
                    698: : hex     10 base ! ;
                    699: 
                    700: \ DEPTH                                                 9may93jaw
                    701: 
                    702: : depth ( -- +n )  sp@ s0 @ swap - cell / ;
                    703: 
                    704: \ INCLUDE                                               9may93jaw
                    705: 
                    706: : include
                    707:         bl word count included ;
                    708: 
                    709: \ RECURSE                                               17may93jaw
                    710: 
                    711: : recurse  last @ cell+ name> a, ; immediate restrict
                    712: \ !! does not work with anonymous words; use lastxt compile,
                    713: 
                    714: \ */MOD */                                              17may93jaw
                    715: 
                    716: : */mod >r m* r> sm/rem ;
                    717: 
                    718: : */ */mod nip ;
                    719: 
                    720: \ EVALUATE                                              17may93jaw
                    721: 
                    722: : evaluate ( c-addr len -- )
                    723:   linestart @ >r loadline @ >r loadfile @ >r
                    724:   blk @ >r >tib @ >r  #tib @ dup >r  >in @ >r
                    725: 
                    726:   >tib +! dup #tib ! >tib @ swap move
                    727:   >in off blk off loadfile off -1 linestart !
                    728: 
                    729:   BEGIN  interpret  >in @ #tib @ u>= UNTIL
                    730: 
                    731:   r> >in !  r> #tib !  r> >tib ! r> blk !
                    732:   r> loadfile ! r> loadline ! r> linestart ! ;
                    733: 
                    734: 
                    735: : abort -1 throw ;
                    736: 
                    737: \+ environment? true ENV" CORE"
                    738: \ core wordset is now complete!
                    739: 
                    740: \ Quit                                                 13feb93py
                    741: 
                    742: Defer 'quit
                    743: Defer .status
                    744: : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;
                    745: : (quit)        BEGIN .status cr query interpret prompt AGAIN ;
                    746: ' (quit) IS 'quit
                    747: 
                    748: \ DOERROR (DOERROR)                                     13jun93jaw
                    749: 
                    750: DEFER DOERROR
                    751: 
                    752: : (DoError) ( throw-code -- )
                    753:          LoadFile @ IF ." Error in line: " Loadline @ . cr THEN
                    754:          cr source type cr
                    755:          source drop >in @ -trailing
                    756:          here c@ 1F min dup >r - 1- 0 max nip
                    757:          dup spaces IF ." ^" THEN r> 0 ?DO ." -" LOOP ." ^"
                    758:          dup -2 =
                    759:          IF "error @ ?dup IF cr count type THEN drop
                    760:          ELSE .error THEN ;
                    761: 
                    762: ' (DoError) IS DoError
                    763: 
                    764: : quit   r0 @ rp! handler off >tib @ >r
                    765:   BEGIN  postpone [  ['] 'quit catch dup  WHILE
                    766:          DoError r@ >tib !
                    767:   REPEAT  drop r> >tib ! ;
                    768: 
                    769: \ Cold                                                 13feb93py
                    770: 
                    771: \ : .name ( name -- ) cell+ count $1F and type space ;
                    772: \ : words  listwords @
                    773: \          BEGIN  @ dup  WHILE  dup .name  REPEAT drop ;
                    774: 
                    775: : >len  ( cstring -- addr n )  100 0 scan 0 swap 100 - /string ;
                    776: : arg ( n -- addr count )  cells argv @ + @ >len ;
                    777: : #!       postpone \ ;  immediate
                    778: 
                    779: Variable env
                    780: Variable argv
                    781: Variable argc
                    782: 
                    783: : get-args ( -- )  #tib off
                    784:   argc @ 1 ?DO  I arg 2dup source + swap move
                    785:                 #tib +! drop  bl source + c! 1 #tib +!  LOOP
                    786:   >in off #tib @ 0<> #tib +! ;
                    787: 
                    788: : script? ( -- flag )  0 arg 1 arg dup 3 pick - /string compare 0= ;
                    789: 
                    790: : cold ( -- )  argc @ 1 >
                    791:   IF  script?
                    792:       IF  1 arg ['] included  ELSE   get-args ['] interpret  THEN
                    793:       catch ?dup IF  dup >r DoError cr r> (bye)  THEN THEN
                    794:   ." ANS FORTH-93 (c) 1993 by the ANS FORTH-93 Team" cr quit ;
                    795: 
                    796: : boot ( **env **argv argc -- )
                    797:   argc ! argv ! env !
                    798:   sp@ dup s0 ! $10 + >tib ! rp@ r0 !  fp@ f0 !  cold ;
                    799: 
                    800: : bye  cr 0 (bye) ;
                    801: 
                    802: \ **argv may be scanned by the C starter to get some important
                    803: \ information, as -display and -geometry for an X client FORTH
                    804: \ or space and stackspace overrides
                    805: 
                    806: \ 0 arg contains, however, the name of the program.

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