Annotation of gforth/kernel/int.fs, revision 1.4

1.1       pazsan      1: \ definitions needed for interpreter only
                      2: 
                      3: \ \ Revision-Log
                      4: 
                      5: \       put in seperate file                           14sep97jaw 
                      6: 
                      7: \ \ input stream primitives                            23feb93py
                      8: 
                      9: : tib ( -- c-addr ) \ core-ext
                     10:     \ obsolescent
                     11:     >tib @ ;
                     12: 
                     13: Defer source ( -- addr count ) \ core
                     14: \ used by dodefer:, must be defer
                     15: 
                     16: : (source) ( -- addr count )
                     17:     tib #tib @ ;
                     18: ' (source) IS source
                     19: 
                     20: : (word) ( addr1 n1 char -- addr2 n2 )
                     21:   dup >r skip 2dup r> scan  nip - ;
                     22: 
                     23: \ (word) should fold white spaces
                     24: \ this is what (parse-white) does
                     25: 
                     26: \ word parse                                           23feb93py
                     27: 
1.3       anton      28: : sword  ( char -- addr len ) \ gforth
                     29:   \G parses like @code{word}, but the output is like @code{parse} output
                     30:   \ this word was called PARSE-WORD until 0.3.0, but Open Firmware and
                     31:   \ dpANS6 A.6.2.2008 have a word with that name that behaves
                     32:   \ differently (like NAME).
1.1       pazsan     33:   source 2dup >r >r >in @ over min /string
                     34:   rot dup bl = IF  drop (parse-white)  ELSE  (word)  THEN
                     35:   2dup + r> - 1+ r> min >in ! ;
                     36: 
                     37: : word   ( char -- addr ) \ core
1.3       anton      38:   sword here place  bl here count + c!  here ;
1.1       pazsan     39: 
                     40: : parse    ( char -- addr len ) \ core-ext
                     41:   >r  source  >in @ over min /string  over  swap r>  scan >r
                     42:   over - dup r> IF 1+ THEN  >in +! ;
                     43: 
                     44: \ name                                                 13feb93py
                     45: 
                     46: [IFUNDEF] (name) \ name might be a primitive
                     47: 
                     48: : (name) ( -- c-addr count )
                     49:     source 2dup >r >r >in @ /string (parse-white)
                     50:     2dup + r> - 1+ r> min >in ! ;
                     51: \    name count ;
                     52: [THEN]
                     53: 
                     54: : name-too-short? ( c-addr u -- c-addr u )
                     55:     dup 0= -&16 and throw ;
                     56: 
                     57: : name-too-long? ( c-addr u -- c-addr u )
                     58:     dup $1F u> -&19 and throw ;
                     59: 
                     60: \ \ Number parsing                                     23feb93py
                     61: 
                     62: \ number? number                                       23feb93py
                     63: 
                     64: hex
                     65: const Create bases   10 ,   2 ,   A , 100 ,
                     66: \                     16     2    10   character
                     67: \ !! this saving and restoring base is an abomination! - anton
                     68: 
                     69: : getbase ( addr u -- addr' u' )
                     70:     over c@ [char] $ - dup 4 u<
                     71:     IF
                     72:        cells bases + @ base ! 1 /string
                     73:     ELSE
                     74:        drop
                     75:     THEN ;
                     76: 
                     77: : s>number ( addr len -- d )
                     78:     base @ >r  dpl on
                     79:     over c@ '- =  dup >r
                     80:     IF
                     81:        1 /string
                     82:     THEN
                     83:     getbase  dpl on  0 0 2swap
                     84:     BEGIN
                     85:        dup >r >number dup
                     86:     WHILE
                     87:        dup r> -
                     88:     WHILE
                     89:        dup dpl ! over c@ [char] . =
                     90:     WHILE
                     91:        1 /string
                     92:     REPEAT  THEN
                     93:         2drop rdrop dpl off
                     94:     ELSE
                     95:        2drop rdrop r>
                     96:        IF
                     97:            dnegate
                     98:        THEN
                     99:     THEN
                    100:     r> base ! ;
                    101: 
                    102: : snumber? ( c-addr u -- 0 / n -1 / d 0> )
                    103:     s>number dpl @ 0=
                    104:     IF
                    105:        2drop false  EXIT
                    106:     THEN
                    107:     dpl @ dup 0> 0= IF
                    108:        nip
                    109:     THEN ;
                    110: 
                    111: : number? ( string -- string 0 / n -1 / d 0> )
                    112:     dup >r count snumber? dup if
                    113:        rdrop
                    114:     else
                    115:        r> swap
                    116:     then ;
                    117: 
                    118: : number ( string -- d )
                    119:     number? ?dup 0= abort" ?"  0<
                    120:     IF
                    121:        s>d
                    122:     THEN ;
                    123: 
                    124: \ \ Comments ( \ \G
                    125: 
                    126: : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file    paren
                    127:     [char] ) parse 2drop ; immediate
                    128: 
                    129: : \ ( -- ) \ core-ext backslash
                    130:     blk @
                    131:     IF
                    132:        >in @ c/l / 1+ c/l * >in !
                    133:        EXIT
                    134:     THEN
                    135:     source >in ! drop ; immediate
                    136: 
                    137: : \G ( -- ) \ gforth backslash
                    138:     POSTPONE \ ; immediate
                    139: 
                    140: \ \ object oriented search list                         17mar93py
                    141: 
                    142: \ word list structure:
                    143: 
                    144: struct
                    145:   cell% field find-method   \ xt: ( c_addr u wid -- nt )
                    146:   cell% field reveal-method \ xt: ( nt wid -- ) \ used by dofield:, must be field
                    147:   cell% field rehash-method \ xt: ( wid -- )      \ re-initializes a "search-data" (hashtables)
                    148:   cell% field hash-method   \ xt: ( wid -- )    \ initializes ""
                    149: \   \ !! what else
                    150: end-struct wordlist-map-struct
                    151: 
                    152: struct
                    153:   cell% field wordlist-id \ not the same as wid; representation depends on implementation
                    154:   cell% field wordlist-map \ pointer to a wordlist-map-struct
                    155:   cell% field wordlist-link \ link field to other wordlists
                    156:   cell% field wordlist-extend \ points to wordlist extensions (eg hashtables)
                    157: end-struct wordlist-struct
                    158: 
                    159: : f83find      ( addr len wordlist -- nt / false )
                    160:     ( wid>wordlist-id ) @ (f83find) ;
                    161: 
                    162: : initvoc              ( wid -- )
                    163:   dup wordlist-map @ hash-method perform ;
                    164: 
                    165: \ Search list table: find reveal
                    166: Create f83search ( -- wordlist-map )
                    167:     ' f83find A,  ' drop A,  ' drop A, ' drop A,
                    168: 
                    169: here NIL A, G f83search T A, NIL A, NIL A,
                    170: AValue forth-wordlist \ variable, will be redefined by search.fs
                    171: 
                    172: AVariable lookup               forth-wordlist lookup !
                    173: \ !! last is user and lookup?! jaw
                    174: AVariable current ( -- addr ) \ gforth
                    175: AVariable voclink      forth-wordlist wordlist-link voclink !
                    176: lookup AValue context
                    177: 
                    178: forth-wordlist current !
                    179: 
                    180: \ \ header, finding, ticks                              17dec92py
                    181: 
                    182: $80 constant alias-mask \ set when the word is not an alias!
                    183: $40 constant immediate-mask
                    184: $20 constant restrict-mask
                    185: 
                    186: \ higher level parts of find
                    187: 
                    188: : flag-sign ( f -- 1|-1 )
                    189:     \ true becomes 1, false -1
                    190:     0= 2* 1+ ;
                    191: 
                    192: : compile-only-error ( ... -- )
                    193:     -&14 throw ;
                    194: 
                    195: : (cfa>int) ( cfa -- xt )
                    196: [ has? compiler [IF] ]
                    197:     dup interpret/compile?
                    198:     if
                    199:        interpret/compile-int @
                    200:     then 
                    201: [ [THEN] ] ;
                    202: 
                    203: : (x>int) ( cfa b -- xt )
                    204:     \ get interpretation semantics of name
                    205:     restrict-mask and
                    206:     if
                    207:        drop ['] compile-only-error
                    208:     else
                    209:        (cfa>int)
                    210:     then ;
                    211: 
                    212: : name>string ( nt -- addr count ) \ gforth     head-to-string
                    213:     \g @var{addr count} is the name of the word represented by @var{nt}.
                    214:     cell+ count $1F and ;
                    215: 
                    216: : ((name>))  ( nfa -- cfa )
                    217:     name>string + cfaligned ;
                    218: 
                    219: : (name>x) ( nfa -- cfa b )
                    220:     \ cfa is an intermediate cfa and b is the flags byte of nfa
                    221:     dup ((name>))
                    222:     swap cell+ c@ dup alias-mask and 0=
                    223:     IF
                    224:         swap @ swap
                    225:     THEN ;
                    226: 
                    227: : name>int ( nt -- xt ) \ gforth
                    228:     \G @var{xt} represents the interpretation semantics of the word
                    229:     \G @var{nt}. Produces @code{' compile-only-error} if
                    230:     \G @var{nt} is compile-only.
                    231:     (name>x) (x>int) ;
                    232: 
                    233: : name?int ( nt -- xt ) \ gforth
                    234:     \G Like name>int, but throws an error if compile-only.
                    235:     (name>x) restrict-mask and
                    236:     if
                    237:        compile-only-error \ does not return
                    238:     then
                    239:     (cfa>int) ;
                    240: 
                    241: : (name>comp) ( nt -- w +-1 ) \ gforth
                    242:     \G @var{w xt} is the compilation token for the word @var{nt}.
                    243:     (name>x) >r 
                    244: [ has? compiler [IF] ]
                    245:     dup interpret/compile?
                    246:     if
                    247:         interpret/compile-comp @
                    248:     then 
                    249: [ [THEN] ]
                    250:     r> immediate-mask and flag-sign
                    251:     ;
                    252: 
                    253: : (name>intn) ( nfa -- xt +-1 )
                    254:     (name>x) tuck (x>int) ( b xt )
                    255:     swap immediate-mask and flag-sign ;
                    256: 
                    257: const Create ???  0 , 3 c, char ? c, char ? c, char ? c,
                    258: \ ??? is used by dovar:, must be created/:dovar
                    259: 
                    260: : >head ( cfa -- nt ) \ gforth  to-name
                    261:  $21 cell do
                    262:    dup i - count $9F and + cfaligned over alias-mask + = if
                    263:      i - cell - unloop exit
                    264:    then
                    265:  cell +loop
                    266:  drop ??? ( wouldn't 0 be better? ) ;
                    267: 
                    268: ' >head ALIAS >name
                    269: 
                    270: : body> 0 >body - ;
                    271: 
                    272: : (search-wordlist)  ( addr count wid -- nt / false )
                    273:     dup wordlist-map @ find-method perform ;
                    274: 
                    275: : search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search
                    276:     \ xt is the interpretation semantics
                    277:     (search-wordlist) dup if
                    278:        (name>intn)
                    279:     then ;
                    280: 
                    281: : find-name ( c-addr u -- nt/0 ) \ gforth
                    282:     \g Find the name @var{c-addr u} in the current search
                    283:     \g order. Return its nt, if found, otherwise 0.
                    284:     lookup @ (search-wordlist) ;
                    285: 
                    286: : sfind ( c-addr u -- 0 / xt +-1  ) \ gforth-obsolete
                    287:     find-name dup
                    288:     if ( nt )
                    289:        state @
                    290:        if
                    291:            (name>comp)
                    292:        else
                    293:            (name>intn)
                    294:        then
                    295:    then ;
                    296: 
                    297: : find ( c-addr -- xt +-1 / c-addr 0 ) \ core,search
                    298:     dup count sfind dup
                    299:     if
                    300:        rot drop
                    301:     then ;
                    302: 
                    303: \ ticks
                    304: 
                    305: : (') ( "name" -- nt ) \ gforth
                    306:     name find-name dup 0=
                    307:     IF
                    308:        drop -&13 bounce
                    309:     THEN  ;
                    310: 
                    311: : '    ( "name" -- xt ) \ core tick
                    312:     \g @var{xt} represents @var{name}'s interpretation
                    313:     \g semantics. Performs @code{-14 throw} if the word has no
                    314:     \g interpretation semantics.
                    315:     (') name?int ;
                    316: 
                    317: \ \ the interpreter loop                                 mar92py
                    318: 
                    319: \ interpret                                            10mar92py
                    320: 
                    321: Defer parser
                    322: Defer name ( -- c-addr count ) \ gforth
                    323: \ get the next word from the input buffer
                    324: ' (name) IS name
                    325: Defer compiler-notfound ( c-addr count -- )
                    326: Defer interpreter-notfound ( c-addr count -- )
                    327: 
                    328: : no.extensions  ( addr u -- )
                    329:     2drop -&13 bounce ;
                    330: ' no.extensions IS compiler-notfound
                    331: ' no.extensions IS interpreter-notfound
                    332: 
                    333: : interpret ( ?? -- ?? ) \ gforth
                    334:     \ interpret/compile the (rest of the) input buffer
                    335:     BEGIN
                    336:        ?stack name dup
                    337:     WHILE
                    338:        parser
                    339:     REPEAT
                    340:     2drop ;
                    341: 
                    342: \ interpreter                                  30apr92py
                    343: 
                    344: \ not the most efficient implementations of interpreter and compiler
                    345: : interpreter ( c-addr u -- ) 
                    346:     2dup find-name dup
                    347:     if
                    348:        nip nip name>int execute
                    349:     else
                    350:        drop
                    351:        2dup 2>r snumber?
                    352:        IF
                    353:            2rdrop
                    354:        ELSE
                    355:            2r> interpreter-notfound
                    356:        THEN
                    357:     then ;
                    358: 
                    359: ' interpreter  IS  parser
                    360: 
                    361: \ \ Query Evaluate                                     07apr93py
                    362: 
                    363: has? file 0= [IF]
                    364: : sourceline# ( -- n )  loadline @ ;
                    365: [THEN]
                    366: 
                    367: : refill ( -- flag ) \ core-ext,block-ext,file-ext
                    368:   blk @  IF  1 blk +!  true  0 >in !  EXIT  THEN
                    369:   tib /line
                    370: [ has? file [IF] ]
                    371:   loadfile @ ?dup
                    372:   IF    read-line throw
                    373:   ELSE
                    374: [ [THEN] ]
                    375:       sourceline# 0< IF 2drop false EXIT THEN
                    376:       accept true
                    377: [ has? file [IF] ]
                    378:   THEN
                    379: [ [THEN] ]
                    380:   1 loadline +!
                    381:   swap #tib ! 0 >in ! ;
                    382: 
                    383: : query   ( -- ) \ core-ext
                    384:     \G obsolescent
                    385:     blk off loadfile off
                    386:     tib /line accept #tib ! 0 >in ! ;
                    387: 
                    388: \ save-mem extend-mem
                    389: 
                    390: has? os [IF]
                    391: : save-mem     ( addr1 u -- addr2 u ) \ gforth
                    392:     \g copy a memory block into a newly allocated region in the heap
                    393:     swap >r
                    394:     dup allocate throw
                    395:     swap 2dup r> -rot move ;
                    396: 
                    397: : extend-mem   ( addr1 u1 u -- addr addr2 u2 )
                    398:     \ extend memory block allocated from the heap by u aus
                    399:     \ the (possibly reallocated piece is addr2 u2, the extension is at addr
                    400:     over >r + dup >r resize throw
                    401:     r> over r> + -rot ;
                    402: [THEN]
                    403: 
                    404: \ EVALUATE                                              17may93jaw
                    405: 
                    406: has? file 0= [IF]
                    407: : push-file  ( -- )  r>
                    408:   sourceline# >r  tibstack @ >r  >tib @ >r  #tib @ >r
                    409:   >tib @ tibstack @ = IF  r@ tibstack +!  THEN
                    410:   tibstack @ >tib ! >in @ >r  >r ;
                    411: 
                    412: : pop-file   ( throw-code -- throw-code )
                    413:   r>
                    414:   r> >in !  r> #tib !  r> >tib !  r> tibstack !  r> loadline !  >r ;
                    415: [THEN]
                    416: 
                    417: : evaluate ( c-addr len -- ) \ core,block
                    418:   push-file  #tib ! >tib !
                    419:   >in off blk off loadfile off -1 loadline !
                    420:   ['] interpret catch
                    421:   pop-file throw ;
                    422: 
                    423: \ \ Quit                                               13feb93py
                    424: 
                    425: Defer 'quit
                    426: 
                    427: Defer .status
                    428: 
                    429: : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;
                    430: 
                    431: : (Query)  ( -- )
                    432:     loadfile off  blk off  refill drop ;
                    433: 
                    434: : (quit)  BEGIN  .status cr (query) interpret prompt  AGAIN ;
                    435: 
                    436: ' (quit) IS 'quit
                    437: 
                    438: \ \ DOERROR (DOERROR)                                  13jun93jaw
                    439: 
                    440: 8 Constant max-errors
                    441: Variable error-stack  0 error-stack !
                    442: max-errors 6 * cells allot
                    443: \ format of one cell:
                    444: \ source ( addr u )
                    445: \ >in
                    446: \ line-number
                    447: \ Loadfilename ( addr u )
                    448: 
                    449: : dec. ( n -- ) \ gforth
                    450:     \ print value in decimal representation
                    451:     base @ decimal swap . base ! ;
                    452: 
                    453: : hex. ( u -- ) \ gforth
                    454:     \ print value as unsigned hex number
                    455:     '$ emit base @ swap hex u. base ! ;
                    456: 
                    457: : typewhite ( addr u -- ) \ gforth
                    458:     \ like type, but white space is printed instead of the characters
                    459:     bounds ?do
                    460:        i c@ #tab = if \ check for tab
                    461:            #tab
                    462:        else
                    463:            bl
                    464:        then
                    465:        emit
                    466:     loop ;
                    467: 
                    468: DEFER DOERROR
                    469: 
                    470: : .error-frame ( addr1 u1 n1 n2 addr2 u2 -- )
                    471:   cr error-stack @
                    472:   IF
                    473:      ." in file included from "
                    474:      type ." :" dec.  drop 2drop
                    475:   ELSE
                    476:      type ." :" dec.
                    477:      cr dup 2over type cr drop
                    478:      nip -trailing 1- ( line-start index2 )
                    479:      0 >r  BEGIN
                    480:                   2dup + c@ bl >  WHILE
                    481:                  r> 1+ >r  1- dup 0<  UNTIL  THEN  1+
                    482:      ( line-start index1 )
                    483:      typewhite
                    484:      r> 1 max 0 ?do \ we want at least one "^", even if the length is 0
                    485:                   [char] ^ emit
                    486:      loop
                    487:   THEN
                    488: ;
                    489: 
                    490: : (DoError) ( throw-code -- )
                    491:   [ has? os [IF] ]
                    492:       outfile-id dup flush-file drop >r
                    493:       stderr to outfile-id
                    494:   [ [THEN] ] 
                    495:   sourceline# IF
                    496:                source >in @ sourceline# 0 0 .error-frame
                    497:   THEN
                    498:   error-stack @ 0 ?DO
                    499:     -1 error-stack +!
                    500:     error-stack dup @ 6 * cells + cell+
                    501:     6 cells bounds DO
                    502:       I @
                    503:     cell +LOOP
                    504:     .error-frame
                    505:   LOOP
                    506:   dup -2 =
                    507:   IF 
                    508:      "error @ ?dup
                    509:      IF
                    510:         cr count type 
                    511:      THEN
                    512:      drop
                    513:   ELSE
                    514:      .error
                    515:   THEN
                    516:   normal-dp dpp ! 
                    517:   [ has? os [IF] ] r> to outfile-id [ [THEN] ]
                    518:   ;
                    519: 
                    520: ' (DoError) IS DoError
                    521: 
                    522: : quit ( ?? -- ?? ) \ core
                    523:     rp0 @ rp! handler off >tib @ >r
                    524:     BEGIN
                    525:        [ has? compiler [IF] ]
                    526:        postpone [
                    527:        [ [THEN] ]
                    528:        ['] 'quit CATCH dup
                    529:     WHILE
                    530:        DoError r@ >tib ! r@ tibstack !
                    531:     REPEAT
                    532:     drop r> >tib ! ;
                    533: 
                    534: \ \ Cold Boot                                          13feb93py
                    535: 
                    536: : (bootmessage)
                    537:     ." GForth " version-string type 
                    538:     ." , Copyright (C) 1994-1998 Free Software Foundation, Inc." cr
                    539:     ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'"
                    540: [ has? os [IF] ]
                    541:      cr ." Type `bye' to exit"
                    542: [ [THEN] ] ;
                    543: 
                    544: defer bootmessage
                    545: defer process-args
                    546: 
                    547: ' (bootmessage) IS bootmessage
                    548: 
                    549: Defer 'cold 
                    550: \ hook (deferred word) for things to do right before interpreting the
                    551: \ command-line arguments
                    552: ' noop IS 'cold
                    553: 
1.2       anton     554: include ../chains.fs
1.1       pazsan    555: 
                    556: Variable init8
                    557: 
                    558: : cold ( -- ) \ gforth
                    559: [ has? file [IF] ]
                    560:     pathstring 2@ fpath only-path 
                    561:     init-included-files
                    562: [ [THEN] ]
                    563:     'cold
                    564:     init8 chainperform
                    565: [ has? file [IF] ]
                    566:     ['] process-args catch ?dup
                    567:     IF
                    568:       dup >r DoError cr r> negate (bye)
                    569:     THEN
                    570:     argc @ 1 >
                    571:     IF \ there may be some unfinished line, so let's finish it
                    572:        cr
                    573:     THEN
                    574: [ [THEN] ]
                    575:     bootmessage
                    576:     loadline off quit ;
                    577: 
                    578: : boot ( path **argv argc -- )
                    579:     main-task up!
                    580: [ has? os [IF] ]
                    581:     stdout TO outfile-id
                    582: \ !! [ [THEN] ]
                    583: \ !! [ has? file [IF] ]
                    584:     argc ! argv ! pathstring 2!
                    585: [ [THEN] ]
                    586:     sp@ sp0 !
                    587: [ has? glocals [IF] ]
                    588:     lp@ forthstart 7 cells + @ - 
                    589: [ [ELSE] ]
                    590:     [ has? os [IF] ]
                    591:     sp@ $1040 +
                    592:     [ [ELSE] ]
                    593:     sp@ $40 +
                    594:     [ [THEN] ]
                    595: [ [THEN] ]
                    596:     dup >tib ! tibstack ! #tib off >in off
                    597:     rp@ rp0 !
                    598: [ has? floating [IF] ]
                    599:     fp@ fp0 !
                    600: [ [THEN] ]
                    601:     ['] cold catch DoError
                    602: [ has? os [IF] ]
                    603:     bye
                    604: [ [THEN] ]
                    605: ;
                    606: 
                    607: has? os [IF]
                    608: : bye ( -- ) \ tools-ext
                    609: [ has? file [IF] ]
                    610:     script? 0= IF  cr  THEN
                    611: [ [ELSE] ]
                    612:     cr
                    613: [ [THEN] ]
                    614:     0 (bye) ;
                    615: [THEN]
                    616: 
                    617: \ **argv may be scanned by the C starter to get some important
                    618: \ information, as -display and -geometry for an X client FORTH
                    619: \ or space and stackspace overrides
                    620: 
                    621: \ 0 arg contains, however, the name of the program.
                    622: 

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