collinge@uvicctr.UUCP (Doug Collinge) (05/21/85)
: This is a shar archive. Extract with sh, not csh.
echo x - letter
cat > letter << '!Funky!Stuff!'
Some people on net.lang.forth were excited by a feature of NEON that
seemed old hat to me. This sharchive contains code that will run on
6502 FIGForth (and maybe others) that gives the parameter mechanism
of NEON. The runtime stuff is written in 6502 for speed but you
could recode it in anything else if you could only understand it...
It sure makes writing and reading Forth a lot easier. In NEON you
say:
: HUMPTY { A B C / D E } ... ;
In PROC you say:
PROC DUMPTY P( A B C ) L( D E ) ... ;
The small runtime overhead is generally less than the overhead incurred
when using the Forth stack manipulation words like DUP and OVER.
This code was written by Doug Collinge and David Harris about three
years ago and has been in light, trouble-free use since then. No
known problems but drop me a line if anything should show up...
If you manage to make this work please send me mail about it - in
fact send me mail anyway.
Feel free to do anything you like with this code. If you
make some money with it be sure to give us a kickback.
Doug Collinge
School of Music, University of Victoria,
PO Box 1700, Victoria, B.C.,
Canada, V8W 2Y2
decvax!nrl-css!uvicctr!collinge
decvax!uw-beaver!uvicctr!collinge
ubc-vision!uvicctr!collinge
!Funky!Stuff!
echo x - procdoc
cat > procdoc << '!Funky!Stuff!'
Here is the documentation for CASES and PROC, such as it is.
CASES:
CASES is a pretty standard case construct. Use as follows:
x CASES ( Takes x off the stack and selects a case )
n CASE ( This Forth code is evaluated iff x=n ) ESAC
( This Forth code is evaluated iff x ^= n )
n CASE ( This Forth code can never be evaluated )
m CASE ( This Forth code is evaluated iff x=m ) ESAC
( This Forth code is evaluated iff no cases were selected )
SESAC
( This Forth code is evaluated after any selected case or )
( if no cases were selected )
Where: x, n, m are Forth code that evaluates to a single value
on the stack. "R" may be used anywhere between CASES and SESAC
to get the value of x, which is stored on the return stack.
Some words in CASES have been coded in 6502 for speed. They may
easily be replaced with their Forth equivalents.
PROCS:
PROCS is a wordset that gives parameters and local variables to
Forth definitions. Use as follows:
PROC BILLY-BOB P( A B ) L( C D )
A B + C ! A B - D !
C @ D @ *
RETURN
5 3 BILLY-BOB .
16 OK
This definition expects two numbers on the stack and stacks the
product of their sum and difference. The words within P( ) define
constants which can be used within the definition to refer to the items
on the stack at the time the definition is evaluated. The order in
which they appear is the order of the items on the stack with the last
word referring to the topmost (most accessible) item. In the example,
"A" refers to 5 and "B" refers to 3.
The words within L( ) are defined as local variables which can
be stored into or fetched from. These are not true variables - "!" or
"@" MUST follow the variable name and are decoded at compile time.
This is to prevent addressing the stack and speeds things up a bit. In
the example "C" and"D" refer to local variables.
Anything left on the stack when RETURN is encountered is what
is returned by the definition. In the example "C @ D @ *" leaves 16 on
the stack and 16 is returned by "BILLY-BOB".
Either or both of P( ) and L( ) may be omitted. If both are
omitted the definition is equivalent to a colon definition. A small
fixed overhead is incurred when entering and leaving a PROC
definition. This overhead is usually less than the overhead involved
in normal Forth stack manipulation using "SWAP", "DUP", "ROT", etc.
The resulting code is far easier to write and read.
UNDER THE HOOD:
The code is pretty gory. It will be incomprehensible to
anyone but Forth gurus.
"PROC" compiles a normal header with a CFA determined by
whether L( ) is present. The CFA is left blank and is later filled in
by RETURN. The CFA code makes use of a pointer called the stack frame
"SF", which is pushed on the return stack on entry. SF is then set to
the value of the stack pointer, "SP". If L( ) is present the CFA code
adjusts the SP to make enough room for the local variables. The number
of bytes to reserve is given in a postbyte of the CFA.
"P(" reads words out of the input and generates immediate words
into the dictionary. These words compile a reference to code that
makes reference into the stack relative to SF and independent of SP.
There are several runtime words predefined so that a reference to the
top four items on the stack takes only two bytes. If there are more
than four parameters on the stack it takes three bytes: two for the
reference and a byte giving the offset from SF.
"L(" is similar to "P(" but generates immediate words that look
in the input for "!" or "@". When one of these words is executed at
compile time is looks at the next word. If it is "!" it compiles a
reference to runtime code that stores the top of the stack to the stack
relative to SF. If it sees "@" it compiles a reference to code that
fetches from the stack relative to SF.
The immediate words compiled into the dictionary by P( and L(
do not take up space after the definition is closed. They are
compressed out by RETURN. RETURN also determines which CFA code to use
and plugs in the correct reference. It compiles a reference to code
which moves the items above the SF down to below the first parameter,
thus eliminating all parameters and local variable space on the stack.
It then unstacks the previous stack frame and stores it in SF.
!Funky!Stuff!
echo x - procs
cat > procs << '!Funky!Stuff!'
( DJC CASES ) HEX ASSEMBLER
CODE R=IF ( BRANCHES IF R = STACK )
XSAVE STX, TSX, TXA, TAY, XSAVE LDX, INX, INX,
101 ,Y LDA, BOT 2 - CMP,
0= NOT IF, 0 # LDY, ' BRANCH JMP, ENDIF,
102 ,Y LDA, BOT 1 - CMP,
0= NOT IF, 0 # LDY, ' BRANCH JMP, ENDIF,
' 0BRANCH 8 + JMP,
CODE RDROP PLA, PLA, NEXT JMP, ( DROP A WORD FROM R STACK)
( ..DJC CASES ) FORTH DECIMAL
: CASES 5 COMPILE >R 0 ; IMMEDIATE
: CASE COMPILE R=IF HERE 0 , 2 ; IMMEDIATE
: ESAC COMPILE BRANCH ROT , [COMPILE] ENDIF HERE 2 - ;
IMMEDIATE
: SESAC ?COMP BEGIN DUP WHILE
DUP @ SWAP HERE OVER - SWAP ! REPEAT DROP
5 ?PAIRS COMPILE RDROP ; IMMEDIATE
;S
( DJC PROC: NLOCALS,NPARMS,PROC ) HEX
00FC CONSTANT SF ( STACK FRAME POINTER)
0 VARIABLE NLOCALS ( NUMBER OF LOCAL VARIABLES)
0 VARIABLE NPARMS ( NUMBER OF PARMS DEFINED )
: DUMMY ; ' DUMMY CFA @ FORGET DUMMY CONSTANT DOCOL
: PROC ( HEADER FOR THIS KIND OF DEFINITION)
?EXEC !CSP CURRENT @ CONTEXT !
0 NPARMS ! 0 NLOCALS ! ( INIT COUNTS )
HERE ( SAVE PROC'S NFA TO RESET LATEST IN RETURN)
CREATE -2 ALLOT DOCOL , HERE HERE ( PFA ADDR , CODE START )
] ( ENTER COMPILE MODE)
; IMMEDIATE
( DJC PROC: PROLOGUES ) ASSEMBLER
: INC16, ( MACRO TO INCREMENT 16 BITS WORD BY 1 )
>R R ASSEMBLER INC, 0= IF, R> 1+ INC, ENDIF, ;
CODE (PROC) ( FOR PROCS WITHOUT LOCALS )
SF LDA, PHA, ( PUSH STACK FRAME )
SF STX, SF 1+ STY, ( ESABLISH STACK FRAME )
DOCOL JMP, ( GOTO REGULAR PROLOGUE )
CODE (PROCL) ( FOR PROCS WITH LOCALS; INLINE LOCS SIZE BYTE )
SF LDA, PHA, SF 1+ STY, ( PUSH STACK FRAME & ZERO HI OF SF )
SEC, TXA, 2 # LDY, W )Y SBC, TAX, ( MAKE SPACE FOR LOCALS )
SF STX, ( ESTABLISH STACK FRAME )
W INC16, 0 # LDY, DOCOL JMP, ( GET PAST INLINE BYTE )
( DJC PROC: <PN> ) HEX ASSEMBLER
0 VARIABLE (PN@)S 8 ALLOT ( VECTOR TO SAVE ADDRS OF <PN@>'S )
CODE (PN@) ( RUNTIME VERB TO LOAD RELATIVE TO SF)
IP )Y LDA, IP INC16, TAY,
HERE (PN@)S ! ( FIRST ONE HAS Y ALREADY 0 )
DEX, DEX, ( MAKE ROOM ON STACK )
SF )Y LDA, BOT STA, INY, SF )Y LDA, BOT 1+ STA, NEXT JMP,
( TO SAVE TIME AND SPACE SOME PARM RUNTIMES ARE BUILT IN )
HERE (PN@)S 2 + ! 2 # LDY, (PN@)S @ JMP,
HERE (PN@)S 4 + ! 4 # LDY, (PN@)S @ JMP,
HERE (PN@)S 6 + ! 6 # LDY, (PN@)S @ JMP,
HERE (PN@)S 8 + ! 8 # LDY, (PN@)S @ JMP,
( DJC PROC: PARMN ) FORTH DECIMAL
: PARMN ( CALLED AT COMPILE TIME TO COMPILE RUN VERB)
NLOCALS @ NPARMS @ + SWAP - DUP +
DUP 8 > 0=
IF (PN@)S + ,
ELSE COMPILE (PN@) C, ENDIF
;
( DJC PROC: <PN!> ) HEX ASSEMBLER
0 VARIABLE (PN!)S 8 ALLOT ( VECTOR TO SAVE ADDRS OF <PN!>'S )
CODE (PN!) ( RUNTIME VERB TO STORE RELATIVE TO SF)
IP )Y LDA, IP INC16, TAY,
HERE (PN!)S ! ( FIRST ONE HAS Y ALREADY 0 )
BOT LDA, SF )Y STA,
BOT 1+ LDA, INY, SF )Y STA, INX, INX, NEXT JMP,
( TO SAVE TIME AND SPACE SOME PARM RUNTIMES ARE BUILT IN )
HERE (PN!)S 2 + ! 2 # LDY, (PN!)S @ JMP,
HERE (PN!)S 4 + ! 4 # LDY, (PN!)S @ JMP,
HERE (PN!)S 6 + ! 6 # LDY, (PN!)S @ JMP,
HERE (PN!)S 8 + ! 8 # LDY, (PN!)S @ JMP,
( DJC PROC: LOCALN ) FORTH HEX
: LOCERR ." @ OR ! AFTER LOCAL!" QUIT ;
: LOCALN ( CALLED AT COMPILE TIME TO COMPILE RUN VERB)
NLOCALS @ SWAP - DUP +
BL WORD HERE C@ 1 = 0= IF LOCERR ENDIF
HERE 1+ C@ CASES
40 ( @ ) CASE DUP 8 > 0= IF (PN@)S + ,
ELSE COMPILE (PN@)S C, ENDIF ESAC
21 ( ! ) CASE DUP 8 > 0= IF (PN!)S + ,
ELSE COMPILE (PN!)S C, ENDIF ESAC
LOCERR SESAC ;
( DJC PROC: P( ) FORTH HEX
: P( ( CREATE A SEQUENCE OF PARM VERBS )
BEGIN CREATE LATEST C@ 1F AND 1 = ( CHECK FOR ONE CHAR )
LATEST 1+ C@ 7F AND 29 = AND 0= WHILE ( STOP IF CLS PAREN)
-2 ALLOT DOCOL , ( MAKE A COLON DEF)
COMPILE LIT NPARMS @ 1+ DUP NPARMS ! , ( MAKE PARM# AVAIL)
COMPILE PARMN COMPILE ;S SMUDGE IMMEDIATE ( COMP IN PARMN)
REPEAT LATEST DP ! LATEST PFA LFA @ CURRENT @ ! ( FORGET CLS)
DROP HERE ( REMEMBER START OF PROC BODY FOR RETURN)
; IMMEDIATE
( DJC PROC: L( ) FORTH HEX
: L( ( CREATE A SEQUENCE OF LOCAL VERBS )
BEGIN CREATE LATEST 1+ C@ A9 = 0= WHILE ( STOP IF CLS PAREN)
-2 ALLOT DOCOL , ( MAKE A COLON DEF)
COMPILE LIT NLOCALS @ 1+ DUP NLOCALS ! , ( MAKE LOCAL# AVAIL)
COMPILE LOCALN COMPILE ;S SMUDGE IMMEDIATE ( COMP IN PARMN)
REPEAT LATEST DP ! LATEST PFA LFA @ CURRENT @ ! ( FORGET CLS)
DROP HERE ( REMEMBER START OF PROC BODY FOR RETURN)
; IMMEDIATE
( DJC PROC:RETURNS) HEX ASSEMBLER
CODE (RETRN) ( PUSH WHAT REMAINS ON STACK BELOW PARMS)
XSAVE STX, IP )Y LDA, CLC, SF ADC, TAX, SF LDY, ( FIND WHERE)
BEGIN, DEY, XSAVE CPY, CS WHILE, ( MOVE BYTES)
DEX, 0 ,Y LDA, 0 ,X STA,
CS NOT ENDREP, ( FORCED BRANCH)
PLA, IP STA, PLA, IP 1+ STA, ( CODE FOR ; )
PLA, SF STA, NEXT JMP, ( RESTORE STACK FRAME & CONTINUE)
( DJC PROC: RETURN ) DECIMAL FORTH
: RETURN ( EXPECTS PFA OF PROC, ADDR OF CODE BODY )
( PLUG IN PROPER PROLOGUE INTO PROC'S CFA )
OVER CFA ( GET CFA OF PROC )
NLOCALS @
IF ( THERE ARE LOCALS THEN USE PROCL )
' (PROCL) SWAP ! ( PLUG IN NEW CFA )
SWAP DUP NLOCALS @ DUP + SWAP C! 1+ SWAP ( INLINE FOR PROCL)
ELSE ( NO LOCALS )
NPARMS @
IF ( PARMS: USE PROC )
' (PROC) SWAP !
ELSE ( NO LOCS, NO PARMS: USE : )
DOCOL SWAP !
ENDIF
ENDIF
( DJC PROC: RETURN ) DECIMAL FORTH
( GENERATES PROPER EPILOGUE AND RELOCATES PROC'S BODY )
NLOCALS @ NPARMS @ + -DUP 0=
IF ( NO PARMS, NO LOCALS: USE ;S )
DROP DROP COMPILE ;S
ELSE ( MUST USE RETURN AND SQUISH UP BODY OF CODE )
COMPILE (RETRN) DUP + C, ( INLINE IS BYTES TO DEALLOCATE )
OVER OVER SWAP OVER HERE SWAP - CMOVE ( SQUISH UP CODE )
- ALLOT ( FIX UP DICT POINTER )
CURRENT @ ! ( SAVE AS LATEST )
ENDIF
[COMPILE] [ ( GET OUT OF COMPILE MODE )
SMUDGE ; IMMEDIATE
;S
( DJC PROC: EXAMPLE ) FORTH DECIMAL
PROC BOB P( A B ) ( TAKES PARMS A & B ON STACK )
A . ." + " B . ." = " A B + . CR
RETURN ( NOTHING'S ON STACK SO RETURN NOTHING )
( JUST TRY TO DO THE FOLLOWING WITHOUT PROC! )
PROC TIM P( A B ) L( X Y ) ( LOCAL VARIABLES X & Y )
A B + X ! A B - Y ! ( STORE TO LOCALS )
X @ Y @ * ( FETCH FROM LOCALS )
RETURN ( RETURN WHAT'S ON STACK )
;S LOCAL VARIABLES ARE SPECIAL. THEY ARE NOT REGULAR VARIABLES.
LOC VARS MUST BE FOLLOWED IMMEDIATLY BY EITHER @ OR !. THEY ARE
STORED ON THE STACK AND DISAPPEAR WHEN THE PROC HAS FINISHED.
!Funky!Stuff!
exit 0
--
Doug Collinge
School of Music, University of Victoria,
PO Box 1700, Victoria, B.C.,
Canada, V8W 2Y2
decvax!nrl-css!uvicctr!collinge
decvax!uw-beaver!uvicctr!collinge
ubc-vision!uvicctr!collinge