Annotation of gforth/kernel.fs, revision 1.14

1.1       pazsan      1: \ kernel.fs    GForth kernel                        17dec92py
                      2: 
                      3: \ Copyright (C) 1995 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: 
                     21: \ Idea and implementation: Bernd Paysan (py)
                     22: 
                     23: HEX
                     24: 
                     25: \ labels for some code addresses
                     26: 
                     27: : docon: ( -- addr )   \ gforth
1.3       pazsan     28:     \G the code address of a @code{CONSTANT}
1.1       pazsan     29:     ['] bl >code-address ;
                     30: 
                     31: : docol: ( -- addr )   \ gforth
1.3       pazsan     32:     \G the code address of a colon definition
1.1       pazsan     33:     ['] docon: >code-address ;
                     34: 
                     35: : dovar: ( -- addr )   \ gforth
1.3       pazsan     36:     \G the code address of a @code{CREATE}d word
1.1       pazsan     37:     ['] udp >code-address ;
                     38: 
                     39: : douser: ( -- addr )  \ gforth
1.3       pazsan     40:     \G the code address of a @code{USER} variable
1.1       pazsan     41:     ['] s0 >code-address ;
                     42: 
                     43: : dodefer: ( -- addr ) \ gforth
1.3       pazsan     44:     \G the code address of a @code{defer}ed word
1.1       pazsan     45:     ['] source >code-address ;
                     46: 
                     47: : dofield: ( -- addr ) \ gforth
1.3       pazsan     48:     \G the code address of a @code{field}
1.1       pazsan     49:     ['] reveal-method >code-address ;
                     50: 
                     51: NIL AConstant NIL \ gforth
                     52: 
1.13      pazsan     53: \ Aliases
                     54: 
                     55: ' i Alias r@
                     56: 
1.1       pazsan     57: \ Bit string manipulation                              06oct92py
                     58: 
                     59: \ Create bits  80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
                     60: \ DOES> ( n -- )  + c@ ;
                     61: 
                     62: \ : >bit  ( addr n -- c-addr mask )  8 /mod rot + swap bits ;
                     63: \ : +bit  ( addr n -- )  >bit over c@ or swap c! ;
                     64: 
                     65: \ : relinfo ( -- addr )  forthstart dup @ + !!bug!! ;
                     66: \ : >rel  ( addr -- n )  forthstart - ;
                     67: \ : relon ( addr -- )  relinfo swap >rel cell / +bit ;
                     68: 
                     69: \ here allot , c, A,                                   17dec92py
                     70: 
                     71: : dp   ( -- addr ) \ gforth
                     72:     dpp @ ;
                     73: : here  ( -- here ) \ core
                     74:     dp @ ;
                     75: : allot ( n -- ) \ core
                     76:     dp +! ;
                     77: : c,    ( c -- ) \ core
                     78:     here 1 chars allot c! ;
                     79: : ,     ( x -- ) \ core
                     80:     here cell allot  ! ;
                     81: : 2,   ( w1 w2 -- ) \ gforth
                     82:     here 2 cells allot 2! ;
                     83: 
                     84: \ : aligned ( addr -- addr' ) \ core
                     85: \     [ cell 1- ] Literal + [ -1 cells ] Literal and ;
                     86: : align ( -- ) \ core
                     87:     here dup aligned swap ?DO  bl c,  LOOP ;
                     88: 
                     89: \ : faligned ( addr -- f-addr ) \ float
                     90: \     [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
                     91: 
                     92: : falign ( -- ) \ float
                     93:     here dup faligned swap
                     94:     ?DO
                     95:        bl c,
                     96:     LOOP ;
                     97: 
                     98: \ !! this is machine-dependent, but works on all but the strangest machines
1.14    ! pazsan     99: 
        !           100: : maxaligned ( addr -- f-addr ) \ float
        !           101:     [ /maxalign 1 - ] Literal + [ 0 /maxalign - ] Literal and ;
        !           102: : maxalign ( -- ) \ float
        !           103:     here dup maxaligned swap
        !           104:     ?DO
        !           105:        bl c,
        !           106:     LOOP ;
1.1       pazsan    107: 
                    108: \ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned"
                    109: ' maxaligned Alias cfaligned ( addr1 -- addr2 ) \ gforth
                    110: \ the code field is aligned if its body is maxaligned
                    111: ' maxalign Alias cfalign ( -- ) \ gforth
                    112: 
                    113: : chars ( n1 -- n2 ) \ core
                    114: ; immediate
                    115: 
                    116: 
                    117: \ : A!    ( addr1 addr2 -- ) \ gforth
                    118: \    dup relon ! ;
                    119: \ : A,    ( addr -- ) \ gforth
                    120: \    here cell allot A! ;
                    121: ' ! alias A! ( addr1 addr2 -- ) \ gforth
                    122: ' , alias A, ( addr -- ) \ gforth 
                    123: 
                    124: 
                    125: \ on off                                               23feb93py
                    126: 
                    127: : on  ( addr -- ) \ gforth
                    128:     true  swap ! ;
                    129: : off ( addr -- ) \ gforth
                    130:     false swap ! ;
                    131: 
                    132: \ dabs roll                                           17may93jaw
                    133: 
                    134: : dabs ( d1 -- d2 ) \ double
                    135:     dup 0< IF dnegate THEN ;
                    136: 
                    137: : roll  ( x0 x1 .. xn n -- x1 .. xn x0 ) \ core-ext
                    138:   dup 1+ pick >r
                    139:   cells sp@ cell+ dup cell+ rot move drop r> ;
                    140: 
                    141: \ name> found                                          17dec92py
                    142: 
                    143: $80 constant alias-mask \ set when the word is not an alias!
                    144: $40 constant immediate-mask
                    145: $20 constant restrict-mask
                    146: 
                    147: : ((name>))  ( nfa -- cfa )
                    148:     name>string +  cfaligned ;
                    149: 
                    150: : (name>x) ( nfa -- cfa b )
                    151:     \ cfa is an intermediate cfa and b is the flags byte of nfa
                    152:     dup ((name>))
                    153:     swap cell+ c@ dup alias-mask and 0=
                    154:     IF
                    155:        swap @ swap
                    156:     THEN ;
                    157: 
                    158: \ place bounds                                         13feb93py
                    159: 
                    160: : place  ( addr len to -- ) \ gforth
                    161:     over >r  rot over 1+  r> move c! ;
                    162: : bounds ( beg count -- end beg ) \ gforth
                    163:     over + swap ;
                    164: 
                    165: \ input stream primitives                              23feb93py
                    166: 
                    167: : tib ( -- c-addr ) \ core-ext
                    168:     \ obsolescent
                    169:     >tib @ ;
                    170: Defer source ( -- addr count ) \ core
                    171: \ used by dodefer:, must be defer
                    172: : (source) ( -- addr count )
                    173:     tib #tib @ ;
                    174: ' (source) IS source
                    175: 
                    176: \ (word)                                               22feb93py
                    177: 
                    178: : scan   ( addr1 n1 char -- addr2 n2 ) \ gforth
                    179:     \ skip all characters not equal to char
                    180:     >r
                    181:     BEGIN
                    182:        dup
                    183:     WHILE
                    184:        over c@ r@ <>
                    185:     WHILE
                    186:        1 /string
                    187:     REPEAT  THEN
                    188:     rdrop ;
                    189: : skip   ( addr1 n1 char -- addr2 n2 ) \ gforth
                    190:     \ skip all characters equal to char
                    191:     >r
                    192:     BEGIN
                    193:        dup
                    194:     WHILE
                    195:        over c@ r@  =
                    196:     WHILE
                    197:        1 /string
                    198:     REPEAT  THEN
                    199:     rdrop ;
                    200: 
                    201: : (word) ( addr1 n1 char -- addr2 n2 )
                    202:   dup >r skip 2dup r> scan  nip - ;
                    203: 
                    204: \ (word) should fold white spaces
                    205: \ this is what (parse-white) does
                    206: 
                    207: \ word parse                                           23feb93py
                    208: 
                    209: : parse-word  ( char -- addr len ) \ gforth
                    210:   source 2dup >r >r >in @ over min /string
                    211:   rot dup bl = IF  drop (parse-white)  ELSE  (word)  THEN
                    212:   2dup + r> - 1+ r> min >in ! ;
                    213: : word   ( char -- addr ) \ core
                    214:   parse-word here place  bl here count + c!  here ;
                    215: 
                    216: : parse    ( char -- addr len ) \ core-ext
                    217:   >r  source  >in @ over min /string  over  swap r>  scan >r
                    218:   over - dup r> IF 1+ THEN  >in +! ;
                    219: 
                    220: \ name                                                 13feb93py
                    221: 
                    222: : capitalize ( addr len -- addr len ) \ gforth
                    223:   2dup chars chars bounds
                    224:   ?DO  I c@ toupper I c! 1 chars +LOOP ;
                    225: : (name) ( -- c-addr count )
                    226:     source 2dup >r >r >in @ /string (parse-white)
                    227:     2dup + r> - 1+ r> min >in ! ;
                    228: \    name count ;
                    229: 
                    230: : name-too-short? ( c-addr u -- c-addr u )
                    231:     dup 0= -&16 and throw ;
                    232: 
                    233: : name-too-long? ( c-addr u -- c-addr u )
                    234:     dup $1F u> -&19 and throw ;
                    235: 
                    236: \ Literal                                              17dec92py
                    237: 
                    238: : Literal  ( compilation n -- ; run-time -- n ) \ core
                    239:     postpone lit  , ; immediate restrict
                    240: : ALiteral ( compilation addr -- ; run-time -- addr ) \ gforth
                    241:     postpone lit A, ; immediate restrict
                    242: 
                    243: : char   ( 'char' -- n ) \ core
                    244:     bl word char+ c@ ;
                    245: : [char] ( compilation 'char' -- ; run-time -- n )
                    246:     char postpone Literal ; immediate restrict
                    247: 
                    248: : (compile) ( -- ) \ gforth
                    249:     r> dup cell+ >r @ compile, ;
                    250: 
1.5       anton     251: : postpone, ( w xt -- )
                    252:     \g Compiles the compilation semantics represented by @var{w xt}.
                    253:     dup ['] execute =
                    254:     if
                    255:        drop compile,
                    256:     else
                    257:        dup ['] compile, =
                    258:        if
                    259:            drop POSTPONE (compile) compile,
                    260:        else
                    261:            swap POSTPONE aliteral compile,
                    262:        then
                    263:     then ;
                    264: 
                    265: : POSTPONE ( "name" -- ) \ core
                    266:     \g Compiles the compilation semantics of @var{name}.
                    267:     COMP' postpone, ; immediate restrict
1.1       pazsan    268: 
1.2       anton     269: : interpret/compile: ( interp-xt comp-xt "name" -- ) \ gforth
1.1       pazsan    270:     Create immediate swap A, A,
                    271: DOES>
                    272:     abort" executed primary cfa of an interpret/compile: word" ;
                    273: \    state @ IF  cell+  THEN  perform ;
                    274: 
                    275: \ Use (compile) for the old behavior of compile!
                    276: 
                    277: \ digit?                                               17dec92py
                    278: 
                    279: : digit?   ( char -- digit true/ false ) \ gforth
                    280:   base @ $100 =
                    281:   IF
                    282:     true EXIT
                    283:   THEN
                    284:   toupper [char] 0 - dup 9 u> IF
                    285:     [ 'A '9 1 + -  ] literal -
                    286:     dup 9 u<= IF
                    287:       drop false EXIT
                    288:     THEN
                    289:   THEN
                    290:   dup base @ u>= IF
                    291:     drop false EXIT
                    292:   THEN
                    293:   true ;
                    294: 
                    295: : accumulate ( +d0 addr digit - +d1 addr )
                    296:   swap >r swap  base @  um* drop rot  base @  um* d+ r> ;
                    297: 
                    298: : >number ( d addr count -- d addr count ) \ core
                    299:     0
                    300:     ?DO
                    301:        count digit?
                    302:     WHILE
                    303:        accumulate
                    304:     LOOP
                    305:         0
                    306:     ELSE
                    307:        1- I' I -
                    308:        UNLOOP
                    309:     THEN ;
                    310: 
                    311: \ number? number                                       23feb93py
                    312: 
                    313: Create bases   10 ,   2 ,   A , 100 ,
1.3       pazsan    314: \              16     2    10   character
1.1       pazsan    315: \ !! this saving and restoring base is an abomination! - anton
                    316: : getbase ( addr u -- addr' u' )
                    317:     over c@ [char] $ - dup 4 u<
                    318:     IF
                    319:        cells bases + @ base ! 1 /string
                    320:     ELSE
                    321:        drop
                    322:     THEN ;
                    323: : s>number ( addr len -- d )
                    324:     base @ >r  dpl on
                    325:     over c@ '- =  dup >r
                    326:     IF
                    327:        1 /string
                    328:     THEN
                    329:     getbase  dpl on  0 0 2swap
                    330:     BEGIN
                    331:        dup >r >number dup
                    332:     WHILE
                    333:        dup r> -
                    334:     WHILE
                    335:        dup dpl ! over c@ [char] . =
                    336:     WHILE
                    337:        1 /string
                    338:     REPEAT  THEN
                    339:         2drop rdrop dpl off
                    340:     ELSE
                    341:        2drop rdrop r>
                    342:        IF
                    343:            dnegate
                    344:        THEN
                    345:     THEN
                    346:     r> base ! ;
                    347: 
                    348: : snumber? ( c-addr u -- 0 / n -1 / d 0> )
                    349:     s>number dpl @ 0=
                    350:     IF
                    351:        2drop false  EXIT
                    352:     THEN
                    353:     dpl @ dup 0> 0= IF
                    354:        nip
                    355:     THEN ;
                    356: : number? ( string -- string 0 / n -1 / d 0> )
                    357:     dup >r count snumber? dup if
                    358:        rdrop
                    359:     else
                    360:        r> swap
                    361:     then ;
                    362: : s>d ( n -- d ) \ core                s-to-d
                    363:     dup 0< ;
                    364: : number ( string -- d )
                    365:     number? ?dup 0= abort" ?"  0<
                    366:     IF
                    367:        s>d
                    368:     THEN ;
                    369: 
                    370: \ space spaces ud/mod                                  21mar93py
                    371: decimal
                    372: Create spaces ( u -- ) \ core
                    373: bl 80 times \ times from target compiler! 11may93jaw
                    374: DOES>   ( u -- )
                    375:     swap
                    376:     0 max 0 ?DO  I' I - &80 min 2dup type  +LOOP  drop ;
                    377: Create backspaces
                    378: 08 80 times \ times from target compiler! 11may93jaw
                    379: DOES>   ( u -- )
                    380:     swap
                    381:     0 max 0 ?DO  I' I - &80 min 2dup type  +LOOP  drop ;
                    382: hex
                    383: : space ( -- ) \ core
                    384:     1 spaces ;
                    385: 
                    386: : ud/mod ( ud1 u2 -- urem udquot ) \ gforth
                    387:     >r 0 r@ um/mod r> swap >r
                    388:     um/mod r> ;
                    389: 
                    390: : pad    ( -- addr ) \ core-ext
                    391:   here [ $20 8 2* cells + 2 + cell+ ] Literal + aligned ;
                    392: 
                    393: \ hold <# #> sign # #s                                 25jan92py
                    394: 
                    395: : hold    ( char -- ) \ core
                    396:     pad cell - -1 chars over +! @ c! ;
                    397: 
                    398: : <# ( -- ) \ core     less-number-sign
                    399:     pad cell - dup ! ;
                    400: 
                    401: : #>      ( xd -- addr u ) \ core      number-sign-greater
                    402:     2drop pad cell - dup @ tuck - ;
                    403: 
                    404: : sign    ( n -- ) \ core
                    405:     0< IF  [char] - hold  THEN ;
                    406: 
                    407: : #       ( ud1 -- ud2 ) \ core                number-sign
                    408:     base @ 2 max ud/mod rot 9 over <
                    409:     IF
                    410:        [ char A char 9 - 1- ] Literal +
                    411:     THEN
                    412:     [char] 0 + hold ;
                    413: 
                    414: : #s      ( +d -- 0 0 ) \ core number-sign-s
                    415:     BEGIN
1.14    ! pazsan    416:        # 2dup or 0=
1.1       pazsan    417:     UNTIL ;
                    418: 
                    419: \ print numbers                                        07jun92py
                    420: 
                    421: : d.r ( d n -- ) \ double      d-dot-r
                    422:     >r tuck  dabs  <# #s  rot sign #>
                    423:     r> over - spaces  type ;
                    424: 
                    425: : ud.r ( ud n -- ) \ gforth    u-d-dot-r
                    426:     >r <# #s #> r> over - spaces type ;
                    427: 
                    428: : .r ( n1 n2 -- ) \ core-ext   dot-r
                    429:     >r s>d r> d.r ;
                    430: : u.r ( u n -- )  \ core-ext   u-dot-r
                    431:     0 swap ud.r ;
                    432: 
                    433: : d. ( d -- ) \ double d-dot
                    434:     0 d.r space ;
                    435: : ud. ( ud -- ) \ gforth       u-d-dot
                    436:     0 ud.r space ;
                    437: 
                    438: : . ( n -- ) \ core    dot
                    439:     s>d d. ;
                    440: : u. ( u -- ) \ core   u-dot
                    441:     0 ud. ;
                    442: 
                    443: \ catch throw                                          23feb93py
                    444: \ bounce                                                08jun93jaw
                    445: 
                    446: \ !! allow the user to add rollback actions    anton
                    447: \ !! use a separate exception stack?           anton
                    448: 
1.14    ! pazsan    449: has-locals [IF]
1.1       pazsan    450: : lp@ ( -- addr ) \ gforth     l-p-fetch
                    451:  laddr# [ 0 , ] ;
1.14    ! pazsan    452: [THEN]
1.1       pazsan    453: 
1.13      pazsan    454: Defer 'catch
                    455: Defer 'throw
                    456: 
                    457: ' noop IS 'catch
                    458: ' noop IS 'throw
                    459: 
1.1       pazsan    460: : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
1.13      pazsan    461:     'catch
1.3       pazsan    462:     sp@ >r
1.14    ! pazsan    463: [ has-floats [IF] ]
1.3       pazsan    464:     fp@ >r
1.14    ! pazsan    465: [ [THEN] ]
        !           466: [ has-locals [IF] ]
1.3       pazsan    467:     lp@ >r
1.14    ! pazsan    468: [ [THEN] ]
1.3       pazsan    469:     handler @ >r
                    470:     rp@ handler !
                    471:     execute
                    472:     r> handler ! rdrop rdrop rdrop 0 ;
1.1       pazsan    473: 
                    474: : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
                    475:     ?DUP IF
1.3       pazsan    476:        [ here 9 cells ! ] \ entry point for signal handler
                    477:        handler @ dup 0= IF
1.14    ! pazsan    478: [ has-os [IF] ]
1.3       pazsan    479:            2 (bye)
1.14    ! pazsan    480: [ [ELSE] ]
        !           481:            quit
        !           482: [ [THEN] ]
1.3       pazsan    483:        THEN
                    484:        rp!
1.1       pazsan    485:        r> handler !
1.14    ! pazsan    486: [ has-locals [IF] ]
        !           487:         r> lp!
        !           488: [ [THEN] ]
        !           489: [ has-floats [IF] ]
1.1       pazsan    490:        r> fp!
1.14    ! pazsan    491: [ [THEN] ]
1.3       pazsan    492:        r> swap >r sp! drop r>
1.13      pazsan    493:        'throw
1.1       pazsan    494:     THEN ;
                    495: 
                    496: \ Bouncing is very fine,
                    497: \ programming without wasting time...   jaw
                    498: : bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym ) \ gforth
                    499: \ a throw without data or fp stack restauration
                    500:   ?DUP IF
1.3       pazsan    501:       handler @ rp!
                    502:       r> handler !
1.14    ! pazsan    503: [ has-locals [IF] ]
1.3       pazsan    504:       r> lp!
1.14    ! pazsan    505: [ [THEN] ]
        !           506: [ has-floats [IF] ]
1.3       pazsan    507:       rdrop
1.14    ! pazsan    508: [ [THEN] ]
1.3       pazsan    509:       rdrop
1.13      pazsan    510:       'throw
1.1       pazsan    511:   THEN ;
                    512: 
                    513: \ ?stack                                               23feb93py
                    514: 
                    515: : ?stack ( ?? -- ?? ) \ gforth
1.11      pazsan    516:     sp@ s0 @ u> IF    -4 throw  THEN
1.14    ! pazsan    517: [ has-floats [IF] ]
        !           518:     fp@ f0 @ u> IF  -&45 throw  THEN
        !           519: [ [THEN] ]
        !           520: ;
1.1       pazsan    521: \ ?stack should be code -- it touches an empty stack!
                    522: 
                    523: \ interpret                                            10mar92py
                    524: 
                    525: Defer parser
                    526: Defer name ( -- c-addr count ) \ gforth
                    527: \ get the next word from the input buffer
                    528: ' (name) IS name
                    529: Defer compiler-notfound ( c-addr count -- )
                    530: Defer interpreter-notfound ( c-addr count -- )
                    531: 
                    532: : no.extensions  ( addr u -- )
                    533:     2drop -&13 bounce ;
                    534: ' no.extensions IS compiler-notfound
                    535: ' no.extensions IS interpreter-notfound
                    536: 
                    537: : compile-only-error ( ... -- )
                    538:     -&14 throw ;
                    539: 
                    540: : interpret ( ?? -- ?? ) \ gforth
                    541:     \ interpret/compile the (rest of the) input buffer
                    542:     BEGIN
                    543:        ?stack name dup
                    544:     WHILE
                    545:        parser
                    546:     REPEAT
                    547:     2drop ;
                    548: 
                    549: \ interpreter compiler                                 30apr92py
                    550: 
                    551: \ not the most efficient implementations of interpreter and compiler
                    552: : interpreter ( c-addr u -- ) 
                    553:     2dup find-name dup
                    554:     if
                    555:        nip nip name>int execute
                    556:     else
                    557:        drop
                    558:        2dup 2>r snumber?
                    559:        IF
                    560:            2rdrop
                    561:        ELSE
                    562:            2r> interpreter-notfound
                    563:        THEN
                    564:     then ;
                    565: 
                    566: : compiler ( c-addr u -- )
                    567:     2dup find-name dup
1.4       anton     568:     if ( c-addr u nt )
1.1       pazsan    569:        nip nip name>comp execute
                    570:     else
                    571:        drop
                    572:        2dup snumber? dup
                    573:        IF
                    574:            0>
                    575:            IF
                    576:                swap postpone Literal
                    577:            THEN
                    578:            postpone Literal
                    579:            2drop
                    580:        ELSE
                    581:            drop compiler-notfound
                    582:        THEN
                    583:     then ;
                    584: 
                    585: ' interpreter  IS  parser
                    586: 
                    587: : [ ( -- ) \ core      left-bracket
                    588:     ['] interpreter  IS parser state off ; immediate
                    589: : ] ( -- ) \ core      right-bracket
                    590:     ['] compiler     IS parser state on  ;
                    591: 
                    592: \ Strings                                              22feb93py
                    593: 
                    594: : ," ( "string"<"> -- ) [char] " parse
                    595:   here over char+ allot  place align ;
                    596: : "lit ( -- addr )
                    597:   r> r> dup count + aligned >r swap >r ;
                    598: : (.")     "lit count type ;
                    599: : (S")     "lit count ;
                    600: : SLiteral ( Compilation c-addr1 u ; run-time -- c-addr2 u ) \ string
                    601:     postpone (S") here over char+ allot  place align ;
                    602:                                              immediate restrict
1.12      anton     603: : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file    paren
1.13      pazsan    604:     [char] ) parse 2drop ; immediate
1.12      anton     605: 
1.1       pazsan    606: : \ ( -- ) \ core-ext backslash
                    607:     blk @
                    608:     IF
                    609:        >in @ c/l / 1+ c/l * >in !
                    610:        EXIT
                    611:     THEN
                    612:     source >in ! drop ; immediate
                    613: 
                    614: : \G ( -- ) \ gforth backslash
                    615:     POSTPONE \ ; immediate
                    616: 
                    617: \ error handling                                       22feb93py
                    618: \ 'abort thrown out!                                   11may93jaw
                    619: 
                    620: : (abort")
                    621:     "lit >r
                    622:     IF
                    623:        r> "error ! -2 throw
                    624:     THEN
                    625:     rdrop ;
                    626: : abort" ( compilation 'ccc"' -- ; run-time f -- ) \ core,exception-ext        abort-quote
                    627:     postpone (abort") ," ;        immediate restrict
                    628: 
                    629: \ Header states                                        23feb93py
                    630: 
                    631: : cset ( bmask c-addr -- )
                    632:     tuck c@ or swap c! ; 
                    633: : creset ( bmask c-addr -- )
                    634:     tuck c@ swap invert and swap c! ; 
                    635: : ctoggle ( bmask c-addr -- )
                    636:     tuck c@ xor swap c! ; 
                    637: 
                    638: : lastflags ( -- c-addr )
                    639:     \ the address of the flags byte in the last header
                    640:     \ aborts if the last defined word was headerless
                    641:     last @ dup 0= abort" last word was headerless" cell+ ;
                    642: 
1.2       anton     643: : immediate ( -- ) \ core
                    644:     immediate-mask lastflags cset ;
                    645: : restrict ( -- ) \ gforth
                    646:     restrict-mask lastflags cset ;
                    647: ' restrict alias compile-only ( -- ) \ gforth
1.1       pazsan    648: 
                    649: \ Header                                               23feb93py
                    650: 
                    651: \ input-stream, nextname and noname are quite ugly (passing
                    652: \ information through global variables), but they are useful for dealing
                    653: \ with existing/independent defining words
                    654: 
                    655: defer (header)
                    656: defer header ( -- ) \ gforth
                    657: ' (header) IS header
                    658: 
                    659: : string, ( c-addr u -- ) \ gforth
1.3       pazsan    660:     \G puts down string as cstring
1.1       pazsan    661:     dup c, here swap chars dup allot move ;
                    662: 
                    663: : header, ( c-addr u -- ) \ gforth
                    664:     name-too-long?
                    665:     align here last !
                    666:     current @ 1 or A,  \ link field; before revealing, it contains the
                    667:                        \ tagged reveal-into wordlist
                    668:     string, cfalign
                    669:     alias-mask lastflags cset ;
                    670: 
                    671: : input-stream-header ( "name" -- )
                    672:     name name-too-short? header, ;
                    673: : input-stream ( -- )  \ general
1.3       pazsan    674:     \G switches back to getting the name from the input stream ;
1.1       pazsan    675:     ['] input-stream-header IS (header) ;
                    676: 
                    677: ' input-stream-header IS (header)
                    678: 
                    679: \ !! make that a 2variable
                    680: create nextname-buffer 32 chars allot
                    681: 
                    682: : nextname-header ( -- )
                    683:     nextname-buffer count header,
                    684:     input-stream ;
                    685: 
                    686: \ the next name is given in the string
                    687: : nextname ( c-addr u -- ) \ gforth
                    688:     name-too-long?
                    689:     nextname-buffer c! ( c-addr )
                    690:     nextname-buffer count move
                    691:     ['] nextname-header IS (header) ;
                    692: 
                    693: : noname-header ( -- )
                    694:     0 last ! cfalign
                    695:     input-stream ;
                    696: 
                    697: : noname ( -- ) \ gforth
                    698: \ the next defined word remains anonymous. The xt of that word is given by lastxt
                    699:     ['] noname-header IS (header) ;
                    700: 
                    701: : lastxt ( -- xt ) \ gforth
                    702: \ xt is the execution token of the last word defined. The main purpose of this word is to get the xt of words defined using noname
                    703:     lastcfa @ ;
                    704: 
                    705: : Alias    ( cfa "name" -- ) \ gforth
                    706:     Header reveal
                    707:     alias-mask lastflags creset
                    708:     dup A, lastcfa ! ;
                    709: 
1.4       anton     710: : name>string ( nt -- addr count ) \ gforth    name-to-string
                    711:     \g @var{addr count} is the name of the word represented by @var{nt}.
                    712:     cell+ count $1F and ;
1.1       pazsan    713: 
                    714: Create ???  0 , 3 c, char ? c, char ? c, char ? c,
1.4       anton     715: : >name ( cfa -- nt ) \ gforth to-name
1.1       pazsan    716:  $21 cell do
                    717:    dup i - count $9F and + cfaligned over alias-mask + = if
                    718:      i - cell - unloop exit
                    719:    then
                    720:  cell +loop
                    721:  drop ??? ( wouldn't 0 be better? ) ;
                    722: 
                    723: \ threading                                   17mar93py
                    724: 
                    725: : cfa,     ( code-address -- )  \ gforth       cfa-comma
                    726:     here
                    727:     dup lastcfa !
                    728:     0 A, 0 ,  code-address! ;
                    729: : compile, ( xt -- )   \ core-ext      compile-comma
                    730:     A, ;
                    731: : !does    ( addr -- ) \ gforth        store-does
                    732:     lastxt does-code! ;
                    733: : (does>)  ( R: addr -- )
                    734:     r> /does-handler + !does ;
                    735: : dodoes,  ( -- )
                    736:   here /does-handler allot does-handler! ;
                    737: 
                    738: : Create ( "name" -- ) \ core
                    739:     Header reveal dovar: cfa, ;
                    740: 
                    741: \ Create Variable User Constant                        17mar93py
                    742: 
                    743: : Variable ( "name" -- ) \ core
                    744:     Create 0 , ;
                    745: : AVariable ( "name" -- ) \ gforth
                    746:     Create 0 A, ;
                    747: : 2VARIABLE ( "name" -- ) \ double
                    748:     create 0 , 0 , ;
                    749:     
                    750: : User ( "name" -- ) \ gforth
                    751:     Variable ;
                    752: : AUser ( "name" -- ) \ gforth
                    753:     AVariable ;
                    754: 
                    755: : (Constant)  Header reveal docon: cfa, ;
                    756: : Constant ( w "name" -- ) \ core
1.3       pazsan    757:     \G Defines constant @var{name}
                    758:     \G  
                    759:     \G @var{name} execution: @var{-- w}
1.1       pazsan    760:     (Constant) , ;
                    761: : AConstant ( addr "name" -- ) \ gforth
                    762:     (Constant) A, ;
                    763: 
                    764: : 2Constant ( w1 w2 "name" -- ) \ double
                    765:     Create ( w1 w2 "name" -- )
                    766:         2,
                    767:     DOES> ( -- w1 w2 )
                    768:         2@ ;
                    769:     
                    770: \ IS Defer What's Defers TO                            24feb93py
                    771: 
                    772: : Defer ( "name" -- ) \ gforth
                    773:     \ !! shouldn't it be initialized with abort or something similar?
                    774:     Header Reveal dodefer: cfa,
                    775:     ['] noop A, ;
                    776: \     Create ( -- ) 
                    777: \      ['] noop A,
                    778: \     DOES> ( ??? )
                    779: \      perform ;
                    780: 
                    781: : Defers ( "name" -- ) \ gforth
                    782:     ' >body @ compile, ; immediate
                    783: 
                    784: \ : ;                                                  24feb93py
                    785: 
                    786: defer :-hook ( sys1 -- sys2 )
                    787: defer ;-hook ( sys2 -- sys1 )
                    788: 
                    789: : : ( "name" -- colon-sys ) \ core     colon
                    790:     Header docol: cfa, defstart ] :-hook ;
                    791: : ; ( compilation colon-sys -- ; run-time nest-sys ) \ core    semicolon
                    792:     ;-hook ?struc postpone exit reveal postpone [ ; immediate restrict
                    793: 
                    794: : :noname ( -- xt colon-sys ) \ core-ext       colon-no-name
                    795:     0 last !
                    796:     cfalign here docol: cfa, 0 ] :-hook ;
                    797: 
                    798: \ Search list handling                                 23feb93py
                    799: 
                    800: AVariable current ( -- addr ) \ gforth
                    801: 
                    802: : last?   ( -- false / nfa nfa )
                    803:     last @ ?dup ;
1.4       anton     804: : (reveal) ( nt wid -- )
1.1       pazsan    805:     ( wid>wordlist-id ) dup >r
                    806:     @ over ( name>link ) ! 
                    807:     r> ! ;
                    808: 
                    809: \ object oriented search list                          17mar93py
                    810: 
                    811: \ word list structure:
                    812: 
                    813: struct
1.4       anton     814:   1 cells: field find-method   \ xt: ( c_addr u wid -- nt )
                    815:   1 cells: field reveal-method \ xt: ( nt wid -- ) \ used by dofield:, must be field
1.1       pazsan    816:   1 cells: field rehash-method \ xt: ( wid -- )
                    817: \   \ !! what else
                    818: end-struct wordlist-map-struct
                    819: 
                    820: struct
                    821:   1 cells: field wordlist-id \ not the same as wid; representation depends on implementation
                    822:   1 cells: field wordlist-map \ pointer to a wordlist-map-struct
                    823:   1 cells: field wordlist-link \ link field to other wordlists
                    824:   1 cells: field wordlist-extend \ points to wordlist extensions (eg hash)
                    825: end-struct wordlist-struct
                    826: 
1.4       anton     827: : f83find      ( addr len wordlist -- nt / false )
1.1       pazsan    828:     ( wid>wordlist-id ) @ (f83find) ;
                    829: 
                    830: \ Search list table: find reveal
                    831: Create f83search ( -- wordlist-map )
                    832:     ' f83find A,  ' (reveal) A,  ' drop A,
                    833: 
                    834: Create forth-wordlist  NIL A, G f83search T A, NIL A, NIL A,
                    835: AVariable lookup       G forth-wordlist lookup T !
                    836: G forth-wordlist current T !
                    837: 
                    838: \ higher level parts of find
                    839: 
                    840: ( struct )
                    841: 0 >body cell
                    842:   1 cells: field interpret/compile-int
                    843:   1 cells: field interpret/compile-comp
                    844: end-struct interpret/compile-struct
                    845: 
                    846: : interpret/compile? ( xt -- flag )
                    847:     >does-code ['] S" >does-code = ;
                    848: 
                    849: : (cfa>int) ( cfa -- xt )
                    850:     dup interpret/compile?
                    851:     if
                    852:        interpret/compile-int @
                    853:     then ;
                    854: 
                    855: : (x>int) ( cfa b -- xt )
                    856:     \ get interpretation semantics of name
                    857:     restrict-mask and
                    858:     if
                    859:        drop ['] compile-only-error
                    860:     else
                    861:        (cfa>int)
                    862:     then ;
                    863: 
1.4       anton     864: : name>int ( nt -- xt ) \ gforth
                    865:     \G @var{xt} represents the interpretation semantics of the word
                    866:     \G @var{nt}. Produces @code{' compile-only-error} if
                    867:     \G @var{nt} is compile-only.
1.1       pazsan    868:     (name>x) (x>int) ;
                    869: 
1.4       anton     870: : name?int ( nt -- xt ) \ gforth
                    871:     \G Like name>int, but throws an error if compile-only.
1.1       pazsan    872:     (name>x) restrict-mask and
                    873:     if
                    874:        compile-only-error \ does not return
                    875:     then
                    876:     (cfa>int) ;
                    877: 
1.4       anton     878: : name>comp ( nt -- w xt ) \ gforth
1.10      anton     879:     \G @var{w xt} is the compilation token for the word @var{nt}.
1.1       pazsan    880:     (name>x) >r dup interpret/compile?
                    881:     if
                    882:        interpret/compile-comp @
                    883:     then
                    884:     r> immediate-mask and if
                    885:        ['] execute
                    886:     else
                    887:        ['] compile,
                    888:     then ;
                    889: 
1.4       anton     890: : (search-wordlist)  ( addr count wid -- nt / false )
1.1       pazsan    891:     dup wordlist-map @ find-method perform ;
                    892: 
                    893: : flag-sign ( f -- 1|-1 )
                    894:     \ true becomes 1, false -1
                    895:     0= 2* 1+ ;
                    896: 
                    897: : (name>intn) ( nfa -- xt +-1 )
                    898:     (name>x) tuck (x>int) ( b xt )
                    899:     swap immediate-mask and flag-sign ;
                    900: 
                    901: : search-wordlist ( addr count wid -- 0 / xt +-1 ) \ search
                    902:     \ xt is the interpretation semantics
                    903:     (search-wordlist) dup if
                    904:        (name>intn)
                    905:     then ;
                    906: 
1.4       anton     907: : find-name ( c-addr u -- nt/0 ) \ gforth
                    908:     \g Find the name @var{c-addr u} in the current search
                    909:     \g order. Return its nt, if found, otherwise 0.
1.1       pazsan    910:     lookup @ (search-wordlist) ;
                    911: 
                    912: : sfind ( c-addr u -- 0 / xt +-1  ) \ gforth-obsolete
                    913:     find-name dup
1.4       anton     914:     if ( nt )
1.1       pazsan    915:        state @
                    916:        if
                    917:            name>comp ['] execute = flag-sign
                    918:        else
                    919:            (name>intn)
                    920:        then
                    921:     then ;
                    922: 
                    923: : find ( c-addr -- xt +-1 / c-addr 0 ) \ core
                    924:     dup count sfind dup
                    925:     if
                    926:        rot drop
                    927:     then ;
                    928: 
1.4       anton     929: : (') ( "name" -- nt ) \ gforth
1.1       pazsan    930:     name find-name dup 0=
                    931:     IF
                    932:        drop -&13 bounce
                    933:     THEN  ;
                    934: 
1.4       anton     935: : [(')]  ( compilation "name" -- ; run-time -- nt ) \ gforth   bracket-paren-tick
1.1       pazsan    936:     (') postpone ALiteral ; immediate restrict
                    937: 
                    938: : '    ( "name" -- xt ) \ core tick
1.4       anton     939:     \g @var{xt} represents @var{name}'s interpretation
                    940:     \g semantics. Performs @code{-14 throw} if the word has no
                    941:     \g interpretation semantics.
1.1       pazsan    942:     (') name?int ;
1.4       anton     943: : [']  ( compilation. "name" -- ; run-time. -- xt ) \ core     bracket-tick
                    944:     \g @var{xt} represents @var{name}'s interpretation
                    945:     \g semantics. Performs @code{-14 throw} if the word has no
                    946:     \g interpretation semantics.
1.1       pazsan    947:     ' postpone ALiteral ; immediate restrict
                    948: 
                    949: : COMP'    ( "name" -- w xt ) \ gforth c-tick
1.4       anton     950:     \g @var{w xt} represents @var{name}'s compilation semantics.
1.1       pazsan    951:     (') name>comp ;
                    952: : [COMP']  ( compilation "name" -- ; run-time -- w xt ) \ gforth       bracket-comp-tick
1.4       anton     953:     \g @var{w xt} represents @var{name}'s compilation semantics.
1.1       pazsan    954:     COMP' swap POSTPONE Aliteral POSTPONE ALiteral ; immediate restrict
                    955: 
                    956: \ reveal words
                    957: 
                    958: Variable warnings ( -- addr ) \ gforth
                    959: G -1 warnings T !
                    960: 
                    961: : check-shadow  ( addr count wid -- )
1.3       pazsan    962: \G prints a warning if the string is already present in the wordlist
1.1       pazsan    963:  >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if
                    964:    ." redefined " name>string 2dup type
                    965:    compare 0<> if
                    966:      ."  with " type
                    967:    else
                    968:      2drop
                    969:    then
                    970:    space space EXIT
                    971:  then
                    972:  2drop 2drop ;
                    973: 
                    974: : reveal ( -- ) \ gforth
                    975:     last?
                    976:     if \ the last word has a header
                    977:        dup ( name>link ) @ 1 and
                    978:        if \ it is still hidden
1.4       anton     979:            dup ( name>link ) @ 1 xor           ( nt wid )
                    980:            2dup >r name>string r> check-shadow ( nt wid )
1.1       pazsan    981:            dup wordlist-map @ reveal-method perform
                    982:        then
                    983:     then ;
                    984: 
                    985: : rehash  ( wid -- )
                    986:     dup wordlist-map @ rehash-method perform ;
                    987: 
                    988: \ Input                                                13feb93py
                    989: 
                    990: 07 constant #bell ( -- c ) \ gforth
                    991: 08 constant #bs ( -- c ) \ gforth
                    992: 09 constant #tab ( -- c ) \ gforth
                    993: 7F constant #del ( -- c ) \ gforth
                    994: 0D constant #cr   ( -- c ) \ gforth
                    995: \ the newline key code
                    996: 0C constant #ff ( -- c ) \ gforth
                    997: 0A constant #lf ( -- c ) \ gforth
                    998: 
                    999: : bell  #bell emit ;
                   1000: : cr ( -- ) \ core
                   1001:     \ emit a newline
                   1002:     #lf ( sic! ) emit ;
                   1003: 
                   1004: \ : backspaces  0 ?DO  #bs emit  LOOP ;
                   1005: 
                   1006: : (ins) ( max span addr pos1 key -- max span addr pos2 )
                   1007:     >r 2dup + r@ swap c! r> emit 1+ rot 1+ -rot ;
                   1008: : (bs) ( max span addr pos1 -- max span addr pos2 flag )
                   1009:     dup IF
                   1010:        #bs emit bl emit #bs emit 1- rot 1- -rot
                   1011:     THEN false ;
1.14    ! pazsan   1012: : (ret)  true bl emit ;
1.1       pazsan   1013: 
                   1014: Create ctrlkeys
                   1015:   ] false false false false  false false false false
                   1016:     (bs)  false (ret) false  false (ret) false false
                   1017:     false false false false  false false false false
                   1018:     false false false false  false false false false [
                   1019: 
                   1020: defer insert-char
                   1021: ' (ins) IS insert-char
                   1022: defer everychar
                   1023: ' noop IS everychar
                   1024: 
                   1025: : decode ( max span addr pos1 key -- max span addr pos2 flag )
                   1026:   everychar
                   1027:   dup #del = IF  drop #bs  THEN  \ del is rubout
                   1028:   dup bl <   IF  cells ctrlkeys + perform  EXIT  THEN
                   1029:   >r 2over = IF  rdrop bell 0 EXIT  THEN
                   1030:   r> insert-char 0 ;
                   1031: 
                   1032: : accept   ( addr len -- len ) \ core
                   1033:   dup 0< IF    abs over dup 1 chars - c@ tuck type 
                   1034: \ this allows to edit given strings
1.14    ! pazsan   1035:   ELSE  0  THEN rot over
1.1       pazsan   1036:   BEGIN  key decode  UNTIL
                   1037:   2drop nip ;
                   1038: 
                   1039: \ Output                                               13feb93py
                   1040: 
1.14    ! pazsan   1041: has-os [IF]
        !          1042: 0 Value outfile-id ( -- file-id ) \ gforth
        !          1043: 
1.1       pazsan   1044: : (type) ( c-addr u -- ) \ gforth
                   1045:     outfile-id write-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ?
                   1046: ;
                   1047: 
                   1048: : (emit) ( c -- ) \ gforth
                   1049:     outfile-id emit-file drop \ !! use ?DUP-IF THROW ENDIF instead of DROP ?
                   1050: ;
1.14    ! pazsan   1051: [THEN]
        !          1052: 
        !          1053: Defer type ( c-addr u -- ) \ core
        !          1054: ' (type) IS Type
1.1       pazsan   1055: 
                   1056: Defer emit ( c -- ) \ core
                   1057: ' (Emit) IS Emit
                   1058: 
                   1059: Defer key ( -- c ) \ core
                   1060: ' (key) IS key
                   1061: 
                   1062: \ Query                                                07apr93py
                   1063: 
1.14    ! pazsan   1064: has-files 0= [IF]
        !          1065: : sourceline# ( -- n )  loadline @ ;
        !          1066: [THEN]
        !          1067: 
1.1       pazsan   1068: : refill ( -- flag ) \ core-ext,block-ext,file-ext
                   1069:   blk @  IF  1 blk +!  true  0 >in !  EXIT  THEN
                   1070:   tib /line
1.14    ! pazsan   1071: [ has-files [IF] ]
1.1       pazsan   1072:   loadfile @ ?dup
                   1073:   IF    read-line throw
1.14    ! pazsan   1074:   ELSE
        !          1075: [ [THEN] ]
        !          1076:       sourceline# 0< IF 2drop false EXIT THEN
        !          1077:       accept true
        !          1078: [ has-files [IF] ]
1.1       pazsan   1079:   THEN
1.14    ! pazsan   1080: [ [THEN] ]
1.1       pazsan   1081:   1 loadline +!
                   1082:   swap #tib ! 0 >in ! ;
                   1083: 
1.8       anton    1084: : query   ( -- ) \ core-ext
1.3       pazsan   1085:     \G obsolescent
1.13      pazsan   1086:     blk off loadfile off
1.8       anton    1087:     tib /line accept #tib ! 0 >in ! ;
1.1       pazsan   1088: 
1.13      pazsan   1089: \ save-mem extend-mem
1.1       pazsan   1090: 
1.14    ! pazsan   1091: has-os [IF]
1.13      pazsan   1092: : save-mem     ( addr1 u -- addr2 u ) \ gforth
                   1093:     \g copy a memory block into a newly allocated region in the heap
                   1094:     swap >r
                   1095:     dup allocate throw
                   1096:     swap 2dup r> -rot move ;
1.1       pazsan   1097: 
1.13      pazsan   1098: : extend-mem   ( addr1 u1 u -- addr addr2 u2 )
                   1099:     \ extend memory block allocated from the heap by u aus
                   1100:     \ the (possibly reallocated piece is addr2 u2, the extension is at addr
                   1101:     over >r + dup >r resize throw
                   1102:     r> over r> + -rot ;
1.14    ! pazsan   1103: [THEN]
1.1       pazsan   1104: 
                   1105: \ HEX DECIMAL                                           2may93jaw
                   1106: 
                   1107: : decimal ( -- ) \ core
                   1108:     a base ! ;
                   1109: : hex ( -- ) \ core-ext
                   1110:     10 base ! ;
                   1111: 
                   1112: \ DEPTH                                                 9may93jaw
                   1113: 
                   1114: : depth ( -- +n ) \ core
                   1115:     sp@ s0 @ swap - cell / ;
                   1116: : clearstack ( ... -- )
                   1117:     s0 @ sp! ;
                   1118: 
                   1119: \ RECURSE                                               17may93jaw
                   1120: 
                   1121: : recurse ( compilation -- ; run-time ?? -- ?? ) \ core
                   1122:     lastxt compile, ; immediate restrict
                   1123: ' reveal alias recursive ( -- ) \ gforth
                   1124:        immediate
                   1125: 
                   1126: \ */MOD */                                              17may93jaw
                   1127: 
                   1128: \ !! I think */mod should have the same rounding behaviour as / - anton
                   1129: : */mod ( n1 n2 n3 -- n4 n5 ) \ core   star-slash-mod
                   1130:     >r m* r> sm/rem ;
                   1131: 
                   1132: : */ ( n1 n2 n3 -- n4 ) \ core star-slash
                   1133:     */mod nip ;
                   1134: 
                   1135: \ EVALUATE                                              17may93jaw
                   1136: 
1.14    ! pazsan   1137: has-files 0= [IF]
        !          1138: : push-file  ( -- )  r>
        !          1139:   sourceline# >r  tibstack @ >r  >tib @ >r  #tib @ >r
        !          1140:   >tib @ tibstack @ = IF  r@ tibstack +!  THEN
        !          1141:   tibstack @ >tib ! >in @ >r  >r ;
        !          1142: 
        !          1143: : pop-file   ( throw-code -- throw-code )
        !          1144:   r>
        !          1145:   r> >in !  r> #tib !  r> >tib !  r> tibstack !  r> loadline !  >r ;
        !          1146: [THEN]
        !          1147: 
1.1       pazsan   1148: : evaluate ( c-addr len -- ) \ core,block
                   1149:   push-file  #tib ! >tib !
                   1150:   >in off blk off loadfile off -1 loadline !
                   1151:   ['] interpret catch
                   1152:   pop-file throw ;
                   1153: 
                   1154: : abort ( ?? -- ?? ) \ core,exception-ext
                   1155:     -1 throw ;
                   1156: 
                   1157: \+ environment? true ENV" CORE"
                   1158: \ core wordset is now complete!
                   1159: 
                   1160: \ Quit                                                 13feb93py
                   1161: 
                   1162: Defer 'quit
                   1163: Defer .status
                   1164: : prompt        state @ IF ."  compiled" EXIT THEN ."  ok" ;
1.8       anton    1165: : (Query)  ( -- )
                   1166:     loadfile off  blk off  refill drop ;
1.14    ! pazsan   1167: : (quit)  BEGIN  .status cr (query) interpret prompt  AGAIN ;
1.1       pazsan   1168: ' (quit) IS 'quit
                   1169: 
                   1170: \ DOERROR (DOERROR)                                     13jun93jaw
                   1171: 
                   1172: 8 Constant max-errors
                   1173: Variable error-stack  0 error-stack !
                   1174: max-errors 6 * cells allot
                   1175: \ format of one cell:
                   1176: \ source ( addr u )
                   1177: \ >in
                   1178: \ line-number
                   1179: \ Loadfilename ( addr u )
                   1180: 
                   1181: : dec. ( n -- ) \ gforth
                   1182:     \ print value in decimal representation
                   1183:     base @ decimal swap . base ! ;
                   1184: 
                   1185: : hex. ( u -- ) \ gforth
                   1186:     \ print value as unsigned hex number
                   1187:     '$ emit base @ swap hex u. base ! ;
                   1188: 
                   1189: : typewhite ( addr u -- ) \ gforth
                   1190:     \ like type, but white space is printed instead of the characters
                   1191:     bounds ?do
1.10      anton    1192:        i c@ #tab = if \ check for tab
                   1193:            #tab
1.1       pazsan   1194:        else
                   1195:            bl
                   1196:        then
                   1197:        emit
                   1198:     loop ;
                   1199: 
                   1200: DEFER DOERROR
                   1201: 
                   1202: : .error-frame ( addr1 u1 n1 n2 addr2 u2 -- )
                   1203:   cr error-stack @
                   1204:   IF
                   1205:      ." in file included from "
                   1206:      type ." :" dec.  drop 2drop
                   1207:   ELSE
                   1208:      type ." :" dec.
                   1209:      cr dup 2over type cr drop
                   1210:      nip -trailing 1- ( line-start index2 )
                   1211:      0 >r  BEGIN
                   1212:                   2dup + c@ bl >  WHILE
                   1213:                  r> 1+ >r  1- dup 0<  UNTIL  THEN  1+
                   1214:      ( line-start index1 )
                   1215:      typewhite
                   1216:      r> 1 max 0 ?do \ we want at least one "^", even if the length is 0
                   1217:                   [char] ^ emit
                   1218:      loop
                   1219:   THEN
                   1220: ;
                   1221: 
                   1222: : (DoError) ( throw-code -- )
                   1223:   sourceline# IF
                   1224:                source >in @ sourceline# 0 0 .error-frame
                   1225:   THEN
                   1226:   error-stack @ 0 ?DO
                   1227:     -1 error-stack +!
                   1228:     error-stack dup @ 6 * cells + cell+
                   1229:     6 cells bounds DO
                   1230:       I @
                   1231:     cell +LOOP
                   1232:     .error-frame
                   1233:   LOOP
                   1234:   dup -2 =
                   1235:   IF 
                   1236:      "error @ ?dup
                   1237:      IF
                   1238:         cr count type 
                   1239:      THEN
                   1240:      drop
                   1241:   ELSE
                   1242:      .error
                   1243:   THEN
                   1244:   normal-dp dpp ! ;
                   1245: 
                   1246: ' (DoError) IS DoError
                   1247: 
                   1248: : quit ( ?? -- ?? ) \ core
                   1249:     r0 @ rp! handler off >tib @ >r
                   1250:     BEGIN
                   1251:        postpone [
                   1252:        ['] 'quit CATCH dup
                   1253:     WHILE
                   1254:        DoError r@ >tib ! r@ tibstack !
                   1255:     REPEAT
                   1256:     drop r> >tib ! ;
                   1257: 
                   1258: \ Cold                                                 13feb93py
                   1259: 
                   1260: \ : .name ( name -- ) name>string type space ;
                   1261: \ : words  listwords @
                   1262: \          BEGIN  @ dup  WHILE  dup .name  REPEAT drop ;
                   1263: Defer 'cold ' noop IS 'cold
                   1264: 
                   1265: : cold ( -- ) \ gforth
1.14    ! pazsan   1266: [ has-os [IF] ]
1.1       pazsan   1267:     stdout TO outfile-id
1.14    ! pazsan   1268: [ [THEN] ]
        !          1269: [ has-files [IF] ]
1.1       pazsan   1270:     pathstring 2@ process-path pathdirs 2!
                   1271:     init-included-files
1.14    ! pazsan   1272: [ [THEN] ]
1.1       pazsan   1273:     'cold
1.14    ! pazsan   1274: [ has-files [IF] ]
1.1       pazsan   1275:     argc @ 1 >
                   1276:     IF
                   1277:        ['] process-args catch ?dup
                   1278:        IF
                   1279:            dup >r DoError cr r> negate (bye)
                   1280:        THEN
                   1281:        cr
                   1282:     THEN
1.14    ! pazsan   1283: [ [THEN] ]
1.1       pazsan   1284:     ." GForth " version-string type ." , Copyright (C) 1994-1996 Free Software Foundation, Inc." cr
1.14    ! pazsan   1285:     ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'"
        !          1286: [ has-os [IF] ]
        !          1287:      cr ." Type `bye' to exit"
        !          1288: [ [THEN] ]
1.1       pazsan   1289:     loadline off quit ;
                   1290: 
                   1291: : license ( -- ) \ gforth
                   1292:  cr
                   1293:  ." This program is free software; you can redistribute it and/or modify" cr
                   1294:  ." it under the terms of the GNU General Public License as published by" cr
                   1295:  ." the Free Software Foundation; either version 2 of the License, or" cr
                   1296:  ." (at your option) any later version." cr cr
                   1297: 
                   1298:  ." This program is distributed in the hope that it will be useful," cr
                   1299:  ." but WITHOUT ANY WARRANTY; without even the implied warranty of" cr
                   1300:  ." MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the" cr
                   1301:  ." GNU General Public License for more details." cr cr
                   1302: 
                   1303:  ." You should have received a copy of the GNU General Public License" cr
                   1304:  ." along with this program; if not, write to the Free Software" cr
                   1305:  ." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ;
                   1306: 
                   1307: : boot ( path **argv argc -- )
1.14    ! pazsan   1308: [ has-files [IF] ]
        !          1309:     argc ! argv ! pathstring 2!
        !          1310: [ [THEN] ]
        !          1311:     main-task up!
        !          1312:     sp@ s0 !
        !          1313: [ has-locals [IF] ]
        !          1314:     lp@ forthstart 7 cells + @ - 
        !          1315: [ [ELSE] ]
        !          1316:     [ has-os [IF] ]
        !          1317:     sp@ $1040 +
        !          1318:     [ [ELSE] ]
        !          1319:     sp@ $40 +
        !          1320:     [ [THEN] ]
        !          1321: [ [THEN] ]
        !          1322:     dup >tib ! tibstack ! #tib off >in off
        !          1323:     rp@ r0 !
        !          1324: [ has-floats [IF] ]
        !          1325:     fp@ f0 !
        !          1326: [ [THEN] ]
        !          1327:     ['] cold catch DoError
        !          1328: [ has-os [IF] ]
        !          1329:     bye
        !          1330: [ [THEN] ]
        !          1331: ;
1.1       pazsan   1332: 
1.14    ! pazsan   1333: has-os [IF]
1.1       pazsan   1334: : bye ( -- ) \ tools-ext
1.14    ! pazsan   1335: [ has-files [IF] ]
        !          1336:     script? 0= IF  cr  THEN
        !          1337: [ [ELSE] ]
        !          1338:     cr
        !          1339: [ [THEN] ]
        !          1340:     0 (bye) ;
        !          1341: [THEN]
1.1       pazsan   1342: 
                   1343: \ **argv may be scanned by the C starter to get some important
                   1344: \ information, as -display and -geometry for an X client FORTH
                   1345: \ or space and stackspace overrides
                   1346: 
                   1347: \ 0 arg contains, however, the name of the program.
                   1348: 
                   1349: 

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