Annotation of gforth/kernel-ec/basics.fs, revision 1.1

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

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