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

1.1       anton       1: \ kernel.fs    GForth kernel                        17dec92py
                      2: 
1.61    ! anton       3: \ Copyright (C) 1995,1998,2000,2003,2004,2005,2006,2007 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
1.29      anton      19: \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
1.1       anton      20: 
                     21: \ Idea and implementation: Bernd Paysan (py)
                     22: 
1.16      jwilke     23: \ Needs:
                     24: 
                     25: require ./vars.fs
1.32      anton      26: require ../compat/strcomp.fs
1.16      jwilke     27: 
                     28: hex
1.1       anton      29: 
                     30: \ labels for some code addresses
                     31: 
                     32: \- NIL NIL AConstant NIL \ gforth
                     33: 
                     34: \ Aliases
                     35: 
1.4       jwilke     36: [IFUNDEF] r@
1.1       anton      37: ' i Alias r@ ( -- w ; R: w -- w ) \ core r-fetch
1.4       jwilke     38: [THEN]
1.1       anton      39: 
                     40: \ !! this is machine-dependent, but works on all but the strangest machines
                     41: 
1.23      anton      42: : maxaligned ( addr1 -- addr2 ) \ gforth
                     43:     \G @i{addr2} is the first address after @i{addr1} that satisfies
                     44:     \G all alignment restrictions.
1.1       anton      45:     [ /maxalign 1 - ] Literal + [ 0 /maxalign - ] Literal and ;
1.23      anton      46: \ !! machine-dependent and won't work if "0 >body" <> "0 >body
                     47:     \G maxaligned"
1.1       anton      48: ' maxaligned Alias cfaligned ( addr1 -- addr2 ) \ gforth
1.23      anton      49: \G @i{addr2} is the first address after @i{addr1} that is aligned for
                     50: \G a code field (i.e., such that the corresponding body is maxaligned).
1.1       anton      51: 
                     52: : chars ( n1 -- n2 ) \ core
1.23      anton      53: \G @i{n2} is the number of address units of @i{n1} chars.""
1.1       anton      54: ; immediate
                     55: 
                     56: 
                     57: \ : A!    ( addr1 addr2 -- ) \ gforth
                     58: \    dup relon ! ;
                     59: \ : A,    ( addr -- ) \ gforth
                     60: \    here cell allot A! ;
                     61: ' ! alias A! ( addr1 addr2 -- ) \ gforth
                     62: 
1.2       anton      63: \ UNUSED                                                17may93jaw
                     64: 
1.41      pazsan     65: has? ec [IF]
1.30      jwilke     66: unlock ram-dictionary borders nip lock
                     67: AConstant dictionary-end
1.4       jwilke     68: [ELSE]
1.35      pazsan     69:     has? header [IF]
                     70:        : dictionary-end ( -- addr )
                     71:            forthstart [ 3 cells image-header + ] Aliteral @ + ;
                     72:     [ELSE]
                     73:        : forthstart 0 ;
                     74:        : dictionary-end ( -- addr )
                     75:            forthstart [ has? kernel-size ] Literal + ;
                     76:     [THEN]
1.4       jwilke     77: [THEN]
1.2       anton      78: 
1.14      anton      79: : usable-dictionary-end ( -- addr )
                     80:     dictionary-end [ word-pno-size pad-minsize + ] Literal - ;
                     81: 
1.2       anton      82: : unused ( -- u ) \ core-ext
1.13      crook      83:     \G Return the amount of free space remaining (in address units) in
                     84:     \G the region addressed by @code{here}.
1.14      anton      85:     usable-dictionary-end here - ;
1.2       anton      86: 
1.40      pazsan     87: has? ec [IF]
                     88: : in-dictionary? ( x -- f )
1.41      pazsan     89:     dictionary-end u< ;
1.40      pazsan     90: [ELSE]    
1.34      anton      91: : in-dictionary? ( x -- f )
                     92:     forthstart dictionary-end within ;
1.40      pazsan     93: [THEN]
1.34      anton      94: 
1.1       anton      95: \ here is used for pad calculation!
                     96: 
                     97: : dp    ( -- addr ) \ gforth
                     98:     dpp @ ;
1.13      crook      99: : here  ( -- addr ) \ core
                    100:     \G Return the address of the next free location in data space.
1.1       anton     101:     dp @ ;
                    102: 
                    103: \ on off                                               23feb93py
                    104: 
1.4       jwilke    105: \ on is used by docol:
1.15      crook     106: : on  ( a-addr -- ) \ gforth
                    107:     \G Set the (value of the) variable  at @i{a-addr} to @code{true}.
1.1       anton     108:     true  swap ! ;
1.15      crook     109: : off ( a-addr -- ) \ gforth
                    110:     \G Set the (value of the) variable at @i{a-addr} to @code{false}.
1.1       anton     111:     false swap ! ;
                    112: 
                    113: \ dabs roll                                           17may93jaw
                    114: 
1.24      anton     115: : dabs ( d -- ud ) \ double d-abs
1.1       anton     116:     dup 0< IF dnegate THEN ;
                    117: 
                    118: : roll  ( x0 x1 .. xn n -- x1 .. xn x0 ) \ core-ext
1.47      anton     119:     \  dup 1+ pick >r
                    120:     \  cells sp@ cell+ dup cell+ rot move drop r> ;
                    121:     dup 0<= if
                    122:        drop
                    123:     else
1.54      pazsan    124:        swap >r 1- recurse r> swap 
1.47      anton     125:     then ;
1.1       anton     126: 
                    127: \ place bounds                                         13feb93py
                    128: 
                    129: : place  ( addr len to -- ) \ gforth
                    130:     over >r  rot over 1+  r> move c! ;
1.27      anton     131: : bounds ( addr u -- addr+u addr ) \ gforth
                    132:     \G Given a memory block represented by starting address @i{addr}
                    133:     \G and length @i{u} in aus, produce the end address @i{addr+u} and
                    134:     \G the start address in the right order for @code{u+do} or
                    135:     \G @code{?do}.
1.1       anton     136:     over + swap ;
                    137: 
                    138: \ (word)                                               22feb93py
                    139: 
                    140: : scan   ( addr1 n1 char -- addr2 n2 ) \ gforth
1.43      anton     141:     \G skip all characters not equal to char
1.1       anton     142:     >r
                    143:     BEGIN
                    144:        dup
                    145:     WHILE
                    146:        over c@ r@ <>
                    147:     WHILE
                    148:        1 /string
                    149:     REPEAT  THEN
                    150:     rdrop ;
                    151: : skip   ( addr1 n1 char -- addr2 n2 ) \ gforth
1.43      anton     152:     \G skip all characters equal to char
1.1       anton     153:     >r
                    154:     BEGIN
                    155:        dup
                    156:     WHILE
                    157:        over c@ r@  =
                    158:     WHILE
                    159:        1 /string
                    160:     REPEAT  THEN
                    161:     rdrop ;
                    162: 
                    163: \ digit?                                               17dec92py
                    164: 
                    165: : digit?   ( char -- digit true/ false ) \ gforth
                    166:   toupper [char] 0 - dup 9 u> IF
1.16      jwilke    167:     [ char A char 9 1 + -  ] literal -
1.1       anton     168:     dup 9 u<= IF
                    169:       drop false EXIT
                    170:     THEN
                    171:   THEN
                    172:   dup base @ u>= IF
                    173:     drop false EXIT
                    174:   THEN
                    175:   true ;
                    176: 
                    177: : accumulate ( +d0 addr digit - +d1 addr )
1.40      pazsan    178:   swap >r swap  base @  um* drop rot  base @  um* d+ r> ;
1.1       anton     179: 
1.18      crook     180: : >number ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) \ core to-number
1.22      anton     181:     \G Attempt to convert the character string @var{c-addr1 u1} to an
1.13      crook     182:     \G unsigned number in the current number base. The double
                    183:     \G @var{ud1} accumulates the result of the conversion to form
                    184:     \G @var{ud2}. Conversion continues, left-to-right, until the whole
                    185:     \G string is converted or a character that is not convertable in
                    186:     \G the current number base is encountered (including + or -). For
                    187:     \G each convertable character, @var{ud1} is first multiplied by
                    188:     \G the value in @code{BASE} and then incremented by the value
                    189:     \G represented by the character. @var{c-addr2} is the location of
                    190:     \G the first unconverted character (past the end of the string if
                    191:     \G the whole string was converted). @var{u2} is the number of
                    192:     \G unconverted characters in the string. Overflow is not detected.
1.1       anton     193:     0
                    194:     ?DO
                    195:        count digit?
                    196:     WHILE
                    197:        accumulate
                    198:     LOOP
                    199:         0
                    200:     ELSE
                    201:        1- I' I -
                    202:        UNLOOP
                    203:     THEN ;
                    204: 
                    205: \ s>d um/mod                                           21mar93py
                    206: 
                    207: : s>d ( n -- d ) \ core                s-to-d
                    208:     dup 0< ;
                    209: 
                    210: : ud/mod ( ud1 u2 -- urem udquot ) \ gforth
                    211:     >r 0 r@ um/mod r> swap >r
                    212:     um/mod r> ;
                    213: 
                    214: \ catch throw                                          23feb93py
                    215: 
1.5       jwilke    216: has? glocals [IF]
1.12      crook     217: : lp@ ( -- addr ) \ gforth     lp-fetch
1.1       anton     218:  laddr# [ 0 , ] ;
                    219: [THEN]
                    220: 
1.59      pazsan    221: has? os 0= [IF]
1.52      pazsan    222:     : catch  ( ... xt -- ... 0 )
                    223:        handler @ >r sp@ >r
                    224:        rp@ handler ! execute 0 r> drop r> handler ! ;
                    225:     : throw  ( error -- error )  dup 0= IF  drop EXIT  THEN
                    226:        handler @ rp! r> swap >r sp! r> r> handler ! ;
                    227: [ELSE]
1.17      anton     228: defer catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) \ exception
1.24      anton     229: \G @code{Executes} @i{xt}.  If execution returns normally,
                    230: \G @code{catch} pushes 0 on the stack.  If execution returns through
                    231: \G @code{throw}, all the stacks are reset to the depth on entry to
                    232: \G @code{catch}, and the TOS (the @i{xt} position) is replaced with
                    233: \G the throw code.
                    234: 
1.17      anton     235: :noname ( ... xt -- ... 0 )
                    236:     execute 0 ;
                    237: is catch
1.1       anton     238: 
1.24      anton     239: defer throw ( y1 .. ym nerror -- y1 .. ym / z1 .. zn error ) \ exception
                    240: \G If @i{nerror} is 0, drop it and continue.  Otherwise, transfer
                    241: \G control to the next dynamically enclosing exception handler, reset
                    242: \G the stacks accordingly, and push @i{nerror}.
                    243: 
                    244: :noname ( y1 .. ym error -- y1 .. ym / z1 .. zn error )
1.19      anton     245:     ?dup if
1.35      pazsan    246:        [ has? header [IF] here image-header 9 cells + ! [THEN] ]
1.60      pazsan    247:        cr DoError cr
1.21      pazsan    248:        [ has? file [IF] ] script? IF  1 (bye)  ELSE  quit  THEN
                    249:        [ [ELSE] ] quit [ [THEN] ]
1.19      anton     250:     then ;
1.56      pazsan    251: is throw
1.52      pazsan    252: [THEN]
1.19      anton     253: 
1.1       anton     254: \ (abort")
                    255: 
1.33      anton     256: : c(abort") ( c-addr -- )
                    257:     "error ! -2 throw ;
                    258: 
1.1       anton     259: : (abort")
                    260:     "lit >r
                    261:     IF
                    262:        r> "error ! -2 throw
                    263:     THEN
                    264:     rdrop ;
1.6       pazsan    265: 
                    266: : abort ( ?? -- ?? ) \ core,exception-ext
1.12      crook     267:     \G @code{-1 throw}.
1.6       pazsan    268:     -1 throw ;
1.1       anton     269: 
                    270: \ ?stack                                               23feb93py
                    271: 
                    272: : ?stack ( ?? -- ?? ) \ gforth
1.3       jwilke    273:     sp@ sp0 @ u> IF    -4 throw  THEN
1.5       jwilke    274: [ has? floating [IF] ]
1.3       jwilke    275:     fp@ fp0 @ u> IF  -&45 throw  THEN
1.1       anton     276: [ [THEN] ]
                    277: ;
                    278: \ ?stack should be code -- it touches an empty stack!
                    279: 
                    280: \ DEPTH                                                 9may93jaw
                    281: 
1.9       crook     282: : depth ( -- +n ) \ core depth
1.12      crook     283:     \G @var{+n} is the number of values that were on the data stack before
                    284:     \G @var{+n} itself was placed on the stack.
1.3       jwilke    285:     sp@ sp0 @ swap - cell / ;
1.9       crook     286: 
                    287: : clearstack ( ... -- ) \ gforth clear-stack
1.42      anton     288: \G remove and discard all/any items from the data stack.
1.3       jwilke    289:     sp0 @ sp! ;
1.42      anton     290: 
                    291: : clearstacks ( ... -- ) \ gforth clear-stacks
                    292: \G empty data and FP stack
1.49      pazsan    293:     clearstack
                    294: [ has? floating [IF] ]
                    295:     fp0 @ fp!
                    296: [ [THEN] ]
                    297: ;
1.1       anton     298: 
                    299: \ Strings                                               22feb93py
                    300: 
                    301: : "lit ( -- addr )
                    302:   r> r> dup count + aligned >r swap >r ;
                    303: 
                    304: \ HEX DECIMAL                                           2may93jaw
                    305: 
                    306: : decimal ( -- ) \ core
1.58      anton     307:     \G Set @code{base} to &10 (decimal).  Don't use @code{hex}, use
                    308:     \G @code{base-execute} instead.
1.1       anton     309:     a base ! ;
                    310: : hex ( -- ) \ core-ext
1.58      anton     311:     \G Set @code{base} to &16 (hexadecimal).  Don't use @code{hex},
                    312:     \G use @code{base-execute} instead.
1.1       anton     313:     10 base ! ;
                    314: 

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