🚀 go-pugleaf

> I am very much a novice FORTH programmer, and I don't even have a good
> textbook to go by.  I recently purchased a FORTH for my Macintosh at home
> (MACH1, distributed by the Palo Alto Shipping Co.), and would like some
> advice.  Professionally I do a lot of work with LISP, and I would like to
> implement something similar to a `DEFSTRUCT' package in FORTH.  In other
> words, I'd like to be able to do something like:
> 
> 	DEFSTRUCT[ RECTANGLE
> 		   TOP    2
> 		   LEFT   2
> 		   BOTTOM 2
> 		   RIGHT  2 ]ENDSTRUCT
> 
> Which would automatically define the following:
> 
> 	8 CONSTANT RECTANGLE-SIZE
> 	: RECTANGLE-TOP@ ( a - n ) @ ;
> 	: RECTANGLE-TOP! ( n a - ) ! ;
> 	: RECTANGLE-LEFT@ ( a - n ) 2 + @ ;
> 	: RECTANGLE-LEFT! ( n a - ) 2 + ! ;
> 	: RECTANGLE-BOTTOM@ ( a - n ) 4 + @ ;
> 	: RECTANGLE-BOTTOM! ( n a - ) 4 + ! ;
> 	: RECTANGLE-RIGHT@ ( a - n ) 6 + @ ;
> 	: RECTANGLE-RIGHT! ( n a - ) 6 + ! ;
> 	: MAKE-RECTANGLE ( whatever code necessary to allocate 8 bytes
> 			   of variable storage and assign a dictionary
> 			   entry to the word which follows.  This I guess
> 			   would be implementation specific. ) ;
> 
> While I'm sure that this could be done by defining `DEFSTRUCT[' so that it
> constructs all of the necessary dictionary headers etc. at the bit and byte
> level, this would doubtless be complicated and not very portable.  I wonder
> then, if there is a higher level method of defining such a beast?  Any help
> (even "no that can't be done") would be appreciated.
> 
> Bruce Florman	-----------------------------	florman@rand-unix.ARPA

This should do what you want to do.  The idea is to create a screen
on-the-fly that contains the definitions, then just load 'em.

    999 constant (DEFSTRUCT-SCREEN) ( screen scratch area, site-dependant)
    0 variable (DEFSTRUCT-STATE)
    0 variable (DEFSTRUCT-OFFSET)
    0 variable (DEFSTRUCT-BYTES)
    0 variable (DEFSTRUCT-LABEL) 32 allot

    : (DEFSTRUCT-EMIT)  ( c -- )
	(DEFSTRUCT-SCREEN) block (DEFSTRUCT-OFFSET) @ + c! update
	(DEFSTRUCT-OFFSET) @ 1 + 
		dup b/buf > if ." DEFSTRUCT[ output too large" abort endif
	(DEFSTRUCT-OFFSET) !
	;

    : (DEFSTRUCT-TYPE) ( addr -- )
		count 0 do dup c@ (DEFSTRUCT-EMIT) 1 + loop drop ;
	
    : (DEFSTRUCT-LEADIN) ( -- )
	bl (DEFSTRUCT-EMIT)
	" : " (DEFSTRUCT-TYPE)
	(DEFSTRUCT-LABEL) (DEFSTRUCT-TYPE)
        '-' (DEFSTRUCT-EMIT)
        here (DEFSTRUCT-TYPE)
       ;

    : (DEFSTRUCT-PROFFSET) ( -- )
	bl (DEFSTRUCT-EMIT)
	(DEFSTRUCT-OFFSET) @ <# #S #> (DEFSTRUCT-TYPE)
	bl (DEFSTRUCT-EMIT)
	;

    : (DEFSTRUCT) ( -- )
	(DEFSTRUCT-STATE) @
		dup 0 = if
			0 (DEFSTRUCT-OFFSET) !
			0 (DEFSTRUCT-BYTES) !
			here (DEFSTRUCT-LABEL) here c@ cmove
			1 (DEFSTRUCT-STATE) !
		else dup 1 = if
			(DEFSTRUCT-LEADIN)
			" @ "                (DEFSTRUCT-TYPE)
			(DEFSTRUCT-PROFFSET)
			" + @ ; "            (DEFSTRUCT-TYPE)

			(DEFSTRUCT-LEADIN)
			" ! "                (DEFSTRUCT-TYPE)
			(DEFSTRUCT-PROFFSET)
			" + ! ; "            (DEFSTRUCT-TYPE)

			2 (DEFSTRUCT-STATE) !
		else dup 2 = if

			0 0 here number drop (DEFSTRUCT-BYTES) !+

			1 (DEFSTRUCT-STATE) !
		endif endif endif
        drop
     ;

    : (DEFSTRUCT-CLOSEUP)
	(DEFSTRUCT-PROFFSET)
	" constant "            (DEFSTRUCT-TYPE)
	(DEFSTRUCT-LABEL)       (DEFSTRUCT-TYPE)
	" -SIZE "               (DEFSTRUCT-TYPE)

	" : MAKE-"              (DEFSTRUCT-TYPE)
	(DEFSTRUCT-LABEL)       (DEFSTRUCT-TYPE)
	BL                      (DEFSTRUCT-EMIT)
	" <builds "             (DEFSTRUCT-TYPE)
	(DEFSTRUCT-PROFFSET)
	BL                      (DEFSTRUCT-EMIT)
	" allot does> ; "       (DEFSTRUCT-TYPE)
	" ;s "                  (DEFSTRUCT-TYPE)
     ;

    0 variable (strequal-flag)

    : strequal ( s1 s2 -- f )
	1 (strequal-flag) !
	count drop swap count 0 do
		2dup c@ swap c@ = if
			1+ swap 1+ swap
		else
			0 (strequal-flag) ! leave
		endif
	loop 2drop (strequal-flag) @ ;

    : DEFSTRUCT[ 
         0 (DEFSTRUCT-STATE) !
         begin
	    BL WORD
	    HERE " ]ENDSTRUCT" strequal not
         while
            (DEFSTRUCT)
         again
	     (DEFSTRUCT-CLOSEUP) (DEFSTRUCT-SCREEN) load
	    ; immediate

It's based on the fig-forth model, or what I remember of it.

This was pounded into the editor and has not be tested.
Everything except the string literals should be in upper case.
I don't have a reference handy so check the usage of
	'DO' '<#','#S','#>', 'cmove', 'number' etc...
(no expressed or implied warranty, blah, blah ....)

the generated code should look like this (except that it will span
	lines randomly) :


   : RECTANGLE-TOP@ 0 + @ ; : RECTANGLE-TOP! 0 + ! ;
   : RECTANGLE-LEFT@ 2 + @ ; : RECTANGLE-LEFT! 2 + ! ;
   : RECTANGLE-BOTTOM@ 4 + @ ; : RECTANGLE-BOTTOM! 4 + ! ;
   : RECTANGLE-RIGHT@ 6 + @ ; : RECTANGLE-RIGHT! 6 + ! ;
   8 CONSTANT RECTANGLE-SIZE : MAKE-RECTANGLE <BUILDS 8 ALLOT DOES> ; ;S


Hope this will help.  If you use this, please post your improved version
to the net.

For the versions of forth that load from text files, create a tempfile
and input it.

Jeff Bartlett
Center for Digital Systems Research
Research Triangle Institute		mcnc!rti-sel!jb

with generic_disclaimer; use generic_disclaimer;