(
DREAMS
An Object Oriented System
For LMI UR/Forth 1.03
Written By: R. J. Brown
Copyright 1989 Elijah Laboratories Inc.
All Rights Reserved Worldwide
This code may be freely copied and
distributed under the terms of the
Gnu Public License. [See gnu.txt]
"...and the dream is certain, and
the interpretation thereof sure."
Daniel 2:45
The dreams system arose out of an experimental port of a Flavors
and a dynamic closures package from Lisp to Forth.
)
\ State which prerequisite source files must be present.
CONSULT ANS \ X3/J14 BASIS6 compatibility for LMI UR/Forth.
CONSULT MACROS \ Eli Lab's macro defining words.
CONSULT EDO \ George Hawkins' structured data types.
CONSULT STACKS \ Stack defining and manipulating words.
\ Define the stacks to hold old bindings and active closures.
100 Stack ABStk \ active bindings during dreams
25 Stack AEStk \ active essences during dreams
25 Stack UEStk \ unbound essences during regressions
10 Stack AVStk \ active visions stack
\ Define data types used in the structure of an essence of a dream.
cell DEF pointer \ an address of something else
\ Define the data structure for a dream's essence.
S{ cell :: dream-size \ the size of this dream
cell :: #-of-bindings \ the number of local objects
\
\ a dream has one of these slots for each local binding
\
S{ pointer :: pfa-pointer \ points at a pfa we are closed over
pointer :: pfa-contents \ our local value for that pfa
cell :: local-type }S \ the type of this local
\
DUP DEF local-binding \ the type of a slot
[*] local-binding[] \ the slot index operator
\
:: local-bindings \ the name the vector of slots
\
}S local-binding - DEF dream-header \ this is called a dream-header
( There is one slot in the local-bindings vector for each locally bound
object. Following this, a region of dictionary is ALLOTed to hold the BODYs
of each of the locally bound objects. An ALLOTment is made for each object
equal to the size of that object, which is also the object's type. Reference
type bindings have a size of zero. )
\ LMI UR/Forth memory model dependent words.
: ^pfa ( cfa -- ^pfa ) BYTE+ ; \ Convert a cfa to a ptr to the pfa.
: pfa@ ( ^pfa -- pfa ) CS0 SWAP @L ; \ Fetch a pfa from the code segment.
: pfa! ( pfa ^pfa -- ) CS0 SWAP !L ; \ Store a pfa into the code segment.
\ Instantiate the essence of a dream and return a pointer to it on the stack.
: Make-Essence ( NIL size-n cfa-n ... size-1 cfa-1 -- ^essence )
HERE >R \ save pointer to instantiation
dream-header ALLOT \ allocate the header
BEGIN ?DUP WHILE \ for each locally bound object...
HERE >R \ remember start of slot
local-binding ALLOT \ allocate a local binding slot
^pfa R@ pfa-pointer ! \ store pointer to pfa
R> local-type ! REPEAT \ store the object's length
HERE R@ local-bindings - \ compute size of local binding vector
local-binding / \ compute number of local bindings
R@ #-of-bindings ! \ save it for dynamic binding routines
HERE \ point to start of local data area
R@ local-bindings \ point to the local-bindings vector
?DO HERE I pfa-contents ! \ set pointer to local data slot
I local-type @ ALLOT \ reserve space for it
I pfa-pointer @ pfa@ \ point to original data
I pfa-contents @ \ point to new data slot
I local-type @ MOVE \ get length & copy data to new slot
I local-type @ 0= \ is it a reference binding?
IF I pfa-pointer @ pfa@ \ yes, inherit old pfa
I pfa-contents ! THEN \ instead of copy of data
local-binding +LOOP \ repeat for each local object
HERE R@ - \ compute overall size of this essence
R@ dream-size ! \ store for future RELAPSE calls
R> ; \ return pointer to this essence
\ Copy an essence to produce a new essence with the same initial bindings.
: Copy-Essence ( ^old-essence -- ^new-essence )
HERE \ destination address
2DUP OVER dream-size @ \ length to copy
DUP ALLOT \ allocate space
MOVE \ make the copy
SWAP OVER - \ compute ptr adjustment
OVER #-of-bindings @ 0 \ for each local binding
?DO OVER local-bindings \ point to...
I SWAP local-binding[] \ ...its slot
DUP local-type @ \ locally instantiated?
IF pfa-contents DUP @ \ yes, get old binding
2 PICK - SWAP ! \ adjust to new binding
ELSE DROP THEN LOOP DROP ; \ loop till done
\ Establish new bindings for local objects.
: new-bindings ( ^essence -- )
DUP AEStk Push \ stack dream occurrence
DUP local-bindings SWAP \ point to bindings vector
#-of-bindings @ 0 \ for each local binding
?DO I OVER local-binding[] \ point to its slot
DUP pfa-pointer @ \ point to its pfa
DUP pfa@ ABStk Push \ save old binding
SWAP pfa-contents @ \ get new binding
SWAP pfa! \ establish new binding
LOOP DROP ; \ clean up & exit
\ Re-establish stacked old bindings for local objects.
: old-bindings ( -- )
AEStk Pop \ point to most recent dream
DUP local-bindings SWAP \ point to bindings vector
#-of-bindings @ ?DUP 0= \ are there any bindings?
IF DROP EXIT THEN \ no, do nothing and exit
1- 0 SWAP \ yes, for each local binding
DO I OVER local-binding[] \ point at its slot
pfa-pointer @ \ point at pfa
ABStk Pop \ get stacked old binding
SWAP pfa! \ restore old binding
-1 +LOOP DROP ; \ clean up & exit
\ Cause a dream to ponder a thought.
: PONDER ( guzintas... thought-cfa ^essence -- guzoutas... )
new-bindings \ bind to local objects
EXECUTE \ do your thing!
old-bindings ; \ unbind from local objects
\ Declarations of lists of objects local to a dream.
: VAR[ { cell ' } [COMPILE] IRP[ ; \ declare variables
: 2VAR[ { 2 CELLS ' } [COMPILE] IRP[ ; \ declare 2variables
: REF[ { NIL ' } [COMPILE] IRP[ ; \ declare reference bindings
\ Defining word for a dream.
: DREAM ( NIL size-n cfa-n ... size-1 cfa-1 -- ) \ name \
Make-Essence CREATE , \ give it a name
DOES> @ PONDER ; \ and a behavior
\ A dream about nothing provides a way to ponder thoughts in the here and now.
NIL DREAM STUPOR \ ponders thoughts in the current understanding
\ Transform a dream's name to its essence, or data structure address.
: ESSENCE ' >BODY @ STATE @ IF [COMPILE] LITERAL THEN ; IMMEDIATE
\ Defining word for a copy of a dream.
: RELAPSE ( ^essence -- ) \ new-dream \
\ Syntax: ESSENCE old-dream RELAPSE new-dream
Copy-Essence CREATE , DOES> @ PONDER ;
\ Defining word for a class of dreams.
: TRANCE ( NIL size-n cfa-n ... size-1 cfa-1 -- ) \ name \
Make-Essence CREATE , \ make the prototype
DOES> @ RELAPSE ; \ replicate the prototype
\ Reference to the essence of the current dream.
: MILIEU ( -- ^essence )
AEStk Empty? \ is there currently any active dream?
IF ESSENCE STUPOR ELSE \ no, return empty dream's essence
AEStk Top THEN ; \ yes, return current dream's essence
\ Defining word for a named thought.
: THOUGHT CONSTANT ; \ Syntax: { blah blah blah } THOUGHT name
\ Find a word's local-binding slot in an essence.
: Find-Binding ( pfa ^essence -- ^slot )
DUP local-bindings >R \ save pointer to vector
#-of-bindings @ ?DUP 0= \ is number of slots zero?
IF R> 2DROP NIL EXIT THEN \ yes, give up search!
BEGIN DUP 1- R@ local-binding[] \ no, point to slot
DUP pfa-pointer @ 3 PICK = \ is this right slot?
IF -ROT 2DROP R> DROP EXIT \ yes, return its pointer!
ELSE DROP THEN \ no, keep looking
1- ?DUP 0= UNTIL \ update index
DROP NIL ; \ search failed, return NIL!
\ Alter the understanding of an object local to a dream.
: IMAGINE ( new-cfa old-cfa ^essence -- )
SWAP ^pfa SWAP \ point to old pfa pointer
Find-Binding ?DUP \ find its binding in the essence
IF DUP local-type @ \ make sure its a reference binding
IF DROP EXIT THEN \ if not reference, don't bind it
SWAP ^pfa pfa@ SWAP \ point to new pfa
pfa-contents ! \ replace old pfa with new pfa
ELSE DROP THEN ; \ if not found, do nothing
\ Regress back to an earlier dream state.
: REGRESS ( guzintas... thought -- guzoutas... )
AEStk Empty? \ are we already in reality?
IF EXECUTE \ yes, can't regress further
ELSE AEStk Top UEStk Push \ no, remember where we are
old-bindings \ go back a level
EXECUTE \ ponder the thought there
UEStk Pop new-bindings THEN ; \ return to where we came from
\ Regress all the way back to Reality.
: REALITY ( guzintas... thought -- guzoutas... )
BEGIN AEStk Empty? NOT WHILE \ till there's no bindings left
AEStk Top UEStk Push \ remember what we undid
old-bindings REPEAT \ un-do a binding
EXECUTE \ think the thought
BEGIN UEStk Empty? NOT WHILE \ till they're all re-bound
UEStk Pop \ get a binding
new-bindings REPEAT ; \ re-bind it.
\ Early binding support: compile time pfa value.
: REALLY ( -- pfa ) \ name \
' >BODY [COMPILE] LITERAL ; IMMEDIATE \ pfa of name in reality
\ Execute early bound colon definition.
: DID ( pfa -- ) \ syntax: REALLY word DID \
R> DROP >R ; \ execute body and return
\ Build data structure for a vision, which is a set of dreams.
: make-vision ( NIL ^essence-1 ... ^essence-n -- ^vision )
HERE >R \ remember where vision starts
NIL , \ backwards terminator
BEGIN ?DUP WHILE \ for each dream in the vision
, REPEAT \ remember its essence
NIL , \ forward terminator
R> ; \ return pointer to vision
\ Establish the understanding of a vision.
: bind-vision ( ^vision -- )
DUP @ IF DUP new-bindings \ handle atomic dream case
ELSE BEGIN CELL+ DUP @ ?DUP WHILE \ for all dreams in vision
DUP @ IF new-bindings \ handle dream in this slot
ELSE RECURSE THEN \ handle nested vision
REPEAT THEN AVStk Push ; \ remember tail for unbinding
\ Disestablish the understanding of a vision.
: unbind-vision ( -- )
AVStk Pop \ point to the vision's tail
DUP @ IF old-bindings \ handle atomic dream case
ELSE BEGIN CELL- DUP @ WHILE \ for all dreams in vision
DUP @ @ IF old-bindings \ handle dream in this slot
ELSE RECURSE THEN \ handle nested vision
REPEAT THEN DROP ; \ clean up before exit
\ See a thought in a vision.
: SEE ( guzintas... thought ^vision -- guzoutas... )
bind-vision \ establish the understanding of the vision
EXECUTE \ ponder the thought therein
unbind-vision ; \ remove the understanding of the vision
\ Defining word for a vision, arguments are on the stack.
: VISION ( NIL ^essence-1 ... ^essence-n -- )
make-vision CREATE ,
DOES> @ SEE ;
\ A vision about nothing makes a useful place-holder in another vision.
NIL VISION COMA \ analogous to STUPOR, the dream about nothing
( Note that the essence of a vision may be extracted just like the essence
of a dream. The use of the word ESSENCE is exactly the same in both cases. )
\ Defining word for a vision, arguments are names in the source stream.
: VISION[ ( -- ) \ Syntax: VISION[ dream-1 ... dream-n ] name
NIL ['] ESSENCE [COMPILE] IRP[ VISION ;
\ words to permit early binding to the understanding of another dream.
: EARLY ( word-cfa ^essence -- word-pfa )
['] >BODY SWAP PONDER ;
: [EARLY] ( -- ) \ word-name dream-name \
' [COMPILE] ESSENCE EARLY [LITERAL] ; IMMEDIATE
\ Words to plant before and after demons into other words.
: BEFORE ( before-cfa method-cfa ^essence -- )
2DUP EARLY \ get old method
HERE >R SWAP >R \ save cfa & essence ptr
ROT , [LITERAL] COMPILE DID COMPILE EXIT \ compile new method
R> R> -ROT IMAGINE ; \ replace old method with it
: AFTER ( after-cfa method-cfa ^essence -- )
2DUP EARLY \ get old method
HERE >R SWAP >R \ save cfa & essence ptr
ROT SWAP [LITERAL] COMPILE DID , COMPILE EXIT \ compile new method
R> R> SWAP IMAGINE ; \ replace old method