Annotation of gforth/kernal.fs, revision 1.1

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: 
        !           271: : no.extensions  ( string -- )   IF &-13 bounce THEN ;
        !           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
        !           289:   ELSE  notfound  THEN ;
        !           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, ;
        !           489: : 2CONSTANT ( w1 w2 "name" -- ) \ double
        !           490:     (constant) 2, ;
        !           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>