next up previous contents index
Next: Ans.4th Up: Dreams Previous: Demonstration   Contents   Index



Dreams.4th


(

                                    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



Robert J. Brown
1999-09-26