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

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: 
                    277: const Create ???  0 , 3 c, char ? c, char ? c, char ? c,
                    278: \ ??? is used by dovar:, must be created/:dovar
                    279: 
                    280: : >head ( cfa -- nt ) \ gforth  to-name
                    281:  $21 cell do
                    282:    dup i - count $9F and + cfaligned over alias-mask + = if
                    283:      i - cell - unloop exit
                    284:    then
                    285:  cell +loop
                    286:  drop ??? ( wouldn't 0 be better? ) ;
                    287: 
                    288: ' >head ALIAS >name
                    289: 
                    290: : body> 0 >body - ;
                    291: 
                    292: : (search-wordlist)  ( addr count wid -- nt / false )
                    293:     dup wordlist-map @ find-method perform ;
                    294: 
                    295: : search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search
                    296:     \ xt is the interpretation semantics
                    297:     (search-wordlist) dup if
                    298:        (name>intn)
                    299:     then ;
                    300: 
                    301: : find-name ( c-addr u -- nt/0 ) \ gforth
                    302:     \g Find the name @var{c-addr u} in the current search
                    303:     \g order. Return its nt, if found, otherwise 0.
                    304:     lookup @ (search-wordlist) ;
                    305: 
                    306: : sfind ( c-addr u -- 0 / xt +-1  ) \ gforth-obsolete
                    307:     find-name dup
                    308:     if ( nt )
                    309:        state @
                    310:        if
                    311:            (name>comp)
                    312:        else
                    313:            (name>intn)
                    314:        then
                    315:    then ;
                    316: 
                    317: : find ( c-addr -- xt +-1 / c-addr 0 ) \ core,search
                    318:     dup count sfind dup
                    319:     if
                    320:        rot drop
                    321:     then ;
                    322: 
                    323: \ ticks
                    324: 
                    325: : (') ( "name" -- nt ) \ gforth
                    326:     name find-name dup 0=
                    327:     IF
                    328:        drop -&13 bounce
                    329:     THEN  ;
                    330: 
                    331: : '    ( "name" -- xt ) \ core tick
                    332:     \g @var{xt} represents @var{name}'s interpretation
                    333:     \g semantics. Performs @code{-14 throw} if the word has no
                    334:     \g interpretation semantics.
                    335:     (') name?int ;
                    336: 
                    337: \ \ the interpreter loop                                 mar92py
                    338: 
                    339: \ interpret                                            10mar92py
                    340: 
                    341: Defer parser
                    342: Defer name ( -- c-addr count ) \ gforth
                    343: \ get the next word from the input buffer
                    344: ' (name) IS name
                    345: Defer compiler-notfound ( c-addr count -- )
                    346: Defer interpreter-notfound ( c-addr count -- )
                    347: 
                    348: : no.extensions  ( addr u -- )
                    349:     2drop -&13 bounce ;
                    350: ' no.extensions IS compiler-notfound
                    351: ' no.extensions IS interpreter-notfound
                    352: 
                    353: : interpret ( ?? -- ?? ) \ gforth
                    354:     \ interpret/compile the (rest of the) input buffer
                    355:     BEGIN
                    356:        ?stack name dup
                    357:     WHILE
                    358:        parser
                    359:     REPEAT
                    360:     2drop ;
                    361: 
                    362: \ interpreter                                  30apr92py
                    363: 
                    364: \ not the most efficient implementations of interpreter and compiler
1.12      pazsan    365: | : interpreter ( c-addr u -- ) 
1.1       pazsan    366:     2dup find-name dup
                    367:     if
                    368:        nip nip name>int execute
                    369:     else
                    370:        drop
                    371:        2dup 2>r snumber?
                    372:        IF
                    373:            2rdrop
                    374:        ELSE
                    375:            2r> interpreter-notfound
                    376:        THEN
                    377:     then ;
                    378: 
                    379: ' interpreter  IS  parser
                    380: 
                    381: \ \ Query Evaluate                                     07apr93py
                    382: 
                    383: has? file 0= [IF]
1.12      pazsan    384: : sourceline# ( -- n )  1 ;
1.1       pazsan    385: [THEN]
                    386: 
                    387: : refill ( -- flag ) \ core-ext,block-ext,file-ext
1.12      pazsan    388:     [ has? file [IF] ]
                    389:        blk @  IF  1 blk +!  true  0 >in !  EXIT  THEN
                    390:        [ [THEN] ]
                    391:     tib /line
                    392:     [ has? file [IF] ]
                    393:        loadfile @ ?dup
                    394:        IF    read-line throw
                    395:        ELSE
                    396:            [ [THEN] ]
                    397:        sourceline# 0< IF 2drop false EXIT THEN
                    398:        accept true
                    399:        [ has? file [IF] ]
                    400:        THEN
                    401:        1 loadline +!
                    402:        [ [THEN] ]
                    403:     swap #tib ! 0 >in ! ;
1.1       pazsan    404: 
                    405: : query   ( -- ) \ core-ext
                    406:     \G obsolescent
1.12      pazsan    407:     [ has? file [IF] ]
                    408:        blk off loadfile off
                    409:        [ [THEN] ]
1.1       pazsan    410:     tib /line accept #tib ! 0 >in ! ;
                    411: 
                    412: \ save-mem extend-mem
                    413: 
                    414: has? os [IF]
                    415: : save-mem     ( addr1 u -- addr2 u ) \ gforth
                    416:     \g copy a memory block into a newly allocated region in the heap
                    417:     swap >r
                    418:     dup allocate throw
                    419:     swap 2dup r> -rot move ;
                    420: 
                    421: : extend-mem   ( addr1 u1 u -- addr addr2 u2 )
                    422:     \ extend memory block allocated from the heap by u aus
                    423:     \ the (possibly reallocated piece is addr2 u2, the extension is at addr
                    424:     over >r + dup >r resize throw
                    425:     r> over r> + -rot ;
                    426: [THEN]
                    427: 
                    428: \ EVALUATE                                              17may93jaw
                    429: 
                    430: has? file 0= [IF]
                    431: : push-file  ( -- )  r>
1.12      pazsan    432:   tibstack @ >r  >tib @ >r  #tib @ >r
1.1       pazsan    433:   >tib @ tibstack @ = IF  r@ tibstack +!  THEN
                    434:   tibstack @ >tib ! >in @ >r  >r ;
                    435: 
                    436: : pop-file   ( throw-code -- throw-code )
                    437:   r>
1.12      pazsan    438:   r> >in !  r> #tib !  r> >tib !  r> tibstack !  >r ;
1.1       pazsan    439: [THEN]
                    440: 
                    441: : evaluate ( c-addr len -- ) \ core,block
                    442:   push-file  #tib ! >tib !
1.12      pazsan    443:   >in off
                    444:   [ has? file [IF] ]
                    445:       blk off loadfile off -1 loadline !
                    446:       [ [THEN] ]
1.1       pazsan    447:   ['] interpret catch
                    448:   pop-file throw ;
                    449: 
                    450: \ \ Quit                                               13feb93py
                    451: 
                    452: Defer 'quit
                    453: 
                    454: Defer .status
                    455: 
                    456: : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;
                    457: 
                    458: : (Query)  ( -- )
1.12      pazsan    459:     [ has? file [IF] ]
                    460:        loadfile off  blk off loadline off
                    461:        [ [THEN] ]
                    462:     refill drop ;
1.1       pazsan    463: 
                    464: : (quit)  BEGIN  .status cr (query) interpret prompt  AGAIN ;
                    465: 
                    466: ' (quit) IS 'quit
                    467: 
                    468: \ \ DOERROR (DOERROR)                                  13jun93jaw
                    469: 
                    470: 8 Constant max-errors
                    471: Variable error-stack  0 error-stack !
                    472: max-errors 6 * cells allot
                    473: \ format of one cell:
                    474: \ source ( addr u )
                    475: \ >in
                    476: \ line-number
                    477: \ Loadfilename ( addr u )
                    478: 
                    479: : dec. ( n -- ) \ gforth
                    480:     \ print value in decimal representation
                    481:     base @ decimal swap . base ! ;
                    482: 
                    483: : hex. ( u -- ) \ gforth
                    484:     \ print value as unsigned hex number
                    485:     '$ emit base @ swap hex u. base ! ;
                    486: 
                    487: : typewhite ( addr u -- ) \ gforth
                    488:     \ like type, but white space is printed instead of the characters
                    489:     bounds ?do
                    490:        i c@ #tab = if \ check for tab
                    491:            #tab
                    492:        else
                    493:            bl
                    494:        then
                    495:        emit
                    496:     loop ;
                    497: 
                    498: DEFER DOERROR
                    499: 
                    500: : .error-frame ( addr1 u1 n1 n2 addr2 u2 -- )
                    501:   cr error-stack @
                    502:   IF
                    503:      ." in file included from "
                    504:      type ." :" dec.  drop 2drop
                    505:   ELSE
                    506:      type ." :" dec.
                    507:      cr dup 2over type cr drop
                    508:      nip -trailing 1- ( line-start index2 )
                    509:      0 >r  BEGIN
                    510:                   2dup + c@ bl >  WHILE
                    511:                  r> 1+ >r  1- dup 0<  UNTIL  THEN  1+
                    512:      ( line-start index1 )
                    513:      typewhite
                    514:      r> 1 max 0 ?do \ we want at least one "^", even if the length is 0
                    515:                   [char] ^ emit
                    516:      loop
                    517:   THEN
                    518: ;
                    519: 
                    520: : (DoError) ( throw-code -- )
                    521:   [ has? os [IF] ]
1.8       pazsan    522:       >stderr
1.1       pazsan    523:   [ [THEN] ] 
                    524:   sourceline# IF
1.8       pazsan    525:       source >in @ sourceline# 0 0 .error-frame
1.1       pazsan    526:   THEN
                    527:   error-stack @ 0 ?DO
                    528:     -1 error-stack +!
                    529:     error-stack dup @ 6 * cells + cell+
                    530:     6 cells bounds DO
                    531:       I @
                    532:     cell +LOOP
                    533:     .error-frame
                    534:   LOOP
                    535:   dup -2 =
                    536:   IF 
                    537:      "error @ ?dup
                    538:      IF
                    539:         cr count type 
                    540:      THEN
                    541:      drop
                    542:   ELSE
                    543:      .error
                    544:   THEN
1.8       pazsan    545:   normal-dp dpp ! ;
1.1       pazsan    546: 
                    547: ' (DoError) IS DoError
                    548: 
                    549: : quit ( ?? -- ?? ) \ core
1.5       anton     550:     rp0 @ rp! handler off clear-tibstack >tib @ >r
1.1       pazsan    551:     BEGIN
                    552:        [ has? compiler [IF] ]
                    553:        postpone [
                    554:        [ [THEN] ]
                    555:        ['] 'quit CATCH dup
                    556:     WHILE
                    557:        DoError r@ >tib ! r@ tibstack !
                    558:     REPEAT
                    559:     drop r> >tib ! ;
                    560: 
                    561: \ \ Cold Boot                                          13feb93py
                    562: 
                    563: : (bootmessage)
                    564:     ." GForth " version-string type 
1.11      anton     565:     ." , Copyright (C) 1998 Free Software Foundation, Inc." cr
1.1       pazsan    566:     ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'"
                    567: [ has? os [IF] ]
                    568:      cr ." Type `bye' to exit"
                    569: [ [THEN] ] ;
                    570: 
                    571: defer bootmessage
                    572: defer process-args
                    573: 
                    574: ' (bootmessage) IS bootmessage
                    575: 
1.10      anton     576: Defer 'cold ( -- ) \ gforth  tick-cold
1.1       pazsan    577: \ hook (deferred word) for things to do right before interpreting the
                    578: \ command-line arguments
                    579: ' noop IS 'cold
                    580: 
1.2       anton     581: include ../chains.fs
1.1       pazsan    582: 
                    583: Variable init8
                    584: 
                    585: : cold ( -- ) \ gforth
                    586: [ has? file [IF] ]
                    587:     pathstring 2@ fpath only-path 
                    588:     init-included-files
                    589: [ [THEN] ]
                    590:     'cold
                    591:     init8 chainperform
                    592: [ has? file [IF] ]
1.8       pazsan    593:     process-args
1.12      pazsan    594:     loadline off
1.1       pazsan    595: [ [THEN] ]
                    596:     bootmessage
1.12      pazsan    597:     quit ;
1.1       pazsan    598: 
1.5       anton     599: : clear-tibstack ( -- )
                    600: [ has? glocals [IF] ]
                    601:     lp@ forthstart 7 cells + @ - 
                    602: [ [ELSE] ]
                    603:     [ has? os [IF] ]
1.8       pazsan    604:     r0 @ forthstart 6 cells + @ -
1.5       anton     605:     [ [ELSE] ]
                    606:     sp@ $40 +
                    607:     [ [THEN] ]
                    608: [ [THEN] ]
                    609:     dup >tib ! tibstack ! #tib off >in off ;
                    610: 
1.1       pazsan    611: : boot ( path **argv argc -- )
                    612:     main-task up!
                    613: [ has? os [IF] ]
                    614:     stdout TO outfile-id
1.7       pazsan    615:     stdin  TO infile-id
1.1       pazsan    616: \ !! [ [THEN] ]
                    617: \ !! [ has? file [IF] ]
                    618:     argc ! argv ! pathstring 2!
                    619: [ [THEN] ]
                    620:     sp@ sp0 !
1.5       anton     621:     clear-tibstack
1.1       pazsan    622:     rp@ rp0 !
                    623: [ has? floating [IF] ]
                    624:     fp@ fp0 !
                    625: [ [THEN] ]
1.8       pazsan    626:     ['] cold catch DoError cr
1.1       pazsan    627: [ has? os [IF] ]
                    628:     bye
                    629: [ [THEN] ]
                    630: ;
                    631: 
                    632: has? os [IF]
                    633: : bye ( -- ) \ tools-ext
                    634: [ has? file [IF] ]
                    635:     script? 0= IF  cr  THEN
                    636: [ [ELSE] ]
                    637:     cr
                    638: [ [THEN] ]
                    639:     0 (bye) ;
                    640: [THEN]
                    641: 
                    642: \ **argv may be scanned by the C starter to get some important
                    643: \ information, as -display and -geometry for an X client FORTH
                    644: \ or space and stackspace overrides
                    645: 
                    646: \ 0 arg contains, however, the name of the program.
                    647: 

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