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

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

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