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

1.1       anton       1: \ kernel.fs    GForth kernel                        17dec92py
                      2: 
1.7       anton       3: \ Copyright (C) 1995,1998 Free Software Foundation, Inc.
1.1       anton       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: \- NIL NIL AConstant NIL \ gforth
                     28: 
                     29: \ Aliases
                     30: 
1.4       jwilke     31: [IFUNDEF] r@
1.1       anton      32: ' i Alias r@ ( -- w ; R: w -- w ) \ core r-fetch
1.12      crook      33: \G Copy @var{w} from the return stack to the data stack.
1.4       jwilke     34: [THEN]
1.1       anton      35: 
                     36: \ !! this is machine-dependent, but works on all but the strangest machines
                     37: 
1.10      anton      38: : maxaligned ( addr -- f-addr ) \ gforth
1.1       anton      39:     [ /maxalign 1 - ] Literal + [ 0 /maxalign - ] Literal and ;
                     40: \ !! machine-dependent and won't work if "0 >body" <> "0 >body maxaligned"
                     41: ' maxaligned Alias cfaligned ( addr1 -- addr2 ) \ gforth
                     42: 
                     43: : chars ( n1 -- n2 ) \ core
                     44: ; immediate
                     45: 
                     46: 
                     47: \ : A!    ( addr1 addr2 -- ) \ gforth
                     48: \    dup relon ! ;
                     49: \ : A,    ( addr -- ) \ gforth
                     50: \    here cell allot A! ;
                     51: ' ! alias A! ( addr1 addr2 -- ) \ gforth
                     52: 
1.2       anton      53: \ UNUSED                                                17may93jaw
                     54: 
1.4       jwilke     55: has? ec 
                     56: [IF]
                     57: unlock ram-dictionary area nip lock
                     58: Constant dictionary-end
                     59: [ELSE]
1.2       anton      60: : dictionary-end ( -- addr )
                     61:     forthstart [ 3 cells ] Aliteral @ + ;
1.4       jwilke     62: [THEN]
1.2       anton      63: 
                     64: : unused ( -- u ) \ core-ext
1.13    ! crook      65:     \G Return the amount of free space remaining (in address units) in
        !            66:     \G the region addressed by @code{here}.
1.2       anton      67:     dictionary-end here - [ word-pno-size pad-minsize + ] Literal - ;
                     68: 
1.1       anton      69: \ here is used for pad calculation!
                     70: 
                     71: : dp    ( -- addr ) \ gforth
                     72:     dpp @ ;
1.13    ! crook      73: : here  ( -- addr ) \ core
        !            74:     \G Return the address of the next free location in data space.
1.1       anton      75:     dp @ ;
                     76: 
                     77: \ on off                                               23feb93py
                     78: 
1.4       jwilke     79: \ on is used by docol:
1.1       anton      80: : on  ( addr -- ) \ gforth
                     81:     true  swap ! ;
                     82: : off ( addr -- ) \ gforth
                     83:     false swap ! ;
                     84: 
                     85: \ dabs roll                                           17may93jaw
                     86: 
                     87: : dabs ( d1 -- d2 ) \ double
                     88:     dup 0< IF dnegate THEN ;
                     89: 
                     90: : roll  ( x0 x1 .. xn n -- x1 .. xn x0 ) \ core-ext
                     91:   dup 1+ pick >r
                     92:   cells sp@ cell+ dup cell+ rot move drop r> ;
                     93: 
                     94: \ place bounds                                         13feb93py
                     95: 
                     96: : place  ( addr len to -- ) \ gforth
                     97:     over >r  rot over 1+  r> move c! ;
                     98: : bounds ( beg count -- end beg ) \ gforth
                     99:     over + swap ;
                    100: 
                    101: \ (word)                                               22feb93py
                    102: 
                    103: : scan   ( addr1 n1 char -- addr2 n2 ) \ gforth
                    104:     \ skip all characters not equal to char
                    105:     >r
                    106:     BEGIN
                    107:        dup
                    108:     WHILE
                    109:        over c@ r@ <>
                    110:     WHILE
                    111:        1 /string
                    112:     REPEAT  THEN
                    113:     rdrop ;
                    114: : skip   ( addr1 n1 char -- addr2 n2 ) \ gforth
                    115:     \ skip all characters equal to char
                    116:     >r
                    117:     BEGIN
                    118:        dup
                    119:     WHILE
                    120:        over c@ r@  =
                    121:     WHILE
                    122:        1 /string
                    123:     REPEAT  THEN
                    124:     rdrop ;
                    125: 
                    126: \ digit?                                               17dec92py
                    127: 
                    128: : digit?   ( char -- digit true/ false ) \ gforth
                    129:   base @ $100 =
                    130:   IF
                    131:     true EXIT
                    132:   THEN
                    133:   toupper [char] 0 - dup 9 u> IF
                    134:     [ 'A '9 1 + -  ] literal -
                    135:     dup 9 u<= IF
                    136:       drop false EXIT
                    137:     THEN
                    138:   THEN
                    139:   dup base @ u>= IF
                    140:     drop false EXIT
                    141:   THEN
                    142:   true ;
                    143: 
                    144: : accumulate ( +d0 addr digit - +d1 addr )
                    145:   swap >r swap  base @  um* drop rot  base @  um* d+ r> ;
                    146: 
1.13    ! crook     147: : >number ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) \ core
        !           148:     \G Attempt to convert the character string @var{c-addr1, u1} to an
        !           149:     \G unsigned number in the current number base. The double
        !           150:     \G @var{ud1} accumulates the result of the conversion to form
        !           151:     \G @var{ud2}. Conversion continues, left-to-right, until the whole
        !           152:     \G string is converted or a character that is not convertable in
        !           153:     \G the current number base is encountered (including + or -). For
        !           154:     \G each convertable character, @var{ud1} is first multiplied by
        !           155:     \G the value in @code{BASE} and then incremented by the value
        !           156:     \G represented by the character. @var{c-addr2} is the location of
        !           157:     \G the first unconverted character (past the end of the string if
        !           158:     \G the whole string was converted). @var{u2} is the number of
        !           159:     \G unconverted characters in the string. Overflow is not detected.
1.1       anton     160:     0
                    161:     ?DO
                    162:        count digit?
                    163:     WHILE
                    164:        accumulate
                    165:     LOOP
                    166:         0
                    167:     ELSE
                    168:        1- I' I -
                    169:        UNLOOP
                    170:     THEN ;
                    171: 
                    172: \ s>d um/mod                                           21mar93py
                    173: 
                    174: : s>d ( n -- d ) \ core                s-to-d
                    175:     dup 0< ;
                    176: 
                    177: : ud/mod ( ud1 u2 -- urem udquot ) \ gforth
                    178:     >r 0 r@ um/mod r> swap >r
                    179:     um/mod r> ;
                    180: 
                    181: \ catch throw                                          23feb93py
                    182: \ bounce                                                08jun93jaw
                    183: 
                    184: \ !! allow the user to add rollback actions    anton
                    185: \ !! use a separate exception stack?           anton
                    186: 
1.5       jwilke    187: has? glocals [IF]
1.12      crook     188: : lp@ ( -- addr ) \ gforth     lp-fetch
1.1       anton     189:  laddr# [ 0 , ] ;
                    190: [THEN]
                    191: 
                    192: \- 'catch Defer 'catch
                    193: \- 'throw Defer 'throw
                    194: 
                    195: ' noop IS 'catch
                    196: ' noop IS 'throw
                    197: 
1.8       anton     198: Defer store-backtrace
                    199: ' noop IS store-backtrace
                    200: 
1.1       anton     201: : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
                    202:     'catch
                    203:     sp@ >r
1.5       jwilke    204: [ has? floating [IF] ]
1.1       anton     205:     fp@ >r
                    206: [ [THEN] ]
1.5       jwilke    207: [ has? glocals [IF] ]
1.1       anton     208:     lp@ >r
                    209: [ [THEN] ]
                    210:     handler @ >r
                    211:     rp@ handler !
1.8       anton     212:     backtrace-empty on
1.1       anton     213:     execute
1.3       jwilke    214:     r> handler ! rdrop 
1.5       jwilke    215: [ has? floating [IF] ]
1.3       jwilke    216:     rdrop
                    217: [ [THEN] ]
1.5       jwilke    218: [ has? glocals [IF] ]
1.3       jwilke    219:     rdrop
                    220: [ [THEN] ]
                    221:     0 ;
1.1       anton     222: 
                    223: : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) \ exception
                    224:     ?DUP IF
1.6       pazsan    225:        [ has? header [IF] here 9 cells ! [THEN] ] \ entry point for signal handler
1.8       anton     226:        store-backtrace
1.5       jwilke    227: [ has? interpreter [IF] ]
1.1       anton     228:        handler @ dup 0= IF
1.5       jwilke    229: [ has? os [IF] ]
1.1       anton     230:            2 (bye)
                    231: [ [ELSE] ]
                    232:            quit
                    233: [ [THEN] ]
                    234:        THEN
                    235: [ [THEN] ]
                    236:        rp!
                    237:        r> handler !
1.5       jwilke    238: [ has? glocals [IF] ]
1.1       anton     239:         r> lp!
                    240: [ [THEN] ]
1.5       jwilke    241: [ has? floating [IF] ]
1.1       anton     242:        r> fp!
                    243: [ [THEN] ]
                    244:        r> swap >r sp! drop r>
                    245:        'throw
                    246:     THEN ;
                    247: 
                    248: \ Bouncing is very fine,
                    249: \ programming without wasting time...   jaw
                    250: : bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym ) \ gforth
                    251: \ a throw without data or fp stack restauration
                    252:   ?DUP IF
1.8       anton     253:       store-backtrace
1.1       anton     254:       handler @ rp!
                    255:       r> handler !
1.5       jwilke    256: [ has? glocals [IF] ]
1.1       anton     257:       r> lp!
                    258: [ [THEN] ]
1.5       jwilke    259: [ has? floating [IF] ]
1.1       anton     260:       rdrop
                    261: [ [THEN] ]
                    262:       rdrop
                    263:       'throw
                    264:   THEN ;
                    265: 
                    266: \ (abort")
                    267: 
                    268: : (abort")
                    269:     "lit >r
                    270:     IF
                    271:        r> "error ! -2 throw
                    272:     THEN
                    273:     rdrop ;
1.6       pazsan    274: 
                    275: : abort ( ?? -- ?? ) \ core,exception-ext
1.12      crook     276:     \G Empty the data stack and perform the functions of @code{quit}.
                    277:     \G Since the exception word set is present, this is performed by
                    278:     \G @code{-1 throw}.
1.6       pazsan    279:     -1 throw ;
1.1       anton     280: 
                    281: \ ?stack                                               23feb93py
                    282: 
                    283: : ?stack ( ?? -- ?? ) \ gforth
1.3       jwilke    284:     sp@ sp0 @ u> IF    -4 throw  THEN
1.5       jwilke    285: [ has? floating [IF] ]
1.3       jwilke    286:     fp@ fp0 @ u> IF  -&45 throw  THEN
1.1       anton     287: [ [THEN] ]
                    288: ;
                    289: \ ?stack should be code -- it touches an empty stack!
                    290: 
                    291: \ DEPTH                                                 9may93jaw
                    292: 
1.9       crook     293: : depth ( -- +n ) \ core depth
1.12      crook     294:     \G @var{+n} is the number of values that were on the data stack before
                    295:     \G @var{+n} itself was placed on the stack.
1.3       jwilke    296:     sp@ sp0 @ swap - cell / ;
1.9       crook     297: 
                    298: : clearstack ( ... -- ) \ gforth clear-stack
                    299:     \G remove and discard all/any items from the data stack.
1.3       jwilke    300:     sp0 @ sp! ;
1.1       anton     301: 
                    302: \ Strings                                               22feb93py
                    303: 
                    304: : "lit ( -- addr )
                    305:   r> r> dup count + aligned >r swap >r ;
                    306: 
                    307: \ */MOD */                                              17may93jaw
                    308: 
                    309: \ !! I think */mod should have the same rounding behaviour as / - anton
                    310: : */mod ( n1 n2 n3 -- n4 n5 ) \ core   star-slash-mod
                    311:     >r m* r> sm/rem ;
                    312: 
                    313: : */ ( n1 n2 n3 -- n4 ) \ core star-slash
                    314:     */mod nip ;
                    315: 
                    316: \ HEX DECIMAL                                           2may93jaw
                    317: 
                    318: : decimal ( -- ) \ core
1.9       crook     319:     \G Set the numeric conversion radix (the value of @code{BASE}) to 10
                    320:     \G (decimal).
1.1       anton     321:     a base ! ;
                    322: : hex ( -- ) \ core-ext
1.9       crook     323:     \G Set the numeric conversion radix (the value of @code{BASE}) to 16
                    324:     \G (hexadecimal).
1.1       anton     325:     10 base ! ;
                    326: 

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