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

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

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