[Mit-cadr-cvs] r300 - in trunk/lisp: patch sys sys2
rswindells at common-lisp.net
rswindells at common-lisp.net
Sat May 5 16:17:49 UTC 2012
Author: rswindells
Date: Sat May 5 09:17:48 2012
New Revision: 300
Log:
Patches to help build the cold load generator.
Added:
trunk/lisp/patch/System-78-51.lisp
trunk/lisp/patch/System-78-52.lisp
Modified:
trunk/lisp/patch/System-78.patch-directory
trunk/lisp/sys/qmisc.lisp
trunk/lisp/sys2/lmmac.lisp
Added: trunk/lisp/patch/System-78-51.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/lisp/patch/System-78-51.lisp Sat May 5 09:17:48 2012 (r300)
@@ -0,0 +1,21 @@
+;;; -*- Mode: Lisp; Package: User; Base: 8.; Patch-File: T -*-
+;;; Patch file for System version 78.51
+;;; Reason: Make ASSIGN-ALTERNATE only read symbols into current package.
+;;; Written 6/08/10 16:36:29 by RJS,
+;;; while running on Unknown from band 1
+;;; with System 78.50, ZMail 38.5, Tape 6.5, LMFS 21.34, Symbolics 8.13, microcode 841.
+
+
+
+; From file qmisc.lisp >sys UNKNOWN:
+#8R SYSTEM-INTERNALS:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
+
+;These are for reading in QCOM, and the like
+(DEFUN ASSIGN-ALTERNATE (X)
+ (PROG NIL
+ L (COND ((NULL X)(RETURN NIL)))
+ (SET (INTERN-LOCAL (GET-PNAME (CAR X)) PACKAGE) (CADR X))
+ (SETQ X (CDDR X))
+ (GO L)))
+
+)
Added: trunk/lisp/patch/System-78-52.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/lisp/patch/System-78-52.lisp Sat May 5 09:17:48 2012 (r300)
@@ -0,0 +1,53 @@
+;;; -*- Mode: Lisp; Package: User; Base: 8.; Patch-File: T -*-
+;;; Patch file for System version 78.52
+;;; Reason: Add SEND, GETF, WHEN and UNLESS.
+;;; Written 6/09/10 23:44:09 by RJS,
+;;; while running on Unknown from band 1
+;;; with System 78.51, ZMail 38.5, Tape 6.5, LMFS 21.34, Symbolics 8.13, microcode 841.
+
+
+
+; From file lmmac.lisp >sys2 UNKNOWN:
+#8R SYSTEM-INTERNALS:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
+
+(DEFMACRO GETF (PLACE PROPERTY &OPTIONAL (DEFAULT NIL))
+ `(OR (GET (LOCF ,PLACE) ,PROPERTY) ,DEFAULT))
+
+)
+
+; From file lmmac.lisp >sys2 UNKNOWN:
+#8R SYSTEM-INTERNALS:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
+
+(DEFMACRO SEND (OBJECT OPERATION &REST ARGUMENTS)
+ `(FUNCALL ,OBJECT ,OPERATION . ,ARGUMENTS))
+
+)
+
+; From file lmmac.lisp >sys2 UNKNOWN:
+#8R SYSTEM-INTERNALS:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
+
+;;; (WHEN pred {form}*)
+(DEFMACRO WHEN (PRED &BODY BODY)
+ `(AND ,PRED (PROGN , at BODY)))
+
+)
+
+; From file lmmac.lisp >sys2 UNKNOWN:
+#8R SYSTEM-INTERNALS:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
+
+;;; (UNLESS pred {form}*)
+(DEFMACRO UNLESS (PRED &BODY BODY)
+ `(IF ,PRED () , at BODY))
+
+)
+
+; From file lmmac.lisp >sys2 UNKNOWN:
+#8R SYSTEM-INTERNALS:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
+
+(DEFMACRO DO-FOREVER (&BODY BODY)
+ `(DO ()
+ (())
+ . ,BODY))
+
+)
+
Modified: trunk/lisp/patch/System-78.patch-directory
==============================================================================
--- trunk/lisp/patch/System-78.patch-directory Sat May 5 09:11:35 2012 (r299)
+++ trunk/lisp/patch/System-78.patch-directory Sat May 5 09:17:48 2012 (r300)
@@ -1,8 +1,8 @@
;;; -*- Mode: Lisp; Package: User; Base: 10.; Patch-File: T -*-
;;; Patch directory for System version 78
-;;; Written 7/25/08 02:14:22 by RJS,
+;;; Written 6/12/10 20:47:50 by RJS,
;;; while running on Unknown from band 1
-;;; with System 78.49, ZMail 38.5, Tape 6.5, LMFS 21.34, Symbolics 8.13, microcode 841.
+;;; with System 78.52, ZMail 38.5, Tape 6.5, LMFS 21.34, Symbolics 8.13, microcode 841.
(RELEASED
((0 "System Loaded" "rg")
@@ -56,5 +56,6 @@
(48 "(CHAOS:HOST-TRUSTED-P <host-address>) & :TRUSTED-CHAOS-SUBNETS site variable." "BSG")
(49 "Y2K Fixes." "RJS")
(50 "Extra Y2K fix." "RJS")
- ))
-
+ (51 "Make ASSIGN-ALTERNATE only read symbols into current package." "RJS")
+ (52 "Add DO-FOREVER, SEND, GETF, WHEN and UNLESS." "RJS")
+ ))
\ No newline at end of file
Modified: trunk/lisp/sys/qmisc.lisp
==============================================================================
--- trunk/lisp/sys/qmisc.lisp Sat May 5 09:11:35 2012 (r299)
+++ trunk/lisp/sys/qmisc.lisp Sat May 5 09:17:48 2012 (r300)
@@ -1543,7 +1543,7 @@
(DEFUN ASSIGN-ALTERNATE (X)
(PROG NIL
L (COND ((NULL X)(RETURN NIL)))
- (SET (CAR X) (CADR X))
+ (SET (INTERN-LOCAL (GET-PNAME (CAR X)) PACKAGE) (CADR X))
(SETQ X (CDDR X))
(GO L)))
Modified: trunk/lisp/sys2/lmmac.lisp
==============================================================================
--- trunk/lisp/sys2/lmmac.lisp Sat May 5 09:11:35 2012 (r299)
+++ trunk/lisp/sys2/lmmac.lisp Sat May 5 09:17:48 2012 (r300)
@@ -52,6 +52,12 @@
;COMPLR DOESNT KNOW (OR CARE) ABOUT COMPILER-LET.
(T LISPM-FORM)))
+(DEFMACRO SEND (OBJECT OPERATION &REST ARGUMENTS)
+ `(FUNCALL ,OBJECT ,OPERATION . ,ARGUMENTS))
+
+(DEFMACRO GETF (PLACE PROPERTY &OPTIONAL (DEFAULT NIL))
+ `(OR (GET (LOCF ,PLACE) ,PROPERTY) ,DEFAULT))
+
;; Needed when conditionalizing something at top level with #Q or #M because
;; splicing readmacros flushed then. #Q and #M now work at top level, so this
;; is for compatibility only.
@@ -330,6 +336,14 @@
((EQ TEST T) THEN) ;and this one (avoids compiler error msg)
(T `(COND (,TEST ,THEN) (T . ,(OR ELSES '(NIL)))))))
+;;; (WHEN pred {form}*)
+(DEFMACRO WHEN (PRED &BODY BODY)
+ `(AND ,PRED (PROGN , at BODY)))
+
+;;; (UNLESS pred {form}*)
+(DEFMACRO UNLESS (PRED &BODY BODY)
+ `(IF ,PRED () , at BODY))
+
;;; (CHECK-ARG STRING STRINGP "a string") signals an error if STRING is not a string.
;;; The error signals condition :WRONG-TYPE-ARGUMENT with arguments
;;; which are STRINGP (the predicate), the value of STRING (the losing value),
@@ -559,6 +573,11 @@
((
,VAR .DOTIMES-INTERNAL.))
. ,BODY))))
+(DEFMACRO DO-FOREVER (&BODY BODY)
+ `(DO ()
+ (())
+ . ,BODY))
+
;;; Execute body with a stream open. Abnormal exit aborts the file (if it's an output file).
(DEFMACRO-DISPLACE WITH-OPEN-STREAM ((STREAM CONSTRUCTION-FORM) &BODY BODY)
`(LET ((,STREAM NIL)
More information about the mit-cadr-cvs
mailing list