/* aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa 0.6.2 H3sm 3-stack programming interface (virtual machine design) in gcc C 19980423 --> 19981224 Rick Hohensee humbubba@smart.net http://www.smart.net/~humbubba/ 19981219 --> 19981229 Michael Somos "http://grail.cba.csuohio.edu/~somos/" Early versions may depend on 4 byte address cell. For big-endian CPU use "gcc -DBIGEND H3sm.c" instead of "gcc H3sm.c". Initial implementation. REQUIRES *GNU* C computed goto capability. `hezzum'. Vowel sounds as in best fun , emphasis on first syllable. See also Ertl/Paysan GForth and GNU .info on gcc "labels as values". The sourcecode of the "Arith" and "calc" arbitrary precision arithmetic packages for unices were consulted for this implementation of pyte arithmetic, although pytes are quite different than numbers in those systems. Phil Koopman's book "Stack Computers: The New Wave" bears mention. It is currently on the web at "http://www.cs.cmu.edu/~koopman/stack_computers/". Also worth mention are the generally meritocratic and cooperative tones of comp.lang.forth, MdFIG and linux-kernel@vger.rutgers.edu. Greg Patterson (xed) was helpful at a particularly frustrating moment with C pointers. Two design features of H3sm were suggested by Jet Thomas; the single-whole-pass dictionary search method of suffind (if implemented), and that pyte sizes go up to 256 bytes instead of 128. I have a copy of John Brien's "Build Your Own Forth" webpage in my /usr/src/H3sm . (original URL is "http://www.users.zetnet.co.uk/aborigine/byof.htm") The printer Charles Lasitter gave me has done yeoman service as an essential debugging tool. As pertains copyrights and release thereof, H3sm is not a derived work of any prior work. This implementation of H3sm is hereby released into the public domain. I assume that due author aknowledgement for reuse of this code, or reuse of any concepts presented here, will be observed. I believe various aspects of pytes are original, for example. Subsequent implementations or variants of H3sm by me may or may not be released, under any terms, as may be specified at such time. This works on Linux with the default gcc/cpp #includes. Virtual Machine Subroutine Threaded H3sm. All executable dictionary cells contain actual addresses of code. The address of a sub-word is in the callER, following a call xt. OK, here we go... */ int main(void){ /* This initial H3sm is all in one C "function". return type doesn't mean much to H3sm. */ typedef unsigned char byte; /* ## ## ## Virtual machine address space, stacks and registers. ## ## ## Things that would be in a simple silicon 3-stacker, OR would go away if implemented in silicon. The 3 core stack pointers are abbreviated with "l" for lubber. A lubber is the nautical equivalent of a cursor, like a sliderule cursor, but on e.g. a ship's compass. A landlubber is a sailor that is always on the part of the deck closest to land. The H3sm Virtual (Machine) Address Space may be addressed on int or byte ply. The user variables, dictionary and free heap are within the VMAS. Host facilities are outside the VMAS, and must have H3sm fundamental ops written for them to access host services. "time" is a simple example of a host service. THE 3 STACKS Each of the 3 "stacks" has a distinctly different related ops from the other 2. return The return stack will contain only xt's. An xt is what NEXT can use, a virtual address space int-ply index to a fundamental, which is a jump to machine code. One day we might do loop indices and such on the return stack too. pointer The H3sm pointer stack is cell-sized, but contains only actual host address-space pointers usually. Such an entity is called a "pointer" from the H3sm-user point of view. The pointer stack may be a bridge between the H3sm VM and the host, but only with specific fundamentals for host services, such as "time", file ops and so on. Pointer stack operands involving the VM address-space perform conversions from pointers to VM addresses. The pointer stack is sluggish, it is not auto-pop/push. The pointer stack pointer is usually left pointing to an occupied cell. When a VM address is put on the pointer stack it is converted to an actual address, i.e. in H3sm-speak, from an address to a pointer. An "address" is a H3sm VM address. Or something like that. data The data stack operates on "pytes", groups of 1, 2, 4, 8, 16....256 bytes. Hi Boolean flags are the low byte of a pyte. False is zero. Non-zero is true. The H3sm true word asserts 255 in a flagpyte. Size "Register" The current effective size of data stack operands is the Size state variable. There are user-visible accessors of this Size "register". Operations on pytes are in terms of Size, except where a pyte is treated as a flag. So the 3 stacks are the data typing of H3sm. Typing is enforced by the various operands. The data stack is where a datum can be treated arbitrarily. In terms of implementation, the current data stack lubber points at the low significance byte of the next VACANT pyte, above TOS. This is known as post-increment/pre-decrement. The pointer stack lubber is usually left ON a pointer. */ int ip; /* instruction pointer, virtual program counter what NEXT jumps to, and leaves incremented. int resolution index into VMAS. */ int dsl; /* data stack lubber, BYTES */ byte ds[32 * 0x400]; /* data byte stack, byte access */ /* byte-only data stack, everything gets converted to bytes. In this version. */ int rsl; /* return stack lubber */ int rs[1024]; /* return stack itself, ints = xt's */ int psl; /* pointer stack lubber */ void *ps[1024]; /* the pointer stack itself, an array of generic pointers */ int Size = 1; /* size of a data stack operation */ #define vassize 1024 * 64 /* Size of the heap. */ union heap { /* virtual address space, including dictionary */ byte b[vassize]; /* de-typed to bytes or ints */ int i[vassize / 4 ]; /* heap is the typename, used here only */ } vas; /* must use unary & to use on pointer stack */ byte block[0x400 * 3]; char TIB[256]; /* plain c string for now */ char nos[600]; /* number output string */ int latest; /* VM addess of count byte of latest word, this is a cheat. */ int vaszero; /* actual address of vas.x[0] for A>VAS conversions */ int addy1, addy2, addy3, /* flow control label names. */ addy4, addy5, addy6; #define NEXT goto *vas.i[ip++]; /* V.M.S.T. NEXt is simple. We pay for it elsewhere, but mostly in the interpreter. */ /* Somos */ #ifdef BIGEND #define BYTES(b0,b1,b2,b3) ((b0)<<24|(b1)<<16|(b2)<<8|(b3)) #else #define BYTES(b0,b1,b2,b3) ((b3)<<24|(b2)<<16|(b1)<<8|(b0)) #endif #define AWORDS * 4 #define DROP dsl = dsl - Size ; #define BUMP dsl = dsl + Size ; #define TRUE dsl = dsl + Size ; ds[dsl] = 255 ; #define FALSE dsl = dsl + Size ; ds[dsl] = 0 ; #define SWAP \ j = dsl - Size ; \ for ( i = 0; i < Size ; i++ ) \ { bite = ds[dsl + i] ; \ ds[dsl + i] = ds[dsl -Size + i] ; \ ds[dsl - Size + i] = bite ; \ } \ #define SIGN \ bite = 0 ; \ if ( ds[dsl + Size - 1 ] & 128 ) \ { bite = 254 ; \ } \ else { \ for ( i = 0 ; i < Size ; i++ ) \ { if ( ds[dsl + i ] ) \ { bite = 1 ; \ } \ } \ } /* nucleus dictionary builder stuff, gone after H3sm builds itself. Extra variables and so on are OK as long as they aren't visible in the H3sm VM. */ int tdp; /* temporary dictionary pointer for kernel build */ int tdpb; /* byte version of above */ int linkTemp; /* count byte of previously appended word */ int nl; /* name length, for aligning */ int nfa; /* name field allotment */ /* call addresses of non-atoms for init thread construction */ int numberaddy, dpaddy, tokenaddy, interpretaddy, suffixedaddy, stringsequaladdy, querycontentsaddy, querywordaddy, suffindaddy, p2dupaddy, p2plussaddy, endparseareaaddy, beginparseareaaddy, tibaddy, esizeaddy, hexdigitsaddy, digitsaddy, queryhexaddy, querynumberaddy, asciiTOdigitaddy, benchaddy, tlenaddy, parseaddy, dotokenaddy, nineaddy ; char *name; /* for _H3sm_ names in builder */ int scratch ; /* crud */ int *pscratch; int i, j, e, fid, newfid; byte bite; char *dic="dictionary"; /* ###### PAU, Pyte Arithmetic Unit declarations ####### Namespace bloat here doesn't effect the H3sm user. */ typedef unsigned short dual; /* 16 bits. 2 bytes. */ byte signA, signB, signR; /* signs of args and result */ byte magA, magB; /* magnitudes of arguments for pre-trimming */ int magdiff, cells; byte obase = 16; byte bits, net; byte ibase = 16; byte bytes[512]; dual accum[512]; dual lowMask = 0xff00; dual highMask = 0x00ff; dual head; /* ****** end declarations *********************************** */ printf("total Virtual Address Space including dictionary is %d bytes.\n", sizeof(vas)); vaszero = (int) & vas.i[0] ; /* host address of VMAS, byte ply crucial for A>VAS conversions. */ goto past_the_fundamentals; /* The fundamentals are the actual runtime machine code of H3sm. The following code has to be *compiled* here, but where it gets called from and where it jumps to is what the labels are for, so we skip it for now with a goto. Everything we need the real machine for should be in here. We use gotos ( in NEXT, e.g.), but in the manner of _uncooked_ spaghetti, i.e. the gotos of the NEXTs of each word are laminar, not tangled. The code following the fundamentals just builds the dictionary, i.e. just runs once at init time. "atoms" might be a good term, since fundamentals are atomic. Stack comments data ( --- ) return (R; --- ) pointer (P; --- ) For some words that need stack items they don't modify, I use ( required ||| consumed --- produced ) e.g. over ( a b ||| --- a ) (... is a running stack comment, showing the current stack *state* after the current word. "|null" means "or no stack item". I wish stack comments were concise, but no guarantees. State comment !SIZE means word probably modifies Size. FORMAT of label: lines of fundamentals fundamental name: [name] (stacks effects) state effects */ /* ======================================================================== */ address: /* (P; --- ptr ) }Push our DFA address. Basic named data instance word runtime action. analog of Forth "dovar", but to pointer stack{ */ ps[++psl] = &vas.i[ip] ; ip = rs[rsl--] ; /* An inline LEAVe. Data instance words are CALLed, but do their own return/leave. */ NEXT /* ======================================================================== */ AND: /* ( pytea pyteb --- pyteaandb ) */ DROP for ( i = 0 ; i < Size ; i++ ) ds[dsl + i] = ds[dsl + i] & ds[dsl + Size + i]; NEXT /* ======================================================================== */ bytemask: /* a violation of my at_least_3_component_words factoring rule. This is a just pyte constant and an AND, but it seems to make sense as one word, perhaps even in silicon. */ ds[dsl] = ds[dsl] & 255 ; for ( i = 1 ; i < Size ; i++ ) { ds[dsl +i] = 0 ; } NEXT /* ======================================================================== */ dualmask: /* ( --- 0xffff ) might be handy for Unicode */ BUMP ds[dsl] = 255 ; ds[dsl + 1] = 255 ; for ( i = 2 ; i < Size ; i++ ) { ds[dsl +i] = 0 ; } NEXT /* ======================================================================== */ bytes: /* 1 !SIZE */ Size = 1 ; NEXT; /* ======================================================================== */ call: /* (R; --- xt ) A>VAS see also Return and Forth ENTER */ rs[++rsl] = ip+1; /* save return ip, skip call cell. */ ip = vas.i[ip] ; /* ip is from call cell, NEXT will jsr */ NEXT /* ======================================================================== */ cells: /* 4 !SIZE */ Size = 4 ; NEXT /* ======================================================================== */ aint: /* ( flagp --- !flagp ) the NOT of a flag */ ds[dsl] = ~ ds[dsl] ; NEXT /* ======================================================================== */ bump: /* bump ( --- junk ) }undrop{ */ BUMP NEXT /* ======================================================================== */ bye: /* return to caller of H3sm with flag byte of TOS */ return (int) ds[dsl] ; /* no NEXT */ /* ======================================================================== */ charsize: /* CHARSIZe !SIZE cheat. poking Size in high-level is a pain. */ Size = 1 ; /* CHARSIZE ASSUMPTION */ NEXT /* ======================================================================== */ doHNC: /* (P; HNIC --- ) (R; --- RET|null ) Forth "execute" and then some */ /*if derived */ if ( ! ( ((byte*)ps[psl]) [2] & 0x80 ) ) /* Somos [2] */ { rs[++rsl] = ip ; ip = ( (int)ps[psl] + ( (*(byte*)ps[psl] + 3) & 0xfc ) + 8 - vaszero ) >> 2 ; psl--; goto *vas.i[ip++]; /* nEXT */ } /* IF atom */ ps[psl] = (void*)( (byte*)ps[psl] + ( (*(byte*)ps[psl] + 3) & 0xfc ) + 8 ) ; goto **(int *)ps[psl--]; /* ======================================================================== */ downsize: /* shift Size down, or to one !SIZE **/ if ( Size > 1 ) { Size = Size >> 1 ; } else { printf("Oops. Can't downsize from 1 \n"); } NEXT /* ======================================================================== */ drop: /* ( pyte --- ) **/ DROP NEXT /* ======================================================================== */ dup: /* ( pytea ||| --- pytea ) **/ BUMP for (i = 0; i < Size; i++) ds[dsl+i]=ds[dsl+i-Size]; NEXT /* ======================================================================== */ ell: /* ell , followed in dict. by VMAS target }unconditional branch{ */ ip = vas.i[ip]; /* put the int following this instr. in ip */ NEXT /* ======================================================================== */ pstore: /* !p (P; p store ||| --- p store ) }p becomes contents of store, no pdrops{ stack-backwards storep. */ *(int*)ps[psl] = (int) ps[psl-1] ; NEXT /* pstore NOT checked */ /* ======================================================================== */ /* extend: */ /* ======================================================================== */ emit: /* ( pyte --- ) treated as a char */ putchar(ds[dsl]); /* putchar assumes stdout somehow, what about 16 bit? */ DROP NEXT /* ======================================================================== */ false: /* ( --- 0flag ) */ BUMP ds[dsl]= 0; NEXT /* ======================================================================== */ fetch: /* @ (P; ptr ||| --- ) ( --- pyte ) }fetch a pyte at current Size { */ BUMP for ( i = 0 ; i < Size ; i++) { ds[dsl + i] = ((byte *)(ps[psl]))[i] ; } NEXT /* ======================================================================== */ fetchsize: /* @size (P; noun --- noun ) !SIZE }get and assert Size of pyte or other noun { */ Size = *(int*)((byte*)ps[psl] - 8 ) ; NEXT /* ======================================================================== */ flag: /* ( pyte --- flagpyte ) bytewise OR a pyte into bite, make lsB of pyte 0 or 255 accordingly, Booleanize a pyte */ bite = 0 ; for ( i= 0 ; i < Size ; i++ ) { if ( ds[dsl + i] ) { bite = 255 ; break ; } } ds[dsl] = bite ; NEXT /* ======================================================================== */ four: /* ( --- 4 ) pyte constant */ BUMP ds[dsl] = 4 ; for ( i = 1 ; i < Size ; i++ ) { ds[dsl +i] = 0 ; } NEXT /* ======================================================================== */ gap: /* ( --- ptra-b ) (P; ptra ptrb ||| --- ) }the difference between pointers{ opposite sense might make more sense. (o: */ BUMP scratch = (byte*)ps[psl - 1] - (byte*)ps[psl] ; for ( i = 0 ; i < Size ; i++ ) { ds[dsl +i] = scratch & 0xff ; scratch >>= 8 ; } NEXT /* ======================================================================== */ hostfn: /* ( --- sh.ret.val ) (P; epa bpa ||| ) !BUFFER0 }invoke a host shell on parse area{ a zero is aggressively appended to end of parse area + 1 and epa on P stack is incremented. */ /* ps[psl-1]++ ; */ *(char*) ps[psl-1] = '\0' ; scratch = system( (char*)ps[psl] ) ; BUMP for ( i = 0 ; i < Size ; i++ ) { ds[dsl +i] = scratch & 0xff ; scratch >>= 8 ; } NEXT /* from the system() manpage.... int system (const char * string); DESCRIPTION system() executes a command specified in string by calling /bin/sh -c string, and returns after the command has been completed. During execution of the command, SIGCHLD will be blocked, and SIGINT and SIGQUIT will be ignored. */ /* ======================================================================== */ /* messed up */ max: /* ( a b --- maxab ) */ SIGN signA = bite ; /* SI.GN's result is bite */ DROP SIGN signB = bite ; if ( signA == signB ) { if ( ! signA ) /* both #'s are 0 */ { NEXT } magdiff = -1 ; /* signs = */ for ( i = Size ; i ; i-- ) { if ( ds[dsl + i] == ds[dsl + i + Size] ) { magdiff = i ; break ; } } if ( magdiff == -1 ) { NEXT /* #'s equal */ } if ( ds[dsl - magdiff] > ds[dsl - Size - magdiff] ) { BUMP SWAP DROP } NEXT } else { /* unequal signs solution */ if ( signA > signB ) { BUMP SWAP DROP } } NEXT /* ======================================================================== */ NOT: /* NOT ( pyte --- !pyte ) */ for ( i = 0 ; i < Size ; i++ ) ds[dsl +i] = ~ ds[dsl +i]; NEXT /* ======================================================================== */ negate: /* ( a --- 2's_complement_negative_a ) */ bite = 1 ; for ( i = dsl ; i < dsl + Size ; i++ ) { if ( ds[i]==0 && bite ) bite |= 2 ; ds[i] = ((byte)0xff - ds[i]) + (bite&1) ; bite = bite>>1 ; } NEXT /* ======================================================================== */ last: /* (P; --- count.byte.addr ) }address of last definition{ */ ps[++psl] = (int *)latest; /* nonPOIN */ NEXT /* ======================================================================== */ /* messed up and unchecked */ literal: /* ( --- pyte ) !SIZE */ /* put a pyte from the thread onto the data stack, runtime action of a literal number in a thread. */ Size =vas.i[ip] & 15; /* get literal's size, ip points at data */ /* the & 15 is sloppy as hell, maybe needless */ ip = ip +1; scratch = ip << 2; /* ip as bytes, using scratch to keep the loop tidy */ /* push */ for ( i=0 ; i> 2; /* we use e to figure the skippage */ if ( e == 0 ) { e = 1 ; } ip = ip + e; NEXT /* ======================================================================== */ minusp: /* -p ( pyte --- ) (P; ptr --- ptr-intpartofpyte ) */ /* ENDIANISM ISSUE */ j = Size; if ( Size > 4 ) j = 4; for (i=0; i < j;i++ ) ps[psl] = (void*) ( (byte*)ps[psl] - (ds[dsl+i]<<(8 * i)) ) ; DROP NEXT /* ======================================================================== */ no: /* ( flagpyte --- ) conditional branch if true "yes" branch target in next cell, the "no" branch follows immediately thereafter. */ if ( ds[dsl] ) /* conditional on low-order byte of current pyte */ { ip = vas.i[ip]; /* put the int following this instr. in ip */ } else { ip++; /* skip branch target addy */ } DROP NEXT /* ======================================================================== */ nothing: NEXT /* ======================================================================== */ nown: /* (P; --- nown_body ) */ ps[++psl] = &vas.i[ip + 6] ; /* 6 cells to returned addy */ ip = rs[rsl--] ; /* in-line leave */ NEXT /* ======================================================================== */ onbits: /* ones ( --- -1 ) or fffff.... }all_ones pyte constant{ */ BUMP for ( i = 0 ; i < Size ; i++ ) { ds[dsl + i] = 255 ; } NEXT /* ======================================================================== */ one: /* ( --- 1 ) pyte constant */ BUMP ds[dsl] = 1 ; for ( i = 1 ; i < Size ; i++ ) { ds[dsl + i] = 0 ; } NEXT /* ======================================================================== */ OR: /* ( pytea pyteb --- pyteaORb )-1 */ DROP for ( i = 0 ; i < Size ; i++ ) ds[dsl + i] = ds[dsl + i + Size] | ds[dsl + i] ; NEXT /* ======================================================================== */ over: /* ( a b --- a b a ) */ BUMP e = Size << 1 ; /* 2x Size */ for (i = 0 ; i < Size ; i++ ) { ds[dsl + i] = ds[dsl + i - e]; } NEXT /* ======================================================================== */ pdrop: /* (P; ptr --- ) decr pointer stack lubber */ --psl; NEXT /* ======================================================================== */ pdup: /* (P; ptra --- ptra ptra ) */ ps[++psl] = ps[psl -1 ] ; NEXT /* ======================================================================== */ period: /* ( --- 46 ) ASCII . pyte constant */ BUMP ds[dsl] = 46 ; for ( i = 1 ; i < Size ; i++ ) { ds[dsl + i] = 0 ; } NEXT /* ======================================================================== */ pfetch: /* p@ (P; ptr1 --- ptr2 ) ptr1 overwritten UC */ /* Forth @, if param stack is ptr stack */ ps[psl] = (void*) ( *(int*)ps[psl] ) ; NEXT /* ======================================================================== */ plus: /* + ( a b --- c ) */ DROP bite = 0 ; for ( i = dsl ; i < dsl + Size ; i++ ) { if ( (~ds[i]&0xff)>1 ; } NEXT /* ======================================================================== */ plusp: /* +p ( pyte --- ) (P; ptr --- ptr+bytepartofpyte ) */ /* ENDIANISM ISSUE */ ps[psl] = (void*) ( (byte*)ps[psl] + ds[dsl] ) ; DROP NEXT /* ======================================================================== */ pMINUSs: /* p-s (P; ptr --- ptr-Size ) */ ps[psl] = (void*) ( (byte*)ps[psl] - Size ) ; NEXT /* ======================================================================== */ pPLUSs: /* p+s (P; ptr --- ptr+Size ) */ ps[psl] = (void*) ( (byte*)ps[psl] + Size ) ; NEXT /* ======================================================================== */ pplusb: /* p+b (P; ptr --- ptr+1 ) */ ps[psl] = (void*) ( (byte*)ps[psl] + 1 ) ; NEXT /* ======================================================================== */ pplusc: /* p+c (P; ptr --- ptr+4 ) */ ps[psl] = (void*) ( (byte*)ps[psl] + 1 AWORDS ) ; NEXT /* ======================================================================== */ pminusc: /* p-c (P; ptr --- ptr-4 ) */ ps[psl] = (void*) ( (byte*)ps[psl] - 1 AWORDS ) ; NEXT /* ======================================================================== */ pminusb: /* p-b (P; ptr --- ptr-1 ) */ ps[psl] = (void*) ( (byte*)ps[psl] - 1 ) ; NEXT /* ======================================================================== */ pTOs: /* (P; Size ||| ) !Size */ Size = (int) ps[psl] ; NEXT /* ======================================================================== */ sTOp: /* (P; --- Size ) */ ps[++psl] = (void *) Size ; NEXT /* ======================================================================== */ storep: /* p! (P; store p ||| --- store p ) }p (on top) becomes contents of store, no pdrops{ */ *(int*)ps[psl-1] = (int) ps[psl] ; NEXT /* pstore NOT checked */ /* ======================================================================== */ pswap: /* pswap (P; a b --- b a ) */ e = (int)ps[psl] ; ps[psl] = ps[psl - 1] ; ps[psl - 1] = (void *)e ; NEXT /* ======================================================================== */ pTOr: /* p>r (P; ptr ||| ) (R; --- ptr ) */ rs[++rsl] = (int) ps[psl] ; NEXT /* ======================================================================== */ pUP: /* (P; --- oldptr ) */ ++psl; NEXT /* ======================================================================== */ push: /* (R; --- ip ) }push address of following word as return address{ */ rs[++rsl] = ip ; NEXT /* ======================================================================== */ /* QUERIES precede an if, i.e. a yes or a no . queries are tests, and generate flags in the low significance byte of a pyte. The yes and no conditional branch instructions consider pytes with a low byte 0 as false. 256 will test as false unless you flag it. flag ORs all the onbits in a pyte into it's lsB, making a flagpyte. flag can be an information loss. ?space ?= ?p= ?digit ?atom */ /* ======================================================================== */ queryequal: /* ?= ( a b --- flagpyte ) */ /* are top two pytes equal? flag for ifbranch/tee */ bite = 255; /* boolean accum set to true */ DROP for ( i = dsl ; i < dsl + Size ; i++ ) { if ( ds[i] != ds[i + Size] ) { bite = 0; /* not =, set to false and exit loop */ break; } } ds[dsl] = bite; /* flagbyteTOS set to result boolean */ NEXT /* ======================================================================== */ rdrop: /* (R; a --- ) */ rsl-- ; NEXT /* ======================================================================== */ Return: /* return (R; xt --- ) }return control to caller{ */ ip = rs[rsl--]; /* return from a call */ NEXT /* ======================================================================== */ rpcopy: /* (R; a ||| ) (P; --- a ) dup r to p */ ps[++psl] = (void *) rs[rsl] ; NEXT /* ======================================================================== */ rTOp: /* r>p (R; ptr --- ) (P; --- ptr ) not symmetrical with p>r. */ ps[++psl] = (void *) rs[rsl--] ; NEXT /* ======================================================================== */ rTOs: /* r>s (R; size --- ) !SIZE We should watch where a user can write Size. */ Size = rs[rsl--] ; NEXT /* ======================================================================== */ saveDictionary: /* */ fid =open(dic, 1); e = (int)write( fid, vas.b, vassize ); printf("size of dictionary saved %d\n", e); NEXT /* ======================================================================== */ sign: /* ( pyte --- 1 or 254 or 0 ) pos = 1, neg = 254, 0 = 0 */ SIGN ds[dsl] = bite ; NEXT /* ======================================================================== */ sixteen: /* ( --- 16 ) pyte constant, decimal 16 */ BUMP ds[dsl] = 16 ; for ( i = 1 ; i < Size ; i++ ) { ds[dsl + i] = 0 ; } NEXT /* ======================================================================== */ sized: /* (P; --- ptr ) VAS>A sized pushes the address of the data. @size can assert Size from that. */ /* to be followed by fetch or store */ ps[++psl]= (int *)&vas.i[ip+1]; ip = rs[rsl--]; /* inline Return. Nouns do that. */ NEXT /* ======================================================================== */ size: /* ( --- Size ) */ BUMP ds[dsl]=(byte)Size; /* new datum is Size */ for ( i = 1 ; i < Size ; i++ ) { ds[dsl + i] = 0 ; } NEXT /* ======================================================================== */ sTOr: /* s>r (R; --- Size ) */ rs[++rsl] = Size ; NEXT /* ======================================================================== */ space: /* ( --- 32pyte ) }pyte constant for a space{ */ BUMP ds[dsl] = 32 ; for ( i = 1 ; i < Size ; i++ ) { ds[dsl +i] = 0 ; } NEXT /* ======================================================================== */ /* Got milk? */ store: /* ! (P; ptr --- ptr ) ( pyte --- ) pointer is used, unaffected */ for ( i = 0 ; i < Size ; i++ ) { ((byte *)ps[psl])[i] = ds[dsl+i]; } /* ps[psl] is an address */ DROP NEXT /* store NOT checked */ /* ======================================================================== */ swap: /* ( pytea pyteb --- pyteb pytea ) */ SWAP NEXT /* ======================================================================== */ ten: /* ( --- 10 ) pyte constant, decimal 10. */ BUMP ds[dsl] = 10 ; for ( i = 1 ; i < Size ; i++ ) { ds[dsl +i] = 0 ; } NEXT /* ======================================================================== */ three: /* ( --- 1 ) pyte constant */ BUMP ds[dsl] = 3 ; for ( i = 1 ; i < Size ; i++ ) { ds[dsl + i] = 0 ; } NEXT /* ======================================================================== */ time: /* ( --- utime.int ) 4 !SIZE }unix timestamp.{ */ scratch=time((void*)0); for (i=0;i< Size;i++) ds[dsl++]=scratch>>(8*i); NEXT /* ======================================================================== */ TOcode: /* (P; HNC --- Code_Body_Cell ) */ ps[psl] = (void*)( (byte*)ps[psl] + ( (*(byte*)ps[psl] + 3) & 0xfc ) + 8 ) ; NEXT /* ======================================================================== */ TOlast: /* (P; ptr --- ) update latest/last */ latest = *(int *)ps[psl--]; NEXT /* TOlast NOT checked */ /* ======================================================================== */ TOlink: /* (P; HNC --- Link_Cell ) this should mask off the upper 3 count bytes. Yes, it's OK to be scared. This IS sick. */ ps[psl] = (void*)( (byte*)ps[psl] + ( (*(byte*)ps[psl] + 3) & 0xfc ) + 4 ) ; NEXT /* ======================================================================== */ TOsize: /* >s ( size --- ) !SIZE */ Size = ds[dsl] ; if ( !Size ) Size = 256 ; DROP NEXT /* ======================================================================== */ true: /* true ( --- true_flagpyte ) */ BUMP ds[dsl] = 255 ; NEXT /* ======================================================================== */ two: /* ( --- 2 ) pyte constant */ BUMP ds[dsl] = 2 ; for ( i = 1 ; i < Size ; i++ ) { ds[dsl + i] = 0 ; } NEXT /* ======================================================================== */ ushift: /* ushift ( shiftee amount --- shifted ) }}up-significance bitshift, shiftl{{ */ /* dsl is amount , ds is POIN/PRED */ cells = ds[dsl] >> 3 ; /* cellshift value */ net = ds[dsl] - (cells << 3); /* from here up checks */ for ( i = 0 ; i < cells ; i++ ) { accum[i]=0; /* leftpad 0-cells */ } /* otherwise there will be junk */ DROP /* dsl is shiftee */ for ( i = 0 ; i < Size ; i++ ) /* cell&bit shift to accum */ { accum[cells + i] = ds[dsl + i] << net ; } ds[dsl] = accum[0] ; /* avoid accum underrun below */ for ( i = 1 ; i < Size ; i++ ) { ds[dsl + i] = (accum[i] & highMask) | ((accum[i-1] & lowMask)>> 8 ) ; } NEXT /* ======================================================================== */ upsize: /* !SIZE */ if ( Size < 256 ) { Size = Size << 1 ; } else { printf("failed to upsize maximal Size pyte.\n") ; } NEXT /* ======================================================================== */ vasbase: /* (P; --- addr.of.vas.x[0] ) s */ ps[++psl] =(void *)vaszero; NEXT /* ======================================================================== */ wait: /* (P; bpa ||| --- epa ) blocks flow save chars at ptr bpa, ending on enter key at pushed pointer epa. There's a slight interpretation performance hit, since the loop doesn't seem to happen *until* char is 10/return . Ideally this would handle Unicode, but I use getchar() here. This one is not Size-sensitive. */ ps[++psl] = ps[psl-1] ; /* inline pdup */ for (i = 0 ; i < 255 ; i++ ) { *((byte *)ps[psl]) = getchar(); if ( *(byte *)ps[psl] == 10 ) { break; } ps[psl] = (void*) (1+(int)ps[psl]) ; } NEXT /* ======================================================================== */ wipesl: /* 0sl ( what ever ... --- ) a stack pointer is a "lubber" */ dsl = 0; NEXT /* ======================================================================== */ wipepsl: /* 0psl (P; what ever ... --- ) */ psl = 0; NEXT /* ======================================================================== */ wipefsl: /* 0fsl (R; what ever ... --- ) */ rsl = 0; NEXT /* ======================================================================== */ XOR: /* ( pytea pyteb --- pyteaXORb ) */ DROP for ( i = 0 ; i < Size ; i++ ) ds[dsl + i]=ds[dsl + Size + i] ^ ds[dsl+i]; NEXT /* ======================================================================== */ yes: /* ( flagpyte --- ) conditional branch if false. "no" branch target in next cell. "yes" branch immediately thereafter, i.e. more visually proximate in a fuzzy kinda way IMO. */ if ( ! ds[dsl] ) /* conditional on low-order byte of current pyte */ { ip = vas.i[ip]; /* put the int following this instr. in ip */ } else { ip++; /* skip branch target addy */ } DROP NEXT /* ======================================================================== */ zero: /* zero ( --- 0 ) 0 as a pyte constant */ BUMP for ( i = 0 ; i < Size ; i++ ) { ds[dsl + i] = 0; } NEXT /* ======================================================================== */ a: printf("a a a a a a a\n"); NEXT /* ======================================================================== */ ok: /* ok */ printf("O-TAY!\n"); NEXT /* ======================================================================== */ regs: /* machine language monitor style stack pic */ printf(" RETURN POINTER DATA pyte Size = %d\n", Size); for ( i=0; i<6; i++ ) { printf("%10x %10x ", i<=rsl?rs[rsl-i]:0, i<=psl?(int)ps[psl-i]:0); { if (!i) {printf("msB, lower bytes --->");} else for ( j = Size-1 ; j >= 0 ; j-- ) { printf("%02x ", ds[dsl - (Size * (i - 1 ) ) + j ] ); } if ( i == 1 ){ printf(" T.O.D.S. "); } printf("\n"); } } printf(" rsl= %d psl= %d dsl = %d = lsB of TOS ip = %d\n\n", rsl, psl, dsl, ip); NEXT /* ======================================================================== */ tdump: /* (P; text ||| --- ) }print 16 ascii chars from ptr{ */ for ( i = 0 ; i < 8 ; i++ ) { printf("%c",((char*)ps[psl])[i]); } printf(" \n"); NEXT /* ======================================================================== */ printSize: printf("Size is %d ", Size); NEXT /* ======================================================================== */ bbb: printf("bbbbBBBBbbbbBBBBbbbbBBBBbbbbBBBB\n"); NEXT /* ======================================================================== */ aaa: printf("aaaaaaad\n"); NEXT /* ======================================================================== */ past_the_fundamentals: /* end of fundamentals (primitives) code only executed by VM gotos */ /* *@*@*@*@*@*@*@*@*@*@*@*@*@*@*@*@*@*@*@*@*@*@*@*@*@*@*@*@*@*@*@*@ */ /* ### ## ###### ## build H3sm nuclear dictionary ## # ### below here we build the dictionary a cell at a time. Lots of code ( hidden by macros a bit ) for little end result. Oh well. */ printf ("actual address of VAS is 0x%x\n\n", vaszero ); printf ("gcc-compiled at " __TIME__ " on " __DATE__ "\n\n"); tdp = 0x600; /* pointer into dictionary as ints */ /* ANATOMY OF A DICTIONARY WORD [optional in brackets] (lower VMAS addresses) [future expansion area ] Head Name Interface Cell, HNC (4 bytes in this H3sm) count unused atomic bit unused xxxxxxxx oooooooo Xxxxxxxx oooooooo name byte neck (name field cell aligned) name byte neck . neck . neck . [up to 3 pad bytes] [neckneckneck] 4 byte LINK Cell neckneckneckneck (actual address) 4 byte CODE Cell bodybodybodybody (machine code address) [whatever] [body] (higher VMAS memory ) . . OK, cpp macros for all the standard build_a_word_neck stuff. Saves bulk. */ #define NECK \ nl=strlen(name); /* length of H3sm name */\ nfa =(nl +3) >> 2; /* name field allotment*/\ vas.i[tdp]=0; /* zero out HNC */\ vas.b[tdp++<<2]=nl; /* cnt in bytes to LsB of HNC */\ strcpy((char*)vas.b+(tdp<<2),name); /* name field */\ tdp = tdp + nfa ; /* skip NFA */\ vas.i[tdp++]=linkTemp; /* link field to previous word NF */\ linkTemp=(int)&vas.i[tdp-2-nfa]; /* next link will see our count cell */ #define ATOM \ nl=strlen(name); /* length of H3sm name */\ nfa =(nl +3) >> 2; /* name field allotment*/\ vas.i[tdp]=0; /* zero out HNC */\ vas.b[(tdp<<2)+2]= 0x80; /* set atomic bit */\ vas.b[tdp++<<2]=nl; /* cnt in bytes to LsB of HNC */\ strcpy((char*)vas.b+(tdp<<2),name); /* name field */\ tdp = tdp + nfa ; /* skip NFA */\ vas.i[tdp++]=linkTemp; /* link field to previous word NF */\ linkTemp=(int)&vas.i[tdp-2-nfa]; /* next link will see our count cell */ #define CELL vas.i[tdp++]= #define OP vas.i[tdp++]= (int) && #define CALL vas.i[tdp++]= (int) && call ; #define LEAVE vas.i[tdp++]= (int) && Return ; #define BRANCH vas.i[tdp++]= tdp /* You *call* named data instances, but they have inline returns. */ name="aardvark"; /* first word in the Dictionary. aardvark exists just to be un" find"able due to 0 count byte and/or code field. Handrolled ( non-macro ) neck. */ nl=0; /* length of H3sm name */ nfa =(8 +3) >> 2; /* name field allotment */ vas.i[tdp]=0; /* zero out HNC */ vas.b[tdp++<<2]=nl; /* cnt in bytes to LsB of HNC */ strcpy((char*)vas.b+(tdp<<2),name); /* name field */ tdp = tdp + nfa ; /* skip NFA */ vas.i[tdp++]=linkTemp; /* link field to previous word NF */ linkTemp=(int)&vas.i[tdp-2-nfa]; /* next link will see our count cell */ vas.i[tdp-1]=0 ; /* aardvark's zero link field, overwrite */ vas.i[tdp++]=0; /* zero code field for aardvark */ /* build the dictionary entries for atoms, machine (C) names now get H3sm names. This H3sm is case-sensitive. H3sm C */ name = "address" ; ATOM OP address ; name = "AND" ; ATOM OP AND ; name = "bytemask" ; ATOM OP bytemask ; name = "bytes" ; ATOM OP bytes ; name = "cells" ; ATOM OP cells ; name = "aint" ; ATOM OP aint ; name = "bump" ; ATOM OP bump ; name = "bye" ; ATOM OP bye ; name = "charsize" ; ATOM OP charsize ; name = "downsize" ; ATOM OP downsize ; name = "drop" ; ATOM OP drop ; name = "dup" ; ATOM OP dup ; name = "ell" ; ATOM OP ell ; name = "emit" ; ATOM OP emit ; name = "false" ; ATOM OP false ; name = "@" ; ATOM OP fetch ; name = "@size" ; ATOM OP fetchsize ; name = "flag" ; ATOM OP flag ; name = "four" ; ATOM OP four ; name = "gap" ; ATOM OP gap ; name = "hostfn" ; ATOM OP hostfn ; name = "max" ; ATOM OP max ; name = "negate" ; ATOM OP negate ; name = "NOT" ; ATOM OP NOT ; name = "last" ; ATOM OP last ; name = "literal" ; ATOM OP literal ; name = "no" ; ATOM OP no ; name = "nothing" ; ATOM OP nothing ; name = "nown" ; ATOM OP nown ; name = "onbits" ; ATOM OP onbits ; name = "one" ; ATOM OP one ; name = "OR" ; ATOM OP OR ; name = "over" ; ATOM OP over ; name = "pdrop" ; ATOM OP pdrop ; name = "pdup" ; ATOM OP pdup ; name = "period" ; ATOM OP period ; name = "p@" ; ATOM OP pfetch ; name = "+" ; ATOM OP plus ; name = "+p" ; ATOM OP plusp ; name = "p-s" ; ATOM OP pMINUSs ; name = "p+s" ; ATOM OP pPLUSs ; name = "p+b" ; ATOM OP pplusb ; name = "p+c" ; ATOM OP pplusc ; name = "p-c" ; ATOM OP pminusc ; name = "p!" ; ATOM OP pstore ; name = "plusp" ; ATOM OP plusp ; name = "pswap" ; ATOM OP pswap ; name = "pTOr" ; ATOM OP pTOr ; name = "pTOs" ; ATOM OP pTOs ; name = "pUP" ; ATOM OP pUP ; name = "?=" ; ATOM OP queryequal ; name = "r" ; ATOM OP regs ; name = "rdrop" ; ATOM OP rdrop ; name = "leave" ; ATOM OP Return ; name = "rpcopy" ; ATOM OP rpcopy ; name = "rTOp" ; ATOM OP rTOp ; name = "rTOs" ; ATOM OP rTOs ; name = "saveDictionary" ; ATOM OP saveDictionary ; name = "sign" ; ATOM OP sign ; name = "sixteen" ; ATOM OP sixteen ; name = "sized" ; ATOM OP sized ; name = "size" ; ATOM OP size ; name = "sTOr" ; ATOM OP sTOr ; name = "sTOp" ; ATOM OP sTOp ; name = "space" ; ATOM OP space ; name = "!" ; ATOM OP store ; name = "swap" ; ATOM OP swap ; name = "ten" ; ATOM OP ten ; name = "three" ; ATOM OP three ; name = "time" ; ATOM OP time ; name = "TOlast" ; ATOM OP TOlast ; name = "TOlink" ; ATOM OP TOlink ; name = "TOsize" ; ATOM OP TOsize ; name = "two" ; ATOM OP two ; name = "call" ; ATOM OP call ; name = "true" ; ATOM OP true ; name = "ushift" ; ATOM OP ushift ; name = "upsize" ; ATOM OP upsize ; name = "vasbase" ; ATOM OP vasbase ; name = "wait" ; ATOM OP wait ; name = "0sl" ; ATOM OP wipesl ; name = "0psl" ; ATOM OP wipepsl ; name = "0fsl" ; ATOM OP wipefsl ; name = "XOR" ; ATOM OP XOR ; name = "yes" ; ATOM OP yes ; name = "0" ; ATOM OP zero ; /* end of dictionary build section for fundamentals/atoms/primitives. Begin derived words; threads, noun instances. The above is the virtual machine, the following are some things you can do with it. Very important in Virtual Machine Subroutine Threading, above here ( by default) words have the atomic bit set in the Head Name Interface Cell. ddddddddddddddddddddddddd */ /* ||||||||||||||||||||||||||||||||||====================================== */ name = "dp" ; /* (P; --- dp ) */ NECK dpaddy = tdp ; OP address ; CELL 0 ; /* ||||||||||||||||||||||||||||||||||====================================== */ name = "nine" ; /* (P; --- dp ) */ NECK nineaddy = tdp ; OP address ; CELL 9 ; /* ||||||||||||||||||||||||||||||||||====================================== */ name = "tlen" ; NECK tlenaddy = tdp ; OP address ; CELL 0 ; tdp = tdp + 256 ; /* allotment for a maximal pyte */ /* ||||||||||||||||||||||||||||||||||====================================== */ name = "tib" ; /* (P; --- &tib ) */ NECK tibaddy = tdp ; OP address ; CELL (int) &vas.i[200] ; /* ||||||||||||||||||||||||||||||||||====================================== */ name = "hexdigits" ; /* (P; --- &array ) */ NECK /* byte-packed array to work at Size = 1 could be dual-aligned. someday. */ hexdigitsaddy = tdp ; OP address ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; /* Somos */ CELL BYTES(0xffu,0xffu,0xffu,0xffu) ; /* 48 0x30 */ CELL BYTES(0xffu,0xffu,0xffu,0xffu) ; CELL BYTES(0xff,0xff,0x00,0x00) ; CELL 0 ; /* 64 0x40 */ CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL BYTES(0x00,0xff,0xff,0xff) ; CELL BYTES(0xff,0xff,0xff,0x00) ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; /* ||||||||||||||||||||||||||||||||||====================================== */ name = "digits" ; /* (P; --- address_of_array ) */ NECK /* an ascii>value array for up to base 36, lower-case only */ digitsaddy = tdp ; OP address ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL BYTES(0x00,0x01,0x02,0x03) ; /* 48 0x30 */ CELL BYTES(0x04,0x05,0x06,0x07) ; CELL BYTES(0x08,0x09,0x00,0x00) ; CELL 0 ; /* 64 0x40 */ CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL BYTES(0x00,0x0a,0x0b,0x0c) ; CELL BYTES(0x0d,0x0e,0x0f,0x00) ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; CELL 0 ; /* ||||||||||||||||||||||||||||||||||====================================== */ name = "asciiTOdigit" ; /* ( --- nybble ) (P; char ||| ) */ NECK asciiTOdigitaddy = tdp ; OP fetch ; /* (... char (P... ||| char */ OP bytemask ; /* (... nybble (P... ||| char */ CALL CELL digitsaddy ; /* (... char (P... ||| array */ OP plusp ; /* plusp does bytemask (... (P... ||| indexed */ OP fetch ; /* (... nybblepyte (P... ||| indexed */ OP bytemask ; /* (... nybble (P... ||| indexed */ OP pdrop ; /* (... nybble (P... ||| */ LEAVE /* ||||||||||||||||||||||||||||||||||====================================== */ name = "?hex" ; /* ( --- flag ) (P; char ||| ) */ NECK queryhexaddy = tdp ; OP fetch ; /* (... char (P... char ||| */ OP bytemask ; /* (... charbyte (P... char ||| CHARSIZE ASSUMPTION */ CALL CELL hexdigitsaddy ; /* (... charbyte (P... char ||| array */ OP plusp ; /* (... (P... char ||| index */ OP fetch ; /* (... flag (P... char ||| index */ OP bytemask ; OP pdrop ; /* ( --- flag ) (P; char ||| ) */ LEAVE /* ||||||||||||||||||||||||||||||||||====================================== */ name = "?#" ; /* ( len ||| --- flag ) (P; beg.tok ||| ) */ NECK querynumberaddy = tdp ; OP pdup ; /* (P... bt */ OP dup ; /* ( ||| len */ OP one ; OP plus ; /* (... count (P... beg.tok */ addy1 = tdp ; OP onbits ; /* decrement char count (... count -1 (P... beg.tok */ OP plus ; /* (... count' (P... beg.tok */ OP dup ; /* (... count' count' (P... beg.tok */ OP yes ; /* (... count (P... beg.tok */ BRANCH + 10 ; OP nothing ; CALL /* more chars [( --- flag ) (P; char ||| )] */ CELL queryhexaddy ; /* (... count flag (P... beg.tok array */ OP nothing ; OP pplusb ; /* next char (... count flag (P... beg.tok array' */ OP yes ; /* (... count (P... beg.tok array */ BRANCH + 8 ; OP ell ; /* is hex digit (... count (P... beg.tok array */ CELL addy1 ; OP drop ; /* done, is number (... (P... beg.tok */ OP pdrop ; /* (... (P... */ OP true ; /* (... ||| ff (P...||| */ OP nothing ; LEAVE OP drop ; /* not a number (... count (P... beg.tok array */ OP pdrop ; /* (... (P... beg.tok */ OP false ; /* (... 00 (P... beg.tok */ LEAVE /* ||||||||||||||||||||||||||||||||||====================================== */ name = "number" ; /* ( len --- # ) (P; beg.tok ||| ) */ NECK numberaddy = tdp ; OP pdup ; /* (... len (P... ||| bt */ OP zero ; /* (... len accum (P... ||| bt */ addy1 = tdp ; /* LOOP */ OP over ; /* (... len accum len (P... ||| char */ OP yes ; /* (... len accum (P... ||| char */ BRANCH + 14 ; OP four ; /* (... len accum 4 (P... ||| char */ OP ushift ; /* (... len accum< (P... ||| char */ CALL CELL asciiTOdigitaddy ; /* (... len accum< dig (P... ||| char */ OP OR ; /* (... len accum<+ (P... ||| char */ OP swap ; /* (... accum cnt (P... ||| char */ OP onbits ; /* (... accum cnt -1 (P... ||| char */ OP plus ; /* (... accum cntdn " */ OP swap ; /* (... cntdn accum " */ OP pplusb ; /* (... cntdn accum (P... ||| char' */ OP ell ; CELL addy1 ; /* (... len accum (P... ||| char */ OP nothing ; OP pdrop ; /* (... len accum (P... ||| */ OP nothing ; OP swap ; /* (... accu len (P... ||| */ OP drop ; /* (... accu (P... ||| */ LEAVE /* ||||||||||||||||||||||||||||||||||====================================== */ name = "endparsearea" ; /* (P; --- &epa ) */ NECK endparseareaaddy = tdp ; OP address ; CELL 0 ; /* ||||||||||||||||||||||||||||||||||====================================== */ name = "beginparsearea" ; /* (P; --- &bpa ) */ NECK beginparseareaaddy = tdp ; OP address ; CELL 0 ; /* ||||||||||||||||||||||||||||||||||====================================== */ name = "esize" ; /* (P; --- &esize ) */ NECK esizeaddy = tdp ; OP address ; CELL 4 ; /* ||||||||||||||||||||||||||||||||||====================================== */ name = "p2dup" ; /* (P; a b ||| --- a b ) 2dup pointers. */ NECK p2dupaddy = tdp ; /* pTOr/rTOp is a net push to (P;, a pdup */ OP pTOr ; /* (P... a b (R... b */ OP pdrop ; /* (P... a */ OP pTOr ; /* (P... a (R... b a */ OP pUP ; /* (P... a b */ OP rTOp ; /* (P... a b a (R... b */ OP rTOp ; /* (P... a b a b (R... */ LEAVE /* ||||||||||||||||||||||||||||||||||====================================== */ name = "bench" ; /* a crude benchmark routine */ NECK benchaddy = tdp ; OP nothing ; OP time ; /* start seconds stamp */ OP four ; OP one ; OP over ; OP ushift ; OP over ; OP ushift ; OP over ; OP ushift ; OP over ; OP ushift ; OP over ; OP ushift ; OP regs ; OP dup ; /* dup the start count */ addy1 = tdp ; /* LOOP */ OP onbits ; OP plus ; OP dup ; OP flag ; OP no ; CELL addy1 ; OP time ; /* end seconds stamp */ LEAVE /* ||||||||||||||||||||||||||||||||||====================================== */ name = "p2pluss" ; /* (P; ptr ptr --- ptr+s ptr+s ) */ NECK p2plussaddy = tdp ; OP pPLUSs ; OP pdrop ; OP pPLUSs ; OP pUP ; LEAVE /* works at Size = 1 */ /* ||||||||||||||||||||||||||||||||||====================================== */ name = "?(ptrs)" ; /* (P; ptr ptr ||| ) ( --- diff ) }are contents of pointers equal?{ This factors better as an atom, by more than 2:1. */ NECK querycontentsaddy = tdp ; OP fetch ; /* (... a */ OP pdrop ; /* (P... ptr */ OP fetch ; /* (... a b */ OP pUP ; /* (P... ptr ptr ||| --- ) */ OP queryequal ; /* (... flag */ LEAVE /* works */ /* ||||||||||||||||||||||||||||||||||====================================== */ name = "?strings" ; /* (P; beg.str beg.str ||| --- ) ( len ||| --- flag ) ii }compare strings of pytes{ called by ?word at bytes (char) size */ NECK stringsequaladdy = tdp ; OP dup ; OP one ; /* local len=cnt (... 0cnt (P... str str init count */ OP plus ; CALL CELL p2dupaddy ; /* local copies of 2 ptrs */ addy1 = tdp ; OP onbits ; /* (... cnt -1 (P... str str */ OP plus ; /* (... cnt' (P... str str */ OP dup ; /* (... cnt cnt " */ OP yes ; /* (... cnt (P... str str */ BRANCH + 7 ; CALL /* [(P; ptr ptr ||| ) ( --- diff )] */ CELL querycontentsaddy ; /* (... cnt flag (P... str str */ CALL CELL p2plussaddy ; /* (... cnt flag (P... str' str' */ OP no ; /* (... cnt (P... str' str' */ CELL addy1 ; /* from branch (... cnt (P... str str from no (... cnt (P... str' str' */ OP flag ; /* drop char ptrs and leave !cnt as a Boolean */ OP aint ; OP pdrop ; OP pdrop ; LEAVE /* works */ /* ||||||||||||||||||||||||||||||||||====================================== */ name = "?word" ; /* FIND ( tlen ||| --- flag ) (P; beg.tok ||| HNClast --- HNC|null ) I think Size needs to be 1 for comparing tokens to names */ NECK querywordaddy = tdp ; OP sTOr ; /* stash default size */ OP bytes ; /* ?word happens at size = 1 */ addy2 = tdp ; OP fetch ; /* LOOP top (... tlen wlen (P... beg.tok HNClast/cur */ OP nothing ; OP no ; /* (... tlen (P...beg.tok HNClast */ BRANCH + 6 ; /* branch on wlen=yes, */ OP pdrop ; /* wlength = 0 = no = false = aardvark = flag, full search failed */ OP rTOs ; OP bytemask ; OP false ; LEAVE /* (... tlen (P... beg.tok prevHNC */ OP fetch ; /* not done (... tlen wlen (P... beg.tok prevHNC */ OP over ; /* (... len wlen len (P... beg.tok prevHNC */ OP queryequal ; /* lengths equal? (... len flag (P... beg.tok prevHNC */ OP nothing ; OP yes ; /* (... len (P... beg.tok prevHNC */ BRANCH + 14 ; /* branch to next (previous in dictionary) word */ OP pplusc ; /* nccTOstr (... len (P... beg.tok name.str */ CALL /* [( len ||| --- flag) (P; beg.str beg.str ||| --- )] */ CELL stringsequaladdy ; /* (... len flag (P... beg.tok name.str */ OP yes ; /* (... len (P... beg.tok name.str */ BRANCH + 8 ; OP pminusc ; /* FOUND (... len (P... beg.tok HNC */ OP rTOs ; /* go back to default size at dsl we changed sizes at */ OP bytemask ; /* de-junk upsized len */ OP nothing ; OP true ; OP nothing ; LEAVE OP pminusc ; /* from stringsequaladdy (... len (P... beg.tok HNC */ OP TOlink ; /* from queryequal (... len (P... beg.tok link */ OP pfetch ; /* (... len (P... beg.tok HNC */ OP ell ; CELL addy2 ; /* to LOOP with next word's HNC */ /* ||||||||||||||||||||||||||||||||||====================================== */ name = "dotoken" ; /* ( tlen ||| --- #|null flag ) (P; epa bt ||| --- ) */ NECK /* happens at dynsize, hopefully the default flag is "did a H3sm token". This has the right args for hostfn also. */ dotokenaddy = tdp ; OP last ; /* (tlen ||| ) (P; beg.tok ||| HNClast */ CALL /* [(tlen ||| --- flag) (P; beg.tok ||| HNClast --- HNC|null )] */ CELL querywordaddy ; /* (tlen ||| --- ) (P; beg.tok ||| --- HNC|null ) */ OP yes ; BRANCH + 34 ; OP nothing ; /* (tlen ||| --- ) (P; beg.tok ||| --- HNC ) */ /* need to clean stacks here. execute/doHNC has unknown stack effects. */ /* (... tlen (P; beg.tok ||| --- HNC */ CALL CELL tlenaddy ; /* (... tlen (P; beg.tok ||| --- HNC tlen */ OP store ; /* (... (P; beg.tok ||| --- HNC tlen */ OP pdrop ; /* (... (P; beg.tok ||| --- HNC */ OP pTOr ; /* (... (P; beg.tok ||| --- HNC (R... HNC */ OP pdrop ; /* (... (P; beg.tok ||| --- (R... HNC */ CALL CELL beginparseareaaddy ; /* (P... epa beg.tok bpaS (R... HNC */ OP pstore ; /* (P... epa beg.tok bpaS (R... HNC */ OP pdrop ; /* (P... epa beg.tok (R... HNC */ OP pdrop ; /* (P... epa (R... HNC */ CALL CELL endparseareaaddy ; /* (P... epa Sepa (R... HNC */ OP pstore ; /* (P... epa Sepa (R... HNC */ OP pdrop ; /* (P... epa (R... HNC */ OP pdrop ; /* (P... (R... HNC */ OP rTOp ; /* (... (P... HNC (R... */ /* really nasty issues with doHNC's unknown stack effects */ OP doHNC ; /* [(... ??? (P; HNC --- ??? ) (R; --- ??? ) ??? Size] */ CALL CELL endparseareaaddy ; /* (P... Sepa */ OP pfetch ; /* (P... epa */ CALL CELL beginparseareaaddy ; /* (P... epa Sbpa */ OP pfetch ; /* (P... epa bt */ CALL CELL tlenaddy ; /* (P... epa bt Stlen */ OP fetch ; /* (.... tlen (P... epa bt tlen */ OP bytemask ; /* need this if Size changed and there was bump/droppage */ OP pdrop ; /* (.... tlen (P... epa bt */ OP true ; /* (.... tlen ff (P... epa bt */ OP nothing ; LEAVE ; /* (tlen ||| --- ) (P; beg.tok ||| --- (null) ) */ CALL /* not a word [( len ||| --- flag ) (P; beg.tok ||| )] */ CELL querynumberaddy ; OP yes ; /* ( len ||| --- ) (P; beg.tok ||| ) */ BRANCH + 7 ; OP dup ; /* (... len len */ CALL /* [( len --- # ) (P; beg.tok ||| )] */ CELL numberaddy ; /* (... len # ) (P; beg.tok ||| ) */ OP swap ; /* (... # len ) get # in sync with doHNC effects *under* len */ OP true ; /* (... # len ff ) (P; beg.tok ||| ) */ LEAVE OP false ; /* neither # nor word (... len 00 (P; beg.tok ||| ) */ /* pass epa and bt to hostfn? */ LEAVE /* ||||||||||||||||||||||||||||||||||====================================== */ name = "parse" ; /* ( delim --- len ) (P; epa ||| cbpa --- cbpa' ) }parse a delimited substring of pytes{ */ NECK parseaddy = tdp ; /* init */ OP zero ; /* initialize count (... delim 0 (P... epa cbpa */ addy1 = tdp ; OP gap ; /* in parse area? (... delim cnt gap (P... epa cbpa */ OP yes ; /* (... delim cnt (P... epa cbpa */ BRANCH + 17 ; /* no gap, end of parse area, done */ OP over ; /* in p.a. (... delim cnt delim (P... epa cbpa */ OP fetch ; /* next char (... delim cnt delim char (P... epa cbpa */ OP pPLUSs ; /* incr cbpa (... delim cnt delim char (P... epa cbpa' */ OP queryequal ; /* ?delim (... delim cnt flag (P... epa cbpa' */ OP no ; /* (... delim cnt (P... epa cbpa' */ BRANCH + 5 ; /* char = delim */ OP one ; /* is char (... delim cnt 1 (P... epa cbpa' */ OP plus ; /* incr count (... delim cnt' (P... epa cbpa' */ OP ell ; /* next chars */ CELL addy1 ; OP dup ; /* is delim (... delim cnt cnt (P... epa cbpa' */ OP no ; /* ?is any count (... delim cnt (P... epa cbpa' */ BRANCH + 3 ; OP ell ; CELL addy1 ; OP pminusb ; OP swap ; /* on delim, was cnt, token! (... cnt delim (P... epa cbpa' */ OP drop ; /* (... cnt (P... epa cbpa' */ LEAVE /* ||||||||||||||||||||||||||||||||||====================================== */ name = "token" ; /* ( --- len ) (P; epa ||| cbpa --- cbpa' ) */ /* CHARSIZE=1 and space_delimiter wrapper for parse */ NECK tokenaddy = tdp ; OP sTOr ; OP bump ; OP bytes ; /* CHARSIZE assumption. bump and drop wrapper needed. */ OP drop ; OP space ; /* ( --- 32 ) (P... epa cbpa' ) Size =1 */ CALL /* [( delim --- len ) (P; epa ||| cbpa --- cbpa' )] */ CELL parseaddy ; /* (..... lenbyte (P... epa cbpa' */ OP rTOs ; /* (..... lenbyte (P... epa cbpa' )] */ OP bytemask ; /* CHARSIZE ASSUMPTION */ LEAVE /* ||||||||||||||||||||||||||||||||||====================================== */ name = "interpret" ; /* ( --- ) (P; epa bpa --- ) */ NECK interpretaddy = tdp ; OP gap ; /* ( --- bufsize ) (P; epa bpa --- ) */ OP no ; /* ( --- ) (P; epa bpa --- ) */ BRANCH + 4 ; /* ( --- ) (P; epa bpa --- ) */ OP pdrop ; OP pdrop ; /* ( --- ) (P; --- ) */ LEAVE addy1 = tdp ; CALL /* [( --- len ) (P; epa ||| cbpa --- cbpa' )] */ CELL tokenaddy ; /* ( --- len ) (P; epa ||| cbpa' */ OP dup ; /* ( --- len len ) (P; epa ||| cbpa' */ OP no ; /* (... len (P... epa cbpa */ BRANCH + 6 ; OP drop ; OP pdrop ; OP pdrop ; OP ok ; LEAVE /* (... len ) (P... epa cbpa' */ OP dup ; /* is a token (... len len (P... epa cbpa */ OP minusp ; /* (... len (P... epa bt */ CALL /* [(... ??? tlen ||| --- flag ) (P; ??? epa bt |||--- ) (R; ??? )] */ CELL dotokenaddy ; /* (... ??? tlen ||| --- flag ) (P; epa bt |||--- ) */ OP nothing ; OP no ; /* (... len (P... epa bt */ BRANCH + 8 ; OP drop ; /* wasn't a H3sm word or number so try host function */ OP hostfn ; /* (... status (P... epa bt */ OP drop ; OP pdrop ; OP pdrop ; OP ok ; LEAVE /* (... len (P... epa bt */ OP plusp ; /* (... (P... epa cbpa */ OP ell ; CELL addy1 ; /* */ /* ||||||||||||||||||||||||||||||||||====================================== */ name = "H3sm"; /* endless loop, wipes stacks. This is the top loop of H3sm. compare to Forth "ready". */ NECK ip = tdp; /* initialize IP */ /* YEEEEEE HHHAAAAAAAAA!!!!! initial ip. This is where we jump to the "interpreter" via the lone NEXT below. This is the beginning of H3sm interpreter flow control. */ OP nothing ; /* Head execution address, CFA, H3sm square one. */ addy2 = tdp ; /* default Size is 1 */ OP wipesl ; /* tabula rasa */ OP wipefsl ; OP wipepsl ; OP cells ; /* set default Size for interpreter */ scratch = tdp ; CALL CELL tibaddy ; /* (P... bpa */ OP pfetch ; /* */ OP wait ; /* (P... bpa epa */ OP pswap ; /* (P... epa bpa */ /* */ CALL CELL interpretaddy ; OP ell ; CELL scratch ; /* ||||||||||||||||||||||||||||||||||====================================== */ /* last word built at init time */ name = "Last"; /* (P; --- HNC of latest defined word */ latest = (int) &vas.i[tdp]; /* at init/build time we set latest to the countbyte field of last. */ printf("latest %x \n", latest ); NECK OP last ; /* head execution address */ LEAVE /* yyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy */ /* poke first vacant dictionary cell address into dp. */ vas.i[dpaddy +1] = (int)&vas.i[tdp] ; psl = rsl = dsl = 0 ; /* initialize all 3 lubbers (stack pointers) */ NEXT /* Jump to "H3sm" word, which we set ip to, the interpreter. Yow. */ /* zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz */ } /* end of main() */ /* end of H3sm.c */