Return to extend.fs CVS log

Up to [gforth] / gforth

Major change!
hash and search does not rely on each other.
context and voclink are now present in kernel.
words and marker can now defined without loading hash or search
marker went to extend.fs
word went to kernel/tools.fs
table goes to seperate file (at the moment)
glocals.fs and kernel/toolsext.fs are changed because of the change in the
wordlist-map-struct...
Attention: You can't recompile the code without new kernel-files!!!
jens

    1: \ EXTEND.FS    CORE-EXT Word not fully tested!         12may93jaw
    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: 
   22: \ May be cross-compiled
   23: 
   24: decimal
   25: 
   26: \ .(                                                    12may93jaw
   27: 
   28: : .(   ( compilation "...<paren>" -- ) \ core-ext dot-paren
   29:     [char] ) parse type ; immediate
   30: 
   31: \ VALUE 2>R 2R> 2R@                                     17may93jaw
   32: 
   33: \ !! 2value
   34: 
   35: : 2Literal ( compilation w1 w2 -- ; run-time  -- w1 w2 ) \ double two-literal
   36:     swap postpone Literal  postpone Literal ; immediate restrict
   37: 
   38: ' drop alias d>s ( d -- n ) \ double		d_to_s
   39: 
   40: : m*/ ( d1 n2 u3 -- dqout ) \ double m-star-slash
   41:     >r s>d >r abs -rot
   42:     s>d r> xor r> swap >r >r dabs rot tuck um* 2swap um*
   43:     swap >r 0 d+ r> -rot r@ um/mod -rot r> um/mod nip swap
   44:     r> IF dnegate THEN ;
   45: 
   46: \ CASE OF ENDOF ENDCASE                                 17may93jaw
   47: 
   48: \ just as described in dpANS5
   49: 
   50: 0 CONSTANT case ( compilation  -- case-sys ; run-time  -- ) \ core-ext
   51:     immediate
   52: 
   53: : of ( compilation  -- of-sys ; run-time x1 x2 -- |x1 ) \ core-ext
   54:     \ !! the implementation does not match the stack effect
   55:     1+ >r
   56:     postpone over postpone = postpone if postpone drop
   57:     r> ; immediate
   58: 
   59: : endof ( compilation case-sys1 of-sys -- case-sys2 ; run-time  -- ) \ core-ext end-of
   60:     >r postpone else r> ; immediate
   61: 
   62: : endcase ( compilation case-sys -- ; run-time x -- ) \ core-ext end-case
   63:     postpone drop
   64:     0 ?do postpone then loop ; immediate
   65: 
   66: \ C"                                                    17may93jaw
   67: 
   68: : (c")     "lit ;
   69: 
   70: : CLiteral
   71:     postpone (c") here over char+ allot  place align ; immediate restrict
   72: 
   73: : C" ( compilation "...<quote>" -- ; run-time  -- c-addr ) \ core-ext c-quote
   74:     [char] " parse postpone CLiteral ; immediate restrict
   75: 
   76: \ [COMPILE]                                             17may93jaw
   77: 
   78: : [compile] ( compilation "name" -- ; run-time ? -- ? ) \ core-ext bracket-compile
   79:     comp' drop compile, ; immediate
   80: 
   81: \ CONVERT                                               17may93jaw
   82: 
   83: : convert ( ud1 c-addr1 -- ud2 c-addr2 ) \ core-ext
   84:     \G obsolescent; superseded by @code{>number}.
   85:     char+ true >number drop ;
   86: 
   87: \ ERASE                                                 17may93jaw
   88: 
   89: : erase ( addr len -- ) \ core-ext
   90:     \ !! dependence on "1 chars 1 ="
   91:     ( 0 1 chars um/mod nip )  0 fill ;
   92: : blank ( addr len -- ) \ string
   93:     bl fill ;
   94: 
   95: \ SEARCH                                                02sep94py
   96: 
   97: : search   ( buf buflen text textlen -- restbuf restlen flag ) \ string
   98:     2over  2 pick - 1+ 3 pick c@ >r
   99:     BEGIN
  100: 	r@ scan dup
  101:     WHILE
  102: 	>r >r  2dup r@ -text
  103: 	0=
  104: 	IF
  105: 	    >r drop 2drop r> r> r> rot + 1- rdrop true
  106: 	    EXIT
  107: 	THEN
  108: 	r> r>  1 /string
  109:     REPEAT
  110:     2drop 2drop  rdrop false ;
  111: 
  112: \ SOURCE-ID SAVE-INPUT RESTORE-INPUT                    11jun93jaw
  113: 
  114: : source-id ( -- 0 | -1 | fileid ) \ core-ext,file source-i-d
  115:   loadfile @ dup 0= IF  drop sourceline# 0 min  THEN ;
  116: 
  117: : save-input ( -- x1 .. xn n ) \ core-ext
  118:     >in @
  119:     loadfile @
  120:     if
  121: 	loadfile @ file-position throw
  122:     else
  123: 	blk @
  124: 	linestart @
  125:     then
  126:     sourceline#
  127:     >tib @
  128:     source-id
  129:     6 ;
  130: 
  131: : restore-input ( x1 .. xn n -- flag ) \ core-ext
  132:     6 <> -12 and throw
  133:     source-id <> -12 and throw
  134:     >tib !
  135:     >r ( line# )
  136:     loadfile @ 0<>
  137:     if
  138: 	loadfile @ reposition-file throw
  139:     else
  140: 	linestart !
  141: 	blk !
  142: 	sourceline# r@ <> blk @ 0= and loadfile @ 0= and
  143: 	if
  144: 	    drop rdrop true EXIT
  145: 	then
  146:     then
  147:     r> loadline !
  148:     >in !
  149:     false ;
  150: 
  151: \ This things we don't need, but for being complete... jaw
  152: 
  153: \ EXPECT SPAN                                           17may93jaw
  154: 
  155: variable span ( -- a-addr ) \ core-ext
  156: \ obsolescent
  157: 
  158: : expect ( c-addr +len -- ) \ core-ext
  159:     \ obsolescent; use accept
  160:     0 rot over
  161:     BEGIN ( maxlen span c-addr pos1 )
  162: 	key decode ( maxlen span c-addr pos2 flag )
  163: 	>r 2over = r> or
  164:     UNTIL
  165:     2 pick swap /string type
  166:     nip span ! ;
  167: 
  168: \ marker                                               18dec94py
  169: 
  170: \ Marker creates a mark that is removed (including everything 
  171: \ defined afterwards) when executing the mark.
  172: 
  173: : marker, ( -- mark )  here dup A,
  174:   voclink @ A, voclink
  175:   BEGIN  @ dup WHILE  dup 0 wordlist-link - @ A,  REPEAT  drop
  176:   udp @ , ;
  177: 
  178: : marker! ( mark -- )
  179:     dup @ swap cell+
  180:     dup @ voclink ! cell+
  181:     voclink
  182:     BEGIN
  183: 	@ dup 
  184:     WHILE
  185: 	over @ over 0 wordlist-link - !
  186: 	swap cell+ swap
  187:     REPEAT
  188:     drop  voclink
  189:     BEGIN
  190: 	@ dup
  191:     WHILE
  192: 	dup 0 wordlist-link - rehash
  193:     REPEAT
  194:     drop
  195:     @ udp !  dp ! ;
  196: 
  197: : marker ( "mark" -- )
  198:     marker, Create A,
  199: DOES> ( -- )
  200:     @ marker! ;
  201: