(
MACRO Support for LMI UR/FORTH
Copyright (c) 1988
Elijah Laboratories Inc.
Written by: R. J. Brown
Elijah Laboratories Inc.
201 West High Street
P. O. Box 833
Warsaw KY 41095
1 606 567-4613
This file defines a words useful for the writing of
defining and compiling words. Especially noteworthy is
the EVAL word that allows processing of one token in the
input stream by the outer interpreter, and then returns
control to the word that invoked EVAL.
)
CONSULT UTIL \ prerequisite modules
( This word is used by the override words for bases and
vocabularies. It takes the address of a variable and a
new value for that variable, and returns the old value
of that variable and its address so that the old value
may be restored with a simple ! operation. )
: XCHG DUP >R @ SWAP R@ ! R> ; ( new addr -- old addr )
( These words will evaluate one word from a text string, and
one word from the input stream. They are useful for
overriding things like the BASE or the VOCABULARY that is
normally in effect, and then restoring it after that one
word has been evaluated. )
: eval FIND CASE ( str -- ; evaluate the word in str )
0 OF NUMBER? 0= ABORT" is undefined! " DROP ( number )
STATE @ IF [COMPILE] LITERAL THEN ENDOF
-1 OF STATE @ IF , ELSE EXECUTE THEN ENDOF ( word )
1 OF EXECUTE ENDOF ENDCASE ; ( immediate word )
: EVAL BL WORD eval ; ( -- ; read and evaluate a word )
( These words allow the current base to be overridden for
the execution/interpretation/compilation of the next word
from the input stream. They restore the original base when
the overridden word is finished executing. )
: base' ( n -- ; causes next word to operate in base n )
BASE XCHG >R >R EVAL R> R> ! ;
( compact forms for the most popular bases... )
: X' 16 base' ; IMMEDIATE ( force hexadecimal )
: D' 10 base' ; IMMEDIATE ( force decimal )
: O' 8 base' ; IMMEDIATE ( force octal )
: B' 2 base' ; IMMEDIATE ( force binary )
( These words work in a fashion analogous to the base
overriding words, only they override the vocabulary instead
of the base, restoring it after the next word has been
executed. )
: v' ( " <vocab>" v' <word > )
CONTEXT @ >R ( save orig vocab )
eval ( execute temp vocab )
EVAL ( read and execute overridden word )
R> CONTEXT ! VOCORDR ; ( restore orig vocab )
: V' BL WORD v' ; IMMEDIATE ( V' <vocab> <word> )
( This special version of CREATE will act the same way CREATE
does unless the name read from the input stream is *not-used*
in which case QREATE will not create a dictionary header and
will exit not only itself, but also the word that called it.
The value returned by *not-used*? is true if QREATE found
the special "*not-used*" token in the input stream. Embeded
comments are handled in the expected way, and not treated
as names to be created. )
VARIABLE ?not-used? ( *not-used* flag, T if not CREATEd )
: *not-used*? ?not-used? @ ; ( predicate is T if no CREATE )
: _qr ( factored helper for QREATE )
R> R> DROP >IN @ >R >R NIL ; ( update >IN for comments )
: QREATE ( -- ; Qreate <name> ... a queer CREATE !!! )
>IN @ >R ( remember place in input stream )
?not-used? NIL! ( assume we will do a CREATE )
BEGIN BL WORD DUP ( read next token )
COUNT " *not-used*" COUNT STRCMP ( special case? )
0= IF R> 2DROP ( yes, clean up stack, )
?not-used? T! 2EXIT THEN ( set flag, & double return )
FIND IF CASE ( allow embedded comments... )
['] ( OF [COMPILE] ( _qr ENDOF ( parenthesis )
['] \ OF [COMPILE] \ _qr ENDOF ( back-slash )
T SWAP ( none of the above... )
ENDCASE ELSE DROP T THEN ( token not found at all )
UNTIL ( keep looking for non-comment tokens )
R> >IN ! ( restore input stream )
CREATE ; ( do a normal CREATE )
( The following words make use of the QREATE word to
implement conditionally generated constants and variables.
These are particularly useful when macro-type words generate
a family of constants or variables, and certain of the
members of these families are not really used. It is nice
to have *not-used* as a place holder for the vacant slots,
without generating unneeded dictionary headers and a host
of 'is re-defined' messages. )
: QONSTANT QREATE , DOES> @ ; ( conditional constant )
: 2QONSTANT QREATE , , DOES> 2@ ; ( double precision const. )
: QVARIABLE QREATE 2 ALLOT DOES> ; ( conditional variable )
\ The Forth version of the indefinate repeat macro.
: IRP[ ( cfa -- \ { words to repeat } IRP[ tkn-1 ... tkn-n ] )
>R \ save cfa
BEGIN \ for the following tokens
>IN @ >R \ save input pointer
BL WORD COUNT \ read the next token
" ]" COUNT STRCMP WHILE \ until we encounter a ']'
R> >IN ! \ back up to token again
R@ EXECUTE \ apply the cfa to the token
REPEAT \ loop till done
R> DROP \ trash saved input pointer
R> DROP \ trash saved cfa
; IMMEDIATE \ this is a read macro word
\ Give names to bit masks in order read.
: BITS[ ( -- \ BITS[ bit0 bit1 bit2 ... bitn ] )
1 \ mask for first bit
{ DUP QONSTANT 2* } \ do this
[COMPILE] IRP[ \ for each bit name
DROP ; \ trash leftover mask
\ Give indices to symbols, starting with ival & returning oval.
: ENUM[ ( -- \ ival ENUM[ tag1 tag2 ... tagn ] -- oval )
{ DUP QONSTANT 1+ } \ do this
[COMPILE] IRP[ ; \ for each tag
\ A block compile word.
: COMPILE[ ( -- \ COMPILE[ word1 ... wordn ] )
{ \ for each token
COMPILE COMPILE \ compile the value of
EVAL \ its evaluation
} \ this is the action to repeat
[COMPILE] IRP[ \ until a ']' is encountered
; IMMEDIATE \ this is a read macro word
( This word is a macro to declare several VARIABLEs at a time.
It is used as follows: VARS[ var1 var2 ... varn ] )
: VARS[ \ multiple variable declaration
['] VARIABLE \ perform VARIABLE
[COMPILE] IRP[ ; \ for each token in the list
( This word is a macro to declare a list of tokens to be
forward references. These words must later be resolved with
the R: word. !!! LMI UR/FORTH Only !!! )
: FWD[ \ declare many forward references
['] F: \ perform F:
[COMPILE] IRP[ ; \ for each token in the list
( These words are used to create a "stub" word that just
displays its name when it is executed. These words are useful
when doing a top-down implementation with testing before all
words are coded. )
VARIABLE here \ variable needed to thwart compiler security
: STUB HERE here ! : \ stub off a word
here @ BODY> >NAME [COMPILE] LITERAL \ make nfa literal
COMPILE CR COMPILE .NAME [COMPILE] ; ; \ code to show name
: STUB[ ['] STUB [COMPILE] IRP[ ; \ stub a list of words
( This word consults a list of files )
: CONSULT[ ( -- \ CONSULT[ f1 ... fn ] ; consult listed files )
['] CONSULT [COMPILE] IRP[ ;