Commit 659af320 authored by anton's avatar anton

long names in dictionary

parent 4558e411
......@@ -28,11 +28,14 @@ s" address-unit-bits" environment? drop constant bits/au
: th ( addr1 n -- addr2 )
cells + ;
: bset ( bmask c-addr -- )
tuck c@ or swap c! ;
: set-bit { u addr -- }
\ set bit u in bit-vector addr
u bits/au /mod
>r 1 bits/au 1- rot - lshift
r> addr + cset ;
r> addr + bset ;
: compare-images { image1 image2 reloc-bits size file-id -- }
\G compares image1 and image2 (of size cells) and sets reloc-bits.
......
......@@ -1516,16 +1516,21 @@ variable ResolveFlag
>CROSS
\ Header states 12dec92py
: flag! ( 8b -- ) tlast @ dup >r T c@ xor r> c! H ;
: flag! ( w -- ) tlast @ dup >r T @ xor r> ! H ;
VARIABLE ^imm
\ !! should be target wordsize specific
$80000000 constant alias-mask
$40000000 constant immediate-mask
$20000000 constant restrict-mask
>TARGET
: immediate 40 flag!
: immediate immediate-mask flag!
^imm @ @ dup <imm> = IF drop EXIT THEN
<res> <> ABORT" CROSS: Cannot immediate a unresolved word"
<imm> ^imm @ ! ;
: restrict 20 flag! ;
: restrict restrict-mask flag! ;
: isdoer
\G define a forth word as doer, this makes obviously only sence on
......@@ -1537,8 +1542,10 @@ VARIABLE ^imm
>TARGET
: string, ( addr count -- )
dup T c, H bounds ?DO I c@ T c, H LOOP ;
: name, ( "name" -- ) bl word count T string, cfalign H ;
dup T c, H bounds ?DO I c@ T c, H LOOP ;
: lstring, ( addr count -- )
dup T , H bounds ?DO I c@ T c, H LOOP ;
: name, ( "name" -- ) bl word count T lstring, cfalign H ;
: view, ( -- ) ( dummy ) ;
>CROSS
......@@ -1693,7 +1700,7 @@ NoHeaderFlag off
IF dup >end tdoes !
ELSE 0 tdoes !
THEN
80 flag!
alias-mask flag!
cross-doc-entry cross-tag-entry ;
VARIABLE ;Resolve 1 cells allot
......@@ -1710,7 +1717,7 @@ VARIABLE ;Resolve 1 cells allot
IF
.sourcepos ." needs prim: " >in @ bl word count type >in ! cr
THEN
(THeader over resolve T A, H 80 flag! ;
(THeader over resolve T A, H alias-mask flag! ;
: Alias: ( cfa -- ) \ name
>in @ skip? IF 2drop EXIT THEN >in !
dup 0< s" prims" T $has? H 0= and
......@@ -2034,7 +2041,7 @@ Cond: DOES> restrict?
create-forward-warn
IF ['] reswarn-forward IS resolve-warning THEN
\ make Alias
(THeader there 0 T a, H 80 flag! ( S executed-ghost new-ghost )
(THeader there 0 T a, H alias-mask flag! ( S executed-ghost new-ghost )
\ store poiter to code-field
switchram T cfalign H
there swap T ! H
......
......@@ -65,7 +65,7 @@ Defer hash-alloc ( addr -- addr )
cells HashTable + ;
: hash-find ( addr len wordlist -- nfa / false )
>r 2dup r> bucket @ (hashfind) ;
>r 2dup r> bucket @ (hashlfind) ;
\ hash vocabularies 16jul94py
......
......@@ -107,12 +107,16 @@ defer header ( -- ) \ gforth
\G puts down string as cstring
dup c, here swap chars dup allot move ;
: longstring, ( c-addr u -- ) \ gforth
\G puts down string as cstring
dup , here swap chars dup allot move ;
: header, ( c-addr u -- ) \ gforth
name-too-long?
align here last !
current @ 1 or A, \ link field; before revealing, it contains the
\ tagged reveal-into wordlist
string, cfalign
longstring, cfalign
alias-mask lastflags cset ;
: input-stream-header ( "name" -- )
......@@ -136,6 +140,7 @@ create nextname-buffer 32 chars allot
: nextname ( c-addr u -- ) \ gforth
\g The next defined word will have the name @var{c-addr u}; the
\g defining word will leave the input stream alone.
dup 31 u> -&19 and throw \ !! make buffer variable-sized
name-too-long?
nextname-buffer c! ( c-addr )
nextname-buffer count move
......@@ -319,13 +324,13 @@ create nextname-buffer 32 chars allot
\ \ Header states 23feb93py
: cset ( bmask c-addr -- )
tuck c@ or swap c! ;
tuck @ or swap ! ;
: creset ( bmask c-addr -- )
tuck c@ swap invert and swap c! ;
tuck @ swap invert and swap ! ;
: ctoggle ( bmask c-addr -- )
tuck c@ xor swap c! ;
tuck @ xor swap ! ;
: lastflags ( -- c-addr )
\ the address of the flags byte in the last header
......
......@@ -97,7 +97,7 @@ Defer source ( -- c-addr u ) \ core
dup 0= -&16 and throw ;
: name-too-long? ( c-addr u -- c-addr u )
dup $1F u> -&19 and throw ;
dup lcount-mask u> -&19 and throw ;
\ \ Number parsing 23feb93py
......@@ -230,7 +230,7 @@ struct
end-struct wordlist-struct
: f83find ( addr len wordlist -- nt / false )
wordlist-id @ (f83find) ;
wordlist-id @ (listlfind) ;
: initvoc ( wid -- )
dup wordlist-map @ hash-method perform ;
......@@ -257,10 +257,20 @@ forth-wordlist current !
\ \ header, finding, ticks 17dec92py
hex
80 constant alias-mask \ set when the word is not an alias!
40 constant immediate-mask
20 constant restrict-mask
\ !! these should be done using the target's operations and cell size
\ 0 invert 1 rshift invert ( u ) \ top bit set
\ constant alias-mask \ set when the word is not an alias!
\ alias-mask 1 rshift constant immediate-mask
\ alias-mask 2 rshift constant restrict-mask
\ 0 invert 3 rshift constant lcount-mask
\ as an intermediate step, I define them correctly for 32-bit machines:
$80000000 constant alias-mask
$40000000 constant immediate-mask
$20000000 constant restrict-mask
$1fffffff constant lcount-mask
\ higher level parts of find
......@@ -279,7 +289,7 @@ hex
then
[ [THEN] ] ;
: (x>int) ( cfa b -- xt )
: (x>int) ( cfa w -- xt )
\ get interpretation semantics of name
restrict-mask and
if
......@@ -290,15 +300,15 @@ hex
: name>string ( nt -- addr count ) \ gforth head-to-string
\g @i{addr count} is the name of the word represented by @i{nt}.
cell+ count $1F and ;
cell+ dup cell+ swap @ lcount-mask and ;
: ((name>)) ( nfa -- cfa )
name>string + cfaligned ;
: (name>x) ( nfa -- cfa b )
\ cfa is an intermediate cfa and b is the flags byte of nfa
: (name>x) ( nfa -- cfa w )
\ cfa is an intermediate cfa and w is the flags cell of nfa
dup ((name>))
swap cell+ c@ dup alias-mask and 0=
swap cell+ @ dup alias-mask and 0=
IF
swap @ swap
THEN ;
......@@ -332,7 +342,7 @@ hex
;
: (name>intn) ( nfa -- xt +-1 )
(name>x) tuck (x>int) ( b xt )
(name>x) tuck (x>int) ( w xt )
swap immediate-mask and flag-sign ;
const Create ??? 0 , 3 c, char ? c, char ? c, char ? c,
......@@ -367,8 +377,10 @@ const Create ??? 0 , 3 c, char ? c, char ? c, char ? c,
drop true ;
: >head-noprim ( cfa -- nt ) \ gforth to-head-noprim
\ also heuristic; finds only names with up to 32 chars
$25 cell do ( cfa )
dup i - count $9F and + cfaligned over alias-mask + =
dup i - dup @ [ alias-mask lcount-mask or ] literal and ( cfa len|alias )
swap + cell + cfaligned over alias-mask + =
if ( cfa )
dup i - cell - dup head?
if
......@@ -383,7 +395,8 @@ const Create ??? 0 , 3 c, char ? c, char ? c, char ? c,
: >head-noprim ( cfa -- nt ) \ gforth to-head-noprim
$25 cell do ( cfa )
dup i - count $9F and + cfaligned over alias-mask + =
dup i - dup @ [ alias-mask lcount-mask or ] literal and ( cfa len|alias )
swap + cell + cfaligned over alias-mask + =
if ( cfa ) i - cell - unloop exit
then
cell +loop
......
......@@ -23,7 +23,7 @@ require hash.fs
\ table (case-sensitive wordlist)
: table-find ( addr len wordlist -- nfa / false )
>r 2dup r> bucket @ (tablefind) ;
>r 2dup r> bucket @ (tablelfind) ;
Create tablesearch-map ( -- wordlist-map )
' table-find A, ' hash-reveal A, ' (rehash) A, ' (rehash) A,
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment