next up previous contents index
Next: Stacks.4th Up: Dreams Previous: Edo.4th   Contents   Index



Macros.4th


(

                  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[ ;



Robert J. Brown
1999-09-26