github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-02-27 01:09:49 +00:00
Code Issues Releases Wiki Activity

Got rid of hack of setting CAR and CDR values to T.

Browse Source 
The old Maclisp used when SHRDLU was created allowed one to take the CAR
and CDR of atoms.  The former returned internal bits associated wih the
symbol, and the latter returned the property list of the symbol.

This was disabled in later verisons of MacLISP, but allowed to be enabled
by setting the value of CAR to T (and the value of CDR to T).

However, doing this masked coding errors that resulted from unintentionally
taking the CAR or CDR of a symbol, when a list or NUL was actually expected.

This commit removes the hack of setting CAR and CDR to T, and adds macros
to replace the use of CAR and CDR in this cases in PLNR and associated PLNR
logic.  These macros are found in the MACROS module.  Making this change,
and removing the duplicated $ reader macro from PLNR (it is already in
MACROS for the benefit of other files), required making changes to the
loader of SHRDLU and PLNR.  I removed the obsolete use of UREAD to load
interpreted files, and replaced with a new NEW-LOAD function.  UREAD was
unable to handle the (status macro $ 'thread) code that needed to be included.
This commit is contained in:
Eric Swenson
2024-08-22 17:43:00 -07:00
parent ae5b1a31b0
commit b26050f9d2
7 changed files with 282 additions and 299 deletions
Download Patch File Download Diff File Expand all files Collapse all files

16
src/shrdlu/blockp.6 → src/shrdlu/blockp.7
View File

@@ -288,7 +288,6 @@
((THSETQ PLAN
(CONS (CONS (QUOTE MOVETO) $?Y) PLAN)))))
THEOREM)
(DEFPROP TC-NAME
(THCONSE (X)
(!NAME $?X)
@@ -434,7 +433,9 @@ THEOREM)
(THCONSE (X Y Z (WHY (EV)) EV)
(!PUTON $?X $?Y)
(ATOM $?Y)
(OR (CDR $?X) (THSETQ $_X (CAR $?X)))
(OR (cond ((listp $?x) (cdr $?x))
(t (plist $?x)))
(THSETQ $_X (and (listp $?x) (CAR $?X))))
(NOT (COND ((ATOM $?X) (EQ $?X $?Y)) ((MEMQ $?Y $?X))))
(MEMORY)
(THCOND ((ATOM $?X)
@@ -623,12 +624,11 @@ THEOREM)
(THGOAL (!AT $?Y $?Z))
(THSUCCEED THEOREM)))
(THSETQ $_X(TFIND $?Y $?TIME))
(THOR(THSETQ $_W(CAR $?X))
(THAND(THAMONG $?W (CDR $?X))
(OR (NOT (LESSP (CAR $?W) (OR (START? $?TIME) -1)))
(THFAIL THAND))
))
(THOR (THSETQ $_W (CAR $?X))
(THAND (THAMONG $?W (CDR $?X))
(OR (NOT (LESSP (CAR $?W) (OR (START? $?TIME) -1)))
(THFAIL THAND))
))
(THSETQ $?Z (CADR $?W)))
THEOREM)

4
src/shrdlu/gramar.29 → src/shrdlu/gramar.30
View File

@@ -1112,7 +1112,7 @@ FDEC (FQ DECLAR)
;; CHECK FOR DISGUISED RSQ CLAUSES BY READING THE FAILURE
;;MESSAGES SENT UP FROM PREPG.
(: (EQ (CAR MES) 'PREP-WHICH) NIL RSQ)
(: (and (listp mes) (EQ (CAR MES) 'PREP-WHICH)) NIL RSQ)
(SETQ MES (CDR MES))
(: (PARSE CLAUSE RSQ PREPREL) PREPNG (RSQ-PREPREL) RETSM)
@@ -1929,7 +1929,7 @@ possdef ;the placement of this tag is a
(AND (ATOM PREV)
(MOVE-PTW N NW (EQ (WORD PTW) PREV))
(CUT PTW))
(AND (OR (EQ PREV 'BUT) (EQ (CADR PREV) 'BUT))
(AND (OR (EQ PREV 'BUT) (and (listp prev) (EQ (CADR PREV) 'BUT)))
(NEXTWORD? 'NOT) ;CHECK FOR BUT-NOT COMBINATION
(OR (FLUSHME) (*GO LOSE2))
(FQ NEGBUT))

122
src/shrdlu/loader.21 → src/shrdlu/loader.22
View File

@@ -1,19 +1,23 @@
;;; THIS IS A PACKAGE FOR LOADING SHRDLU'S INTO CORE FROM THE DISK FILES.
;;; THE PROCEDURE IS TO FIRST LOAD A BLISP (IGNORE ALLOCATIONS, THE
;;; PROGRAMS DO THEIR OWN). AND UREAD THIS FILE. EXECUTING "LOADSHRDLU"
;;; WILL GENERATE (AFTER SOME TIME) A FULLY INTERPRETED VERSION.
;;; PARTIALLY COMPILED MIXES ARE AVAILLABLE, AS SEEN BELOW.
;;; THIS IS A PACKAGE FOR LOADING SHRDLUS INTO CORE FROM THE DISK FILES.
;;; THE PROCEDURE IS TO FIRST LOAD A LISP (IGNORE ALLOCATIONS, THE
;;; PROGRAMS DO THEIR OWN), THEN TO LOAD THIS FILE. EXECUTING
;;; (load-shrdlu-interpreted) WILL GENERATE (AFTER SOME TIME) A FULLY
;;; INTERPRETED VERSION. Once SHRDLU is loaded, invoking
;;; (dump-shrdlu) will generate a PDUMPable image.
;;;
;;; (load-shrdlu-compiled) can be used instead of
;;; (load-shrdlu-interpreted) to load a compiled version of PLNR and
;;; SHRDLU. (dump-shrdlu) can then be used to generate a PDUMPable
;;; image.
;;;
;;; THE VARIABLE "VERSION-FILES" KEEPS A RUNNING TAB OF THE FILES
;;; LOADER VIA "LOADER". IF ANY ERRORS OCCUR DURING READIN THEY
;;; LOADER VIA "new-loader". IF ANY ERRORS OCCUR DURING READIN THEY
;;; ARE PROTECTED BY AN "ERRSET" AND LOADING CONTINUES. (NOTE !! IF AN
;;; UNBOUND PAREN CAUSES THE FILE TO BE TERMINATED TOO SOON, YOU'LL
;;; NEVER NOTICE)
;;;
;(setsyntax 34. 'single 34.)
(SETQ GC-OVERFLOW '(LAMBDA (X) T))
(defun makoblist (x)
(cond ((null x)
(listarray obarray (- (cadr (arraydims 'obarray)) 129.)))
@@ -35,29 +39,23 @@
(SETQ *RSET T)
(DEFUN LOADER (*!?KEY)
(OR (ERRSET (EVAL (LIST 'UREAD
*!?KEY
'>
'DSK
'SHRDLU))
NIL)
(AND (PRINT *!?KEY)
(PRINC 'NOT-FOUND)
(RETURN NIL)))
(LOADX))
(DEFUN LOADX ()
(PROG (*!?H *!?F *!?EOF)
(SETQ *!?EOF (GENSYM))
(PRINT 'READING)
(PRINC *!?KEY)
(SETQ VERSION-FILES (CONS (STATUS UREAD) VERSION-FILES))
LOOP ((LAMBDA (^Q) (SETQ *!?H (READ *!?EOF))) T)
(AND (EQ *!?H *!?EOF) (RETURN T))
(OR (ERRSET ((LAMBDA (^W ^Q) (EVAL *!?H)) T T))
(PROG2 (PRINT 'ERROR-IN-FILE) (PRINT *!?H)))
(GO LOOP)))
(defun new-loader (filename)
(let ((file (probef `(,filename > dsk shrdlu))))
(if file
(progn
(print 'reading)
(princ filename)
(setq version-files (cons file version-files))
(or
(errset (progn (load file) t))
(progn
(print filename)
(princ 'error-in-file)
nil)))
(progn
(print filename)
(princ 'not-found)
nil))))
(defun fload2 (x)
(fload (cons x '(fasl dsk shrdlu))))
@@ -71,75 +69,69 @@
(ERT lossage in loading - try again ?))
)
(SETQ VERSION-FILES NIL)
(defun loadplanner ()
(defun load-planner-interpreted ()
(ALLOC '(LIST 320000
FIXNUM 15000
SYMBOL 15000
array 500
flonum 4000))
(SETQ PURE NIL)
(setq car t)
(setq cdr t)
(SETQ THINF NIL THTREE NIL THLEVEL NIL)
(MAPC 'LOADER '(PLNR THTRAC))
(new-loader 'plnrfi)
(MAPC 'new-LOADER '(PLNR THTRAC))
(THINIT))
(defun planner-compiled ()
(defun load-planner-compiled ()
(ALLOC '(LIST 320000
FIXNUM 15000
SYMBOL 15000
array 500
flonum 4000))
(SETQ PURE NIL)
(setq car t)
(setq cdr t)
(SETQ THINF NIL THTREE NIL THLEVEL NIL)
(new-loader 'plnrfi)
(MAPC 'fload2 '(PLNR THTRAC))
(THINIT))
(DEFUN LOADSHRDLU ()
(DEFUN load-shrdlu-interpreted ()
(ALLOC '(LIST 320000
FIXNUM 15000
SYMBOL 15000
array 500
flonum 3000))
(SETQ PURE NIL)
(setq car t)
(setq cdr t)
(SETQ THINF NIL THTREE NIL THLEVEL NIL NOSTOP NIL)
(load '((lisp) slave fasl))
(load '((lisp) format fasl))
(load '((lisp) umlmac fasl))
(MAPC 'LOADER '(PLNR THTRAC))
(load '(macros >))
(MAPC 'new-LOADER '(PLNR THTRAC))
(thinit)
(setq errlist nil) ;removes micro-planner's fangs
(MAPC 'LOADER '(SYSCOM MORPHO SHOW))
(MAPC 'LOADER '(PROGMR PROGGO GINTER GRAMAR DICTIO))
(MAPC 'LOADER '(SMSPEC SMASS SMUTIL))
(LOADER 'NEWANS)
(load 'blockp)
(load 'data2)
(load 'blockl)
(LOADER 'SETUP)
(load 'data)
(MAPC 'new-LOADER '(SYSCOM MORPHO SHOW))
(MAPC 'new-LOADER '(PROGMR PROGGO GINTER GRAMAR DICTIO))
(MAPC 'new-LOADER '(SMSPEC SMASS SMUTIL))
(new-loader 'NEWANS)
(new-loader 'blockp)
(new-loader 'data2)
(new-loader 'blockl)
(new-loader 'SETUP)
(new-loader 'data)
(load '((lisp) trace fasl))
(let ((x nil)) nil) ; forces let to get loaded
; (let ((x nil)) nil) ; forces let to get loaded
(load '((shrdlu) graphf fasl))
(load '((lisp) grinde fasl))
'CONSTRUCTION/ COMPLETED)
(DEFUN SHRDLU-COMPILED ()
(DEFUN load-shrdlu-compiled ()
(ALLOC '(LIST 320000
FIXNUM 15000
SYMBOL 15000
array 500
flonum 3000))
(SETQ PURE NIL)
(setq car t)
(setq cdr t)
(SETQ THINF NIL THTREE NIL THLEVEL NIL NOSTOP NIL)
(load '((lisp) slave fasl))
(mapc 'fload2 '(plnr thtrac))
@@ -151,27 +143,27 @@
(mapc 'fload2 '(newans blockp))
(load 'data2)
(fload2 'blockl)
(LOADER 'SETUP)
(new-LOADER 'SETUP)
(load 'data)
(load '((lisp) trace fasl))
(let ((x nil)) nil) ; forces let to get loaded
(load '((shrdlu) graphf fasl))
(load '((lisp) grinde fasl))
(load '((lisp) mlmac fasl))
(load '((lisp) mlsub fasl))
'COMPLETED)
(defun loadparser ()
(defun load-parser-interpreted ()
(mapc 'loader '(syscom morpho show))
(mapc 'loader '(progmr proggo ginter gramar dictio))
(loader 'setup)
(loader 'parser)
(new-loader 'setup)
(new-loader 'parser)
'complete-call-setup-num-date)
(DEFUN PARSER-compiled ()
(DEFUN load-parser-compiled ()
(SETQ PURE NIL)
(mapc 'fload2 '(syscom morpho show))
(mapc 'fload2 '(progmr proggo ginter gramar dictio))
(load '((lisp) trace fasl))
(loader 'setup)
(loader 'parser)
(new-loader 'setup)
(new-loader 'parser)
'PARSER-LOADED)

29
src/shrdlu/macros.1 → src/shrdlu/macros.2
View File

@@ -1,6 +1,4 @@
(SSTATUS MACRO $ (QUOTE THREAD))
(DEFUN THREAD ;FUNCTION FOR THE /$ READ MACRO
(DEFUN THREAD ;FUNCTION FOR THE /$ READ MACRO
;;EXPANDS _ TO (THNV (READ)) EXPANDS A TO ASSERT ;EXPANDS G TO GOAL EXPANDS T TO THTBF THTRUE
NIL ;EXPANDS ? TO (THV (READ)) EXPANDS E TO (THEV
;(READ))
@@ -29,3 +27,28 @@
(PRINC CHAR)
(PRINC (READ))
(ERR NIL))))))
(sstatus macro $ 'thread)
; this macro handles the case where the value passed to it is an atom
; the old MacLISP used to support this, and this returned some implementation
; specific flags from a symbol flag word. The current MacLISP CAR doesn't
; allow this, and causes an error to be signalled. Rather than SETQ the value
; CAR to T, which re-enables the old behavior, this macro handles the ATOM
; case by returning a GENSYM (*car-of-atom*), which is guaranteed not to match
; any other value. In the original code, any comparison with the value returned
; from (CAR <atom>) would fail, and so too does this rewrite.
(defvar *car-of-atom* (gensym))
(defmacro carx (x)
`(let ((xx ,x))
(cond ((null xx) nil)
((atom xx) *car-of-atom*)
(t (car xx)))))
(defmacro cdrx (x)
`(let ((xx ,x))
(cond ((null xx) nil)
((atom xx) (error "CDRX of a symbol"))
(t (cdr xx)))))

403
src/shrdlu/plnr.184 → src/shrdlu/plnr.185
View File

File diff suppressed because it is too large Load Diff

3
src/shrdlu/plnrfi.1 → src/shrdlu/plnrfi.2
View File

@@ -4,9 +4,6 @@
(t
(*ARRAY x 'OBARRAY))))
(setq car t)
(setq cdr t)
(defun dump-planner ()
(suspend)
(thinit)

4
src/shrdlu/smutil.151 → src/shrdlu/smutil.152
View File

@@ -120,7 +120,7 @@
(DEFUN NEWCOPY (OSS)
(PROG (OLD NEW)
(SETQ NEW (MAKESYM 'OSS))
(SETQ OLD (CDR OSS))
(SETQ OLD (plist OSS))
;WATCH OUT -- THIS IS IMPLEMENTATION DEPENDENT,
UP (COND ((NULL OLD)
;AND GETS THE ENTIRE PROPERTY LIST IN OUR LISP.
@@ -1282,6 +1282,8 @@
(PROG NIL
LOOP (COND ((NULL NEW-MARKERS)
(RETURN (LIST MARKERS SYSTEMS)))
((not (listp new-markers))
(return nil))
((CHECKAMARKER (CAR NEW-MARKERS))
(SETQ NEW-MARKERS (CDR NEW-MARKERS))
(GO LOOP))