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

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))
-