Fixed lots of bugs and made it so SHRDLU and PLNR can be compiled.

Now, we build SHRDLU;TS SHRDLU and SHRDLU;TS PLNR from compiled
lisp code.  This should allow it to run faster and have fewer issues
with garbage collection and running out of LIST space.

Found lots of bugs going through the compilation effort.  Also fixed
several issues that were resulting in weird/incorrect responses to
standard demo prompts.

Below is a list of prompts that I have tested:

pick up a big red block.
grasp the pyramid
find a block that is taller than the one you are holding and put it into the box.
what does the box contain?
what is the pyramid supported by?
how many blocks are not in the box?
is the red cube supported?
can the table pick up blocks?
can a pyramid be supported by a block?
can a pyramid support a pyramid?
stack up two pyramids.
stack up two red blocks.
put the green pyramid on the red cube.
which cube is sitting on the table?
is there a large block behind a pyramid?
put a small one onto the green cube that supports a pyramid.
put the littlest pyramid on top of it.
does the red cube support anything?
what color is the block that supports the green pyramid?
how many things are on top of green cubes?
had you touched any pyramid before you put the green pyramid on the little cube?
when did you pick it up?
why did you pick it up?
why did you clear off that cube?
how did you clean off the red cube?
how many objects did you touch while you were doing it?
put the blue pyramid on the block in the box.
is there anything which is bigger than every pyramid but is not as wide as the thing that supports it?
thank you.

Of course, lots more things are possible.

It is still best to do this without answering "Y" to the Type 340 display prompt at the
start.  There is either an issue with the GRAPHF module or the SLAVE module (or perhaps
with the Type 340 simulator) that is causing crashes after several successful commands
with graphic output.

build/shrdlu.tcl

@@ -2,25 +2,117 @@ log_progress "ENTERING BUILD SCRIPT: SHRDLU"
 
 respond "*" ":cwd shrdlu\r"
 
+# first, compile all the sources that should be compiled
+
 respond "*" ":complr\r"
 respond "_" "shrdlu; graphf\r"
 respond "_" "\032"
 type ":kill\r"
 
+respond "*" ":complr\r"
+respond "_" "shrdlu; macros\r"
+respond "_" "\032"
+type ":kill\r"
+
+respond "*" ":complr\r"
+respond "_" "shrdlu; proggo\r"
+respond "_" "\032"
+type ":kill\r"
+
+respond "*" ":complr\r"
+respond "_" "shrdlu; plnr\r"
+respond "_" "\032"
+type ":kill\r"
+
+respond "*" ":complr\r"
+respond "_" "shrdlu; thtrac\r"
+respond "_" "\032"
+type ":kill\r"
+
+respond "*" ":complr\r"
+respond "_" "shrdlu; syscom\r"
+respond "_" "\032"
+type ":kill\r"
+
+respond "*" ":complr\r"
+respond "_" "shrdlu; morpho\r"
+respond "_" "\032"
+type ":kill\r"
+
+respond "*" ":complr\r"
+respond "_" "shrdlu; show\r"
+respond "_" "\032"
+type ":kill\r"
+
+respond "*" ":complr\r"
+respond "_" "shrdlu; progmr\r"
+respond "_" "\032"
+type ":kill\r"
+
+respond "*" ":complr\r"
+respond "_" "shrdlu; ginter\r"
+respond "_" "\032"
+type ":kill\r"
+
+respond "*" ":complr\r"
+respond "_" "shrdlu; gramar\r"
+respond "_" "\032"
+type ":kill\r"
+
+respond "*" ":complr\r"
+respond "_" "shrdlu; dictio\r"
+respond "_" "\032"
+type ":kill\r"
+
+respond "*" ":complr\r"
+respond "_" "shrdlu; smspec\r"
+respond "_" "\032"
+type ":kill\r"
+
+respond "*" ":complr\r"
+respond "_" "shrdlu; smass\r"
+respond "_" "\032"
+type ":kill\r"
+
+respond "*" ":complr\r"
+respond "_" "shrdlu; smutil\r"
+respond "_" "\032"
+type ":kill\r"
+
+respond "*" ":complr\r"
+respond "_" "shrdlu; newans\r"
+respond "_" "\032"
+type ":kill\r"
+
+respond "*" ":complr\r"
+respond "_" "shrdlu; blockp\r"
+respond "_" "\032"
+type ":kill\r"
+
+respond "*" ":complr\r"
+respond "_" "shrdlu; blockl\r"
+respond "_" "\032"
+type ":kill\r"
+
+# now load up a compiled version of SHRDLU
 respond "*" ":lisp\r"
 respond "Alloc?" "n"
 respond "*" "(load 'loader)"
-respond "T" "(loadshrdlu)"
-respond "|CONSTRUCTION COMPLETED|" "(dump-it)"
+respond "T" "(shrdlu-compiled)"
+respond "COMPLETED" "(dump-shrdlu)"
+
+# dump it as SHRDLU;TS SHRDLU
 respond "*" ":pdump shrdlu;ts shrdlu\r"
 respond "*" ":kill\r"
 
+# load up a compiled version of PLNR
 respond "*" ":lisp\r"
 respond "Alloc?" "n"
 respond "*" "(load 'loader)"
 respond "T" "(load 'plnrfi)"
-respond "T" "(loadplanner)"
+respond "T" "(planner-compiled)"
 respond "(THERT TOP LEVEL))" "(dump-planner)"
+
+# dump it as SHRDLU;TS PLNR
 respond "*" ":pdump shrdlu;ts plnr\r"
 respond "*" ":kill\r"
-

src/shrdlu/blockl.6 → src/shrdlu/blockl.7

@@ -5,7 +5,13 @@
 ;;;################################################################
 
 (declare (genprefix blockl)
-	 (*fexpr ert thvsetq thand thsetq thgoal))
+         (muzzled t)
+         (specials t)
+	 (*fexpr ert thvsetq thand thsetq thgoal cleanout thv)
+         (*expr imperf? start? thadd thvarsubst evlis thval end?))
+
+(eval-when (compile)
+  (load 'macros))
 
 (DEFUN ABSVAL (X) (COND ((MINUSP X) (MINUS X)) (X)))
 
@@ -14,7 +20,7 @@
 (DEFUN CLEAR
        (LOC SIZE OBJ)
        (PROG (W X1 X2)
-	     (SETQ OBJ (LISTIFY OBJ))
+	     (SETQ OBJ (LISTIFY2 OBJ))
 	     (AND (MEMQ NIL
 			(MAPCAR (QUOTE (LAMBDA (X Y)
 					       (AND (GREATERP X -1)
@@ -52,7 +58,7 @@
 (DEFUN FINDSPACE
  (TYPE SURF SIZE OBJ)
  (PROG (XYMAX XYMIN N V X1 X2)
-       (SETQ OBJ (LISTIFY OBJ))
+       (SETQ OBJ (LISTIFY2 OBJ))
        (AND (MEMQ SURF OBJ) (RETURN NIL))
        (COND ((EQ SURF (QUOTE :TABLE)) (SETQ XYMIN (QUOTE (0 0)))
 				       (SETQ XYMAX (QUOTE (1200 1200)))
@@ -124,7 +130,7 @@
 (DEFUN GROW
  (LOC MIN MAX OBJ)
  (PROG (GROW XL XH XO YL YH YO)
-       (SETQ OBJ (LISTIFY OBJ))
+       (SETQ OBJ (LISTIFY2 OBJ))
        (COND
 	((OR
 	  (MINUSP (CAAR (SETQ XL (LIST (LIST (DIFFERENCE (CAR LOC) (CAR MIN))
@@ -200,7 +206,7 @@
 		    (QUOTE (XL XH YL YH)))
 	      (GO GO)))))
 
-(DEFUN LISTIFY (X) (COND ((ATOM X) (LIST X)) (X)))
+(DEFUN LISTIFY2 (X) (COND ((ATOM X) (LIST X)) (X)))
 
 (declare (*expr fn))
 
@@ -254,7 +260,7 @@
 						      TYPE)))
 				  (LIST (LIST (QUOTE X) X)))
 			   (SETQ XX (PACKORD X (SIZE X) XX)))))
-	  (listify obj))
+	  (listify2 obj))
     (RETURN (MAPCAR (QUOTE CADR) XX))))
 
 (DEFUN PACKON
@@ -318,7 +324,7 @@
 
 (DEFUN SUPPORT
        (LOC SIZE X)
-       (COND ((EQ (CADDR LOC) 0) (QUOTE :TABLE))
+       (COND ((= (CADDR LOC) 0) (QUOTE :TABLE))
 	     ((SETQ LOC (OCCUPIER (PLUS (CAR LOC) (DIV2 (CAR SIZE)))
 				  (PLUS (CADR LOC) (DIV2 (CADR SIZE)))
 				  (SUB1 (CADDR LOC))))

src/shrdlu/blockp.5 → src/shrdlu/blockp.6

@@ -1,4 +1,3 @@
-
 ;################################################################
 ;
 ;		BLOCKP >
@@ -7,6 +6,14 @@
 ;    MICRO-PLANNER CODE FOR THE "BLOCKS" MICRO-WORLD 
 ;################################################################
 
+(declare (muzzled t))
+(declare (specials t))
+(declare (*fexpr ioc))
+(declare (*expr tcent atab listify2))
+
+(eval-when (compile)
+  (load 'macros))
+
 (DEFPROP TA-AT
 	 (THANTE (X Y) (!AT $?X $?Y) (THRPLACA (CDR (ATAB $?X)) $?Y))
 	 THEOREM)
@@ -285,7 +292,7 @@
 (DEFPROP TC-NAME
 	 (THCONSE (X)
 		  (!NAME $?X)
-		  (THVSETQ $_X (LISTIFY $?X))
+		  (THVSETQ $_X (LISTIFY2 $?X))
 		  (THVSETQ $_X (THFIND ALL
 				       $?Y
 				       (Y Z)
@@ -413,7 +420,7 @@ THEOREM)
 			  ((THSUCCEED)))
 		  (THGOAL (!IS $?Y !BOX))
 		  (THVSETQ $_Z
-			   (UNION (LISTIFY $?X)
+			   (UNION (LISTIFY2 $?X)
 				  (THVAL (QUOTE (THFIND ALL
 							$?W
 							(W)
@@ -496,7 +503,7 @@ THEOREM)
   (!STACKUP $?X)
   (OR (LESSP (APPLY (QUOTE PLUS)
 		    (MAPCAR (QUOTE (LAMBDA (X) (CADDR (SIZE X))))
-			    (listify $?x)))
+			    (listify2 $?x)))
 	     1201)
       (NOT (DPRINT2 (QUOTE TOO/ HIGH/,))))
   (THCOND
@@ -778,7 +785,8 @@ THEOREM)
 
 (SETQ NOSTACKS T)
 
-(DEFUN SASSQ (X Y Z) (OR (ASSQ X Y) (APPLY Z NIL)))
+; ejs: now defined in interpreter
+;(DEFUN SASSQ (X Y Z) (OR (ASSQ X Y) (APPLY Z NIL)))
 
 (DEFPROP !CLEARTOP (((THGOAL (!SUPPORT $?* ?)))) CHOOSE)
 
@@ -810,40 +818,6 @@ THEOREM)
 	  ((THNOT (THGOAL (!IS $?* !PYRAMID)))))
 	 CHOOSE)
 
-(THDATA)
-
-(TC-CALL)
-
-(TC-CLEARTOP)
-
-(TC-GET-RID-OF)
-
-(TC-GRASP)
-
-(TC-NAME)
-
-(TC-NOTICE)
-
-(TC-PACK)
-
-(TC-PICKUP)
-
-(TC-PUTIN)
-
-(TC-PUTON)
-
-(TC-RAISEHAND)
-
-(TC-STACKUP)
-
-(TC-UNGRASP)
-
-(TC-ON)
-
-(TC-PHYSOB)
-
-NIL
-
 (DEFUN UNION (A B) (PROG NIL
 		    UP	 (COND ((NULL A) (RETURN B))
 			       ((MEMQ (CAR A) B))

src/shrdlu/data2.1

@@ -0,0 +1,34 @@
+(THDATA)
+
+(TC-CALL)
+
+(TC-CLEARTOP)
+
+(TC-GET-RID-OF)
+
+(TC-GRASP)
+
+(TC-NAME)
+
+(TC-NOTICE)
+
+(TC-PACK)
+
+(TC-PICKUP)
+
+(TC-PUTIN)
+
+(TC-PUTON)
+
+(TC-RAISEHAND)
+
+(TC-STACKUP)
+
+(TC-UNGRASP)
+
+(TC-ON)
+
+(TC-PHYSOB)
+
+NIL
+

src/shrdlu/dictio.75 → src/shrdlu/dictio.76

@@ -1,16 +1,20 @@
-
-
-
-
 ;;;===========================================================
 ;;;
 ;;;                         WORDS
 ;;;
 ;;;===========================================================
 
+(declare (muzzled t))
+(declare (specials t))
+(declare (*fexpr defs relation ioc say ertstop))
+(declare (*expr !beint !bethere quantifier? flushme))
+
+(eval-when (compile)
+  (load 'macros))
+
 (DEFS /, FEATURES (SPECIAL) SPECIAL (COMMA))
 
-(DEFS " FEATURES (B-SPECIAL RELWRD) B-SPECIAL (DOUBLEQUOTER))
+(DEFS /" FEATURES (B-SPECIAL RELWRD) B-SPECIAL (DOUBLEQUOTER))
 
 (DEFS A SEMANTICS ((DET T)) FEATURES (DET NS INDEF))
 
@@ -103,7 +107,7 @@
 					    '!1
 					    (LIST 'QUOTE
 						  (REFER? !2))))))))
-		   (T (ERTSTOP SORRY I DON 'T UNDERSTAND THE
+		   (T (ERTSTOP SORRY I DON/'T UNDERSTAND THE
 			       VERB BE WHEN YOU USE IT LIKE
 			       THAT))))
 
@@ -175,8 +179,6 @@
 		 (RETURN (PROG (CUT NBB BOTH) 
 			       (SETQ NBB N)
 			       (AND (FLUSHME)
-;ejs
-;				    (** N
 				    (move-ptw N
 					NW
 					(EQ (WORD PTW) (CAR A))
@@ -953,11 +955,12 @@
 (DEFS THANK FEATURES (B-SPECIAL) SEMANTICS  (THANK)B-SPECIAL (THANK))
 
 (DEFUN THANK NIL 
-    (COND ((EQ (CADR N) 'YOU)
-            (SAY YOU/'RE WELCOME)
-            (FLUSHME)
-            (FLUSHME)
-          (OR NN (IOC G))
+  (COND ((EQ (CADR N) 'YOU)
+         (SAY YOU/'RE WELCOME)
+         (FLUSHME)
+         (FLUSHME)
+         (OR NN (IOC G))
+         (setq global-message '(||))
          (SETQ SPECIAL 'DONE))))
 
 (DEFS THAT 
@@ -1808,4 +1811,3 @@ MARKERS: (!PLACE)
 	 (SHORT !HEIGHT)
 	 (THICK !THICKNESS)
 	 (THIN !THICKNESS))
-