diff --git a/sources/CMLTYPES b/sources/CMLTYPES index 3d617222b..80e2ecbee 100644 --- a/sources/CMLTYPES +++ b/sources/CMLTYPES @@ -1,15 +1,20 @@ -(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP") -(IL:FILECREATED " 4-Jan-93 17:55:42" IL:|{DSK}lde>lispcore>sources>CMLTYPES.;2| 66088 +(DEFINE-FILE-INFO PACKAGE "LISP" READTABLE "XCL" BASE 10) - IL:|previous| IL:|date:| "16-May-90 14:50:29" IL:|{DSK}lde>lispcore>sources>CMLTYPES.;1| +(IL:FILECREATED " 4-Jun-2024 23:32:50" IL:|{DSK}matt>Interlisp>medley>SOURCES>CMLTYPES.;2| 66046 + + :EDIT-BY "mth" + + :CHANGES-TO (IL:FUNCTIONS SYMBOL-TYPE) + + :PREVIOUS-DATE " 4-Jan-93 17:55:42" IL:|{DSK}matt>Interlisp>medley>SOURCES>CMLTYPES.;1| ) -; Copyright (c) 1985, 1986, 1987, 1988, 1990, 1993 by Venue & Xerox Corporation. All rights reserved. +; Copyright (c) 1985-1988, 1990, 1993, 2024 by Venue & Xerox Corporation. (IL:PRETTYCOMPRINT IL:CMLTYPESCOMS) -(IL:RPAQQ IL:CMLTYPESCOMS +(IL:RPAQQ IL:CMLTYPESCOMS ( (IL:* IL:|;;;| "Implementation of Common Lisp type system. ") @@ -137,8 +142,8 @@ (IL:* IL:|;;| "Check if OBJECT is of type TYPE") (LET* ((SYMBOL-TYPE (IF (CONSP TYPE) - (CAR TYPE) - TYPE)) + (CAR TYPE) + TYPE)) (FN (GETHASH SYMBOL-TYPE *TYPEP-HASH-TABLE*))) (IF FN (IF (CONSP TYPE) @@ -174,8 +179,7 @@ (ERROR "Unknown type expression: ~s" TYPE))))))))) (DEFUN TYPE-OF (X) - (LET ((TYPENAME (IL:\\INDEXATOMPNAME (IL:|fetch| IL:DTDNAME IL:|of| (IL:\\GETDTD - (IL:NTYPX X)))))) + (LET ((TYPENAME (IL:\\INDEXATOMPNAME (IL:|fetch| IL:DTDNAME IL:|of| (IL:\\GETDTD (IL:NTYPX X)))))) (SETQ TYPENAME (OR (GET TYPENAME 'CMLTYPE) TYPENAME)) (OR (LET ((D (GET TYPENAME 'CMLSUBTYPE-DESCRIMINATOR))) @@ -245,27 +249,27 @@ (NULL TYPE)))) (XCL:DEFOPTIMIZER TYPEP (OBJ TYPE) - (IF (CONSTANTP TYPE) - (LET ((TYPE-EXPR (EVAL TYPE))) - (IF (%VALID-TYPE-P TYPE-EXPR) - `(,(%TYPEP-PRED TYPE-EXPR) - ,OBJ) - (PROGN (WARN "Can't optimize (typep ~s ~s); type not known." - OBJ TYPE) - 'COMPILER:PASS))) - 'COMPILER:PASS)) + (IF (CONSTANTP TYPE) + (LET ((TYPE-EXPR (EVAL TYPE))) + (IF (%VALID-TYPE-P TYPE-EXPR) + `(,(%TYPEP-PRED TYPE-EXPR) + ,OBJ) + (PROGN (WARN "Can't optimize (typep ~s ~s); type not known." OBJ + TYPE) + 'COMPILER:PASS))) + 'COMPILER:PASS)) (XCL:DEFOPTIMIZER COERCE (OBJECT RESULT-TYPE) - (IL:* IL:|;;| "Open code the simple coerce cases ") + (IL:* IL:|;;| "Open code the simple coerce cases ") - (IF (CONSTANTP RESULT-TYPE) - (CASE (EVAL RESULT-TYPE) - (CHARACTER `(CHARACTER ,OBJECT)) - ((FLOAT SINGLE-FLOAT SHORT-FLOAT LONG-FLOAT DOUBLE-FLOAT) - `(FLOAT ,OBJECT)) - (OTHERWISE 'COMPILER:PASS)) - 'COMPILER:PASS)) + (IF (CONSTANTP RESULT-TYPE) + (CASE (EVAL RESULT-TYPE) + (CHARACTER `(CHARACTER ,OBJECT)) + ((FLOAT SINGLE-FLOAT SHORT-FLOAT LONG-FLOAT DOUBLE-FLOAT) + `(FLOAT ,OBJECT)) + (OTHERWISE 'COMPILER:PASS)) + 'COMPILER:PASS)) @@ -275,10 +279,10 @@ (XCL:DEF-DEFINE-TYPE IL:TYPES "Common Lisp type definitions") (XCL:DEFDEFINER (DEFTYPE (:PROTOTYPE (LAMBDA (NAME) - (AND (SYMBOLP NAME) - `(DEFTYPE ,NAME ("Arg list") - "Body"))))) IL:TYPES (NAME DEFTYPE-ARGS - &BODY BODY) + (AND (SYMBOLP NAME) + `(DEFTYPE ,NAME ("Arg list") + "Body"))))) IL:TYPES (NAME DEFTYPE-ARGS &BODY + BODY) (UNLESS (AND NAME (SYMBOLP NAME)) (ERROR "Illegal name used in DEFTYPE: ~S" NAME)) (LET @@ -321,8 +325,8 @@ (DEFUN TYPE-EXPANDER (TYPE) (LET* ((SYMBOL-TYPE (ETYPECASE TYPE - (SYMBOL TYPE) - (CONS (CAR TYPE)))) + (SYMBOL TYPE) + (CONS (CAR TYPE)))) (EXPANDER (OR (GET SYMBOL-TYPE ':TYPE-EXPANDER) (GET SYMBOL-TYPE 'IL:TYPE-EXPANDER)))) (IF (AND (NULL EXPANDER) @@ -342,7 +346,7 @@ (IL:FILEPKGFLG NIL) (IL:* IL:|;;| - "DFNFLG nil makes sure this has an effect and filepkgflg nil makes sure it isn't remembered.") + "DFNFLG nil makes sure this has an effect and filepkgflg nil makes sure it isn't remembered.") ) (EVAL DEFTYPE-FORM))) @@ -394,10 +398,13 @@ (LIST 'ARRAY (ARRAY-ELEMENT-TYPE ARRAY) (ARRAY-DIMENSIONS ARRAY)))))) -(DEFUN SYMBOL-TYPE (SYMBOL) - (IF (KEYWORDP SYMBOL) - 'KEYWORD - 'SYMBOL)) +(DEFUN SYMBOL-TYPE (SYMBOL) (IL:* IL:\; "Edited 4-Jun-2024 23:23 by mth") + (COND + ((NULL SYMBOL) + 'NULL) + ((KEYWORDP SYMBOL) + 'KEYWORD) + (T 'SYMBOL))) (DEFUN XCL:FALSE () NIL) @@ -474,18 +481,18 @@ T)) (XCL:DEFOPTIMIZER NUMBERP (X) - `(AND (IL:NUMBERP ,X) - T)) + `(AND (IL:NUMBERP ,X) + T)) (XCL:DEFOPTIMIZER FLOATP (X) - `(AND (IL:FLOATP ,X) - T)) + `(AND (IL:FLOATP ,X) + T)) (XCL:DEFOPTIMIZER XCL:FALSE (&BODY IL:FORMS) - `(PROG1 NIL ,@IL:FORMS)) + `(PROG1 NIL ,@IL:FORMS)) (XCL:DEFOPTIMIZER XCL:TRUE (&BODY XCL::FORMS) - `(PROG1 T ,@XCL::FORMS)) + `(PROG1 T ,@XCL::FORMS)) @@ -546,7 +553,7 @@ (DEFCONSTANT *COMMON-LISP-BASE-TYPES* (IL:* IL:|;;| - "The types which are known to be disjoint from any type explicitly handled by subtypep.") + "The types which are known to be disjoint from any type explicitly handled by subtypep.") '( (IL:* IL:|;;| "The only types that need to be in this list are types on page 43 that expand into a satisfies or datatype clause, i.e. any type that expands into something that base-subtypep doesn't know to handle, e.g. satisfies.") @@ -554,10 +561,10 @@ ARRAY ATOM BIGNUM (IL:* IL:\; "even though bignum expands into a datatype, that datatype is not a subdatatype of integer, etc. so must be explicitly handled.") CHARACTER COMMON COMPLEX COMPILED-FUNCTION CONS IL:DATATYPE (IL:* IL:\; - "this is only here for back-compatibility. The first global recompile, this can go.") + "this is only here for back-compatibility. The first global recompile, this can go.") :DATATYPE FLOAT FUNCTION HASH-TABLE INTEGER KEYWORD NIL NULL NUMBER PACKAGE PATHNAME RANDOM-STATE RATIO (IL:* IL:\; - "same comment for ratio as bignum.") + "same comment for ratio as bignum.") RATIONAL READTABLE SIMPLE-ARRAY STANDARD-CHAR STREAM STRING-CHAR SYMBOL T)) (DEFCONSTANT *BASE-TYPE-LATTICE* @@ -572,14 +579,14 @@ #'COMPILED-FUNCTION (NIL) (IL:DATATYPE :DATATYPE) (IL:* IL:\; - "the presence of il:datatype is for back compatibility.") + "the presence of il:datatype is for back compatibility.") (:DATATYPE IL:DATATYPE)) "the lattice which tells the (base) subtypes of any base type.") (DEFUN SUBTYPEP (TYPE1 TYPE2) (IL:* IL:|;;| - "Returns T if type1 is a subtype of type2. If second value is nil, couldn't decide.") + "Returns T if type1 is a subtype of type2. If second value is nil, couldn't decide.") (IF (EQUAL TYPE1 TYPE2) @@ -608,7 +615,7 @@ (OR (IL:* IL:|;;| - "(subtypep '(or t1 t2 ...) 't3) <=> (and (subtypep 't1 't3) (subtypep 't2 't3) ...)") + "(subtypep '(or t1 t2 ...) 't3) <=> (and (subtypep 't1 't3) (subtypep 't2 't3) ...)") (LET ((RESULT T) CERTAINTY @@ -628,7 +635,7 @@ (RETURN T) (IL:* IL:|;;| - "else continue to look for a more cetain result") + "else continue to look for a more cetain result") (SETQ LOOP-CERTAINTY NIL))) (T (IF (NULL CONJUNCT-CERTAINTY) @@ -669,7 +676,7 @@ (RETURN T) (IL:* IL:|;;| - "else continue to look for a more cetain result") + "else continue to look for a more cetain result") (SETQ LOOP-CERTAINTY NIL))) (T (IF (NULL CONJUNCT-CERTAINTY) @@ -680,7 +687,7 @@ (IL:* IL:|;;| "(subtypep 't1 '(or t2 t3 ...)) <=> (or (subtypep 't1 't2) (subtypep 't1 't3) ... ) because '(or t1 t2 ...) denotes the union of types t1, t2, ...") (IL:* IL:|;;| - "We can't ever return (values nil t) because the t2..tn might form a partition of t1, i.e.") + "We can't ever return (values nil t) because the t2..tn might form a partition of t1, i.e.") (IL:* IL:|;;| "(deftype evenp nil '(and integer (satisfies %evenp)))") @@ -709,7 +716,7 @@ (SUBTYPEP TYPE1 NEW-TYPE2) (IL:* IL:|;;| - "we have now handled everything but base types. There is no further expansion etc, to be done.") + "we have now handled everything but base types. There is no further expansion etc, to be done.") (BASE-SUBTYPEP TYPE1 TYPE2))))))))))) @@ -737,10 +744,9 @@ (DO* ((TYPE-NUMBER-1 (IL:\\TYPENUMBERFROMNAME TYPE1)) (TYPE-NUMBER-2 (IL:\\TYPENUMBERFROMNAME TYPE2)) - (SUPER-TYPE-NUMBER TYPE-NUMBER-1 (IL:|fetch| IL:DTDSUPERTYPE IL:|of| (IL:\\GETDTD - + (SUPER-TYPE-NUMBER TYPE-NUMBER-1 (IL:|fetch| IL:DTDSUPERTYPE IL:|of| (IL:\\GETDTD SUPER-TYPE-NUMBER - )))) + )))) ((EQ %NO-SUPER-TYPE SUPER-TYPE-NUMBER) (IL:* IL:|;;| "we didn't find type2 on type1's super chain so return NIL ") @@ -752,7 +758,7 @@ (DEFUN EQUAL-DIMENSIONS (DIMS1 DIMS2) (IL:* IL:|;;| - "Says if dims1 and dims2 are the same in each dimension (allowing for wildcard's (*'s)).") + "Says if dims1 and dims2 are the same in each dimension (allowing for wildcard's (*'s)).") (OR (EQ DIMS1 '*) (EQ DIMS2 '*) @@ -784,12 +790,12 @@ TYPE (LIST TYPE)))) (CASE (CAR LIST-TYPE) - ((SIMPLE-ARRAY ARRAY) (XCL:DESTRUCTURING-BIND (ARRAY-TYPE &OPTIONAL - (ELEMENT-TYPE '*) + ((SIMPLE-ARRAY ARRAY) (XCL:DESTRUCTURING-BIND (ARRAY-TYPE &OPTIONAL (ELEMENT-TYPE + '*) (DIMENSIONS '*)) LIST-TYPE (LIST ARRAY-TYPE ELEMENT-TYPE ( - COMPLETE-ARRAY-TYPE-DIMENSIONS + COMPLETE-ARRAY-TYPE-DIMENSIONS DIMENSIONS)))) ((INTEGER FLOAT RATIONAL) (XCL:DESTRUCTURING-BIND (NUMERIC-TYPE &OPTIONAL (LOWER '*) @@ -886,17 +892,17 @@ (IL:* IL:|;;| "from this point on, we are only dealing with Common Lisp base types.") ((EQ TYPE1 T) (IL:* IL:\; - "t is not a subtype of anything but t, and that's checked above).") + "t is not a subtype of anything but t, and that's checked above).") (VALUES NIL T)) ((EQ TYPE2 NIL) (IL:* IL:\; - "nil is not a supertype of anything but nil, and that's checked above).") + "nil is not a supertype of anything but nil, and that's checked above).") (VALUES NIL T)) ((EQ TYPE2 'ATOM) (IL:* IL:|;;| "this case could be explicitly added to the type lattice. But if someone adds a base type, then they would have to remember to add it as a sub type of atom, (which they wouldn't.)") (IF (EQ TYPE1 'CONS) (IL:* IL:\; - "this is the only base type that isn't a subtype of atom.") + "this is the only base type that isn't a subtype of atom.") (VALUES NIL T) (VALUES T T))) ((NOT (OR (EQ SYMBOL-TYPE1 SYMBOL-TYPE2) @@ -918,14 +924,13 @@ ((ARRAY SIMPLE-ARRAY) (IL:* IL:|;;| - "the type will look like (simple-array element-type dimensions)") + "the type will look like (simple-array element-type dimensions)") (XCL:DESTRUCTURING-BIND (ARRAY-TYPE1 ELEMENT-TYPE-1 DIMS-1) TYPE1 (XCL:DESTRUCTURING-BIND (ARRAY-TYPE2 ELEMENT-TYPE-2 DIMS-2) TYPE2 - (IF (AND (EQUAL-ELEMENT-TYPE ELEMENT-TYPE-1 - ELEMENT-TYPE-2) + (IF (AND (EQUAL-ELEMENT-TYPE ELEMENT-TYPE-1 ELEMENT-TYPE-2) (EQUAL-DIMENSIONS DIMS-1 DIMS-2)) (VALUES T T) (VALUES NIL T))))) @@ -940,7 +945,7 @@ (NUMBER (IL:* IL:|;;| - "number doesn't take ranges, there's nothing to verify.") + "number doesn't take ranges, there's nothing to verify.") (VALUES T T)) (OTHERWISE (XCL:DESTRUCTURING-BIND @@ -949,8 +954,8 @@ (XCL:DESTRUCTURING-BIND (NUMERIC-TYPE2 LOW2 HIGH2) TYPE2 - (IF (RANGE<= LOW2 LOW1 HIGH1 - HIGH2 NUMERIC-TYPE1 + (IF (RANGE<= LOW2 LOW1 HIGH1 HIGH2 + NUMERIC-TYPE1 NUMERIC-TYPE2) (VALUES T T) (VALUES NIL T))))))) @@ -1220,7 +1225,7 @@ (DEFTYPE VECTOR (&OPTIONAL ELEMENT-TYPE SIZE) (IL:* IL:|;;| - "this type must be defined in terms of array so that subtypep can reason(?) about them.") + "this type must be defined in terms of array so that subtypep can reason(?) about them.") `(ARRAY ,ELEMENT-TYPE (,SIZE))) @@ -1351,7 +1356,7 @@ (SYMBOL-PACKAGE NAME)))) (IL:* IL:|;;| - "the eval-when insures that the functions in the hash table are always compiled") + "the eval-when insures that the functions in the hash table are always compiled") `(PROGN (EVAL-WHEN (LOAD) (SETF (SYMBOL-FUNCTION ',TYPEP-NAME) @@ -1582,54 +1587,67 @@ (IL:* IL:|;;;| "for TYPE-OF Interlisp types that have different common Lisp names") -(IL:PUTPROPS IL:CHARACTER CMLTYPE CHARACTER) +(IL:PUTPROPS IL:CHARACTER CMLTYPE CHARACTER) -(IL:PUTPROPS IL:FIXP CMLTYPE BIGNUM) +(IL:PUTPROPS IL:FIXP CMLTYPE BIGNUM) -(IL:PUTPROPS IL:FLOATP CMLTYPE SINGLE-FLOAT) +(IL:PUTPROPS IL:FLOATP CMLTYPE SINGLE-FLOAT) -(IL:PUTPROPS IL:GENERAL-ARRAY CMLTYPE ARRAY) +(IL:PUTPROPS IL:GENERAL-ARRAY CMLTYPE ARRAY) -(IL:PUTPROPS IL:LISTP CMLTYPE CONS) +(IL:PUTPROPS IL:LISTP CMLTYPE CONS) -(IL:PUTPROPS IL:LITATOM CMLTYPE SYMBOL) +(IL:PUTPROPS IL:LITATOM CMLTYPE SYMBOL) -(IL:PUTPROPS IL:ONED-ARRAY CMLTYPE ARRAY) +(IL:PUTPROPS IL:ONED-ARRAY CMLTYPE ARRAY) -(IL:PUTPROPS IL:SMALLP CMLTYPE FIXNUM) +(IL:PUTPROPS IL:SMALLP CMLTYPE FIXNUM) -(IL:PUTPROPS IL:HARRAYP CMLTYPE HASH-TABLE) +(IL:PUTPROPS IL:HARRAYP CMLTYPE HASH-TABLE) -(IL:PUTPROPS IL:TWOD-ARRAY CMLTYPE ARRAY) +(IL:PUTPROPS IL:TWOD-ARRAY CMLTYPE ARRAY) -(IL:PUTPROPS SYMBOL CMLSUBTYPE-DESCRIMINATOR SYMBOL-TYPE) +(IL:PUTPROPS SYMBOL CMLSUBTYPE-DESCRIMINATOR SYMBOL-TYPE) -(IL:PUTPROPS ARRAY CMLSUBTYPE-DESCRIMINATOR ARRAY-TYPE) +(IL:PUTPROPS ARRAY CMLSUBTYPE-DESCRIMINATOR ARRAY-TYPE) (IL:* IL:|;;;| "tell the filepkg what to do with the type-expander property") -(IL:PUTPROPS :TYPE-EXPANDER IL:PROPTYPE IGNORE) +(IL:PUTPROPS :TYPE-EXPANDER IL:PROPTYPE IGNORE) -(IL:PUTPROPS IL:TYPE-EXPANDER IL:PROPTYPE IGNORE) +(IL:PUTPROPS IL:TYPE-EXPANDER IL:PROPTYPE IGNORE) (IL:* IL:|;;;| "Compiler options") -(IL:PUTPROPS IL:CMLTYPES IL:FILETYPE COMPILE-FILE) +(IL:PUTPROPS IL:CMLTYPES IL:FILETYPE COMPILE-FILE) -(IL:PUTPROPS IL:CMLTYPES IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP")) +(IL:PUTPROPS IL:CMLTYPES IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP")) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T) ) ) -(IL:PUTPROPS IL:CMLTYPES IL:COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1993)) +(IL:PUTPROPS IL:CMLTYPES IL:COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1993 2024) +) (IL:DECLARE\: IL:DONTCOPY - (IL:FILEMAP (NIL))) + (IL:FILEMAP (NIL (4086 4144 (COMMONP 4086 . 4144)) (4257 6153 (TYPEP 4257 . 6153)) (6155 6504 (TYPE-OF + 6155 . 6504)) (6506 7652 (COERCE 6506 . 7652)) (7654 8477 (TYPECASE 7654 . 8477)) (8479 8916 ( +%VALID-TYPE-P 8479 . 8916)) (12020 12451 (TYPE-EXPAND 12020 . 12451)) (12453 13582 (TYPE-EXPANDER +12453 . 13582)) (13584 13696 (SETF-TYPE-EXPANDER 13584 . 13696)) (13918 15237 (ARRAY-TYPE 13918 . +15237)) (15239 15457 (SYMBOL-TYPE 15239 . 15457)) (15459 15490 (XCL:FALSE 15459 . 15490)) (15492 15520 + (XCL:TRUE 15492 . 15520)) (15522 18961 (%RANGE-TYPE 15522 . 18961)) (18963 19020 (NUMBERP 18963 . +19020)) (19022 19077 (FLOATP 19022 . 19077)) (19555 21413 (%TYPEP-PRED 19555 . 21413)) (21415 21504 ( +BIGNUMP 21415 . 21504)) (23517 31063 (SUBTYPEP 23517 . 31063)) (31065 31379 (SUBTYPEP-TYPE-EXPAND +31065 . 31379)) (31381 31560 (SI::DATATYPE-P 31381 . 31560)) (31562 32330 (SI::SUB-DATATYPE-P 31562 . +32330)) (32332 33015 (EQUAL-DIMENSIONS 32332 . 33015)) (33017 33216 (COMPLETE-ARRAY-TYPE-DIMENSIONS +33017 . 33216)) (33218 34693 (COMPLETE-META-EXPRESSION-DEFAULTS 33218 . 34693)) (34695 36276 (RANGE<= +34695 . 36276)) (36278 42968 (BASE-SUBTYPEP 36278 . 42968)) (42970 43336 (EQUAL-ELEMENT-TYPE 42970 . +43336)) (43338 43672 (USEFUL-TYPE-EXPANSION-P 43338 . 43672))))) IL:STOP diff --git a/sources/CMLTYPES.LCOM b/sources/CMLTYPES.LCOM index 30ae8a1a3..76bd547cd 100644 Binary files a/sources/CMLTYPES.LCOM and b/sources/CMLTYPES.LCOM differ diff --git a/sources/XCL-LOOP b/sources/XCL-LOOP index a6e6ac566..c6a901421 100644 --- a/sources/XCL-LOOP +++ b/sources/XCL-LOOP @@ -1,13 +1,13 @@ (DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "LOOP" (USE "LISP" "XCL")) READTABLE "XCL" BASE 10) -(il:filecreated " 8-Apr-2024 19:38:27" il:|{DSK}larry>il>medley>sources>XCL-LOOP.;13| 61862 +(il:filecreated "14-Jun-2024 23:09:54" il:|{DSK}matt>Interlisp>medley>sources>XCL-LOOP.;4| 62255 - :edit-by "lmm" + :edit-by "mth" - :changes-to (il:vars il:xcl-loopcoms) - (il:functions cl::symbol-macrolet with-list-accumulator) + :changes-to (il:functions default-type default-value) - :previous-date " 2-Apr-2024 15:08:27" il:|{DSK}larry>il>medley>sources>XCL-LOOP.;12|) + :previous-date " 8-Apr-2024 19:38:27" il:|{DSK}matt>Interlisp>medley>sources>XCL-LOOP.;2| +) (il:prettycomprint il:xcl-loopcoms) @@ -476,8 +476,12 @@ (dig d-type-spec d-var-spec) bindings))) -(defun default-type (type) - (if (eq type t) +(defun default-type (type) (il:* il:\; "Edited 13-Jun-2024 20:05 by mth") + + (il:* il:|;;| "Probably shouldn't ever happen, but if TYPE is NIL") + + (if (or (null type) + (eq type t)) t (let ((value (default-value type))) (if (typep value type) @@ -489,8 +493,13 @@ `(or null ,type) `(or ,default-type ,type)))))))) -(defun default-value (type) +(defun default-value (type) (il:* il:\; "Edited 13-Jun-2024 20:31 by mth") (cond + ((null type) + + (il:* il:|;;| "giving NIL specifically as the VAR type probably shouldn't happen, but seems to be \"legal\", so handle it") + + nil) ((subtypep type 'bignum) (1+ most-positive-fixnum)) ((subtypep type 'integer) @@ -1389,7 +1398,7 @@ (il:putprops il:xcl-loop il:copyright (("Interlisp.org" 2004) ("Yuji Minejima ") - 2002 2004)) + 2002 2004 2024)) (il:putprops il:xcl-loop il:license "See COPYRIGHT and LICENSE in the repository ;; $Id: loop.lisp,v 1.38 2005/04/16 07:34:27 yuji Exp $ @@ -1417,56 +1426,56 @@ ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.") (il:declare\: il:dontcopy - (il:filemap (nil (6825 6910 (%keyword 6825 . 6910)) (6912 7095 (%list 6912 . 7095)) (7097 8354 ( -accumulate-in-list 7097 . 8354)) (8356 10036 (accumulation-clause 8356 . 10036)) (10038 10272 ( -accumulator-kind 10038 . 10272)) (10274 12163 (accumulator-spec 10274 . 12163)) (12165 12634 ( -along-with 12165 . 12634)) (12636 13128 (always-never-thereis-clause 12636 . 13128)) (13130 13489 ( -ambiguous-loop-result-error 13130 . 13489)) (13491 13706 (append-context 13491 . 13706)) (13785 14162 -(bindings 13785 . 14162)) (14164 14504 (bound-variables 14164 . 14504)) (14506 14596 (by-step-fun -14506 . 14596)) (14598 14704 (car-type 14598 . 14704)) (14706 14812 (cdr-type 14706 . 14812)) (14814 -15211 (check-multiple-bindings 14814 . 15211)) (15213 15433 (cl-external-p 15213 . 15433)) (15435 -15564 (clause* 15435 . 15564)) (15566 15966 (clause1 15566 . 15966)) (15968 16125 (compound-forms* -15968 . 16125)) (16127 16251 (compound-forms+ 16127 . 16251)) (16253 17511 (conditional-clause 16253 - . 17511)) (17513 18224 (constant-bindings 17513 . 18224)) (18226 18597 (constant-function-p 18226 . -18597)) (18599 18793 (constant-vector 18599 . 18793)) (18795 18886 (constant-vector-p 18795 . 18886)) -(18888 19080 (d-var-spec-p 18888 . 19080)) (19082 19312 (d-var-spec1 19082 . 19312)) (19314 19639 ( -d-var-type-spec 19314 . 19639)) (19641 20201 (declarations 19641 . 20201)) (20203 20313 ( -default-binding 20203 . 20313)) (20315 20928 (default-bindings 20315 . 20928)) (20930 21391 ( -default-type 20930 . 21391)) (21393 21914 (default-value 21393 . 21914)) (21916 23406 ( -destructuring-multiple-value-bind 21916 . 23406)) (23408 24693 (destructuring-multiple-value-setq -23408 . 24693)) (24695 25222 (dispatch-for-as-subclause 24695 . 25222)) (25224 25293 (do-clause 25224 - . 25293)) (25295 25471 (empty-p 25295 . 25471)) (25473 25747 (enumerate 25473 . 25747)) (25749 27475 -(extended-loop 25749 . 27475)) (27477 27648 (fill-in 27477 . 27648)) (27650 27727 (finally-clause -27650 . 27727)) (27729 27847 (for 27729 . 27847)) (27849 29205 (for-as-across-subclause 27849 . 29205) -) (29207 30129 (for-as-arithmetic-possible-prepositions 29207 . 30129)) (30131 30847 ( -for-as-arithmetic-step-and-test-functions 30131 . 30847)) (30849 32794 (for-as-arithmetic-subclause -30849 . 32794)) (32796 33246 (for-as-being-subclause 32796 . 33246)) (33248 34464 (for-as-clause 33248 - . 34464)) (34466 35994 (for-as-equals-then-subclause 34466 . 35994)) (35996 36274 (for-as-fill-in -35996 . 36274)) (36276 38242 (for-as-hash-subclause 36276 . 38242)) (38244 38490 ( -for-as-in-list-subclause 38244 . 38490)) (38492 39985 (for-as-on-list-subclause 38492 . 39985)) (39987 - 41689 (for-as-package-subclause 39987 . 41689)) (41691 41922 (for-as-parallel-p 41691 . 41922)) ( -41924 42072 (form-or-it 41924 . 42072)) (42074 42193 (form1 42074 . 42193)) (42195 42295 ( -gensym-ignorable 42195 . 42295)) (42297 42408 (globally-special-p 42297 . 42408)) (42410 42589 ( -hash-d-var-spec 42410 . 42589)) (42591 42672 (initially-clause 42591 . 42672)) (42674 42831 ( -invalid-accumulator-combination-error 42674 . 42831)) (42833 43450 (keyword1 42833 . 43450)) (43452 -43922 (keyword? 43452 . 43922)) (43924 44033 (let-form 43924 . 44033)) (44035 44189 (loop-error 44035 - . 44189)) (44191 44382 (loop-finish-test-forms 44191 . 44382)) (44384 44536 (loop-warn 44384 . 44536) -) (44538 44742 (lp 44538 . 44742)) (44744 45181 (main-clause* 44744 . 45181)) (45183 45279 (mapappend -45183 . 45279)) (45281 45811 (multiple-value-list-argument-form 45281 . 45811)) (45813 46206 ( -multiple-value-list-form-p 45813 . 46206)) (46208 46546 (name-clause? 46208 . 46546)) (46548 46827 ( -one 46548 . 46827)) (46829 48474 (ordinary-bindings 46829 . 48474)) (48476 48693 (preposition1 48476 - . 48693)) (48695 48896 (preposition? 48695 . 48896)) (48898 49058 (psetq-forms 48898 . 49058)) (49060 - 49240 (quoted-form-p 49060 . 49240)) (49242 49497 (quoted-object 49242 . 49497)) (49499 50303 ( -reduce-redundant-code 49499 . 50303)) (50305 50534 (repeat-clause 50305 . 50534)) (50536 50626 ( -return-clause 50536 . 50626)) (50628 51463 (selectable-clause 50628 . 51463)) (51465 51616 ( -simple-loop 51465 . 51616)) (51618 51696 (simple-var-p 51618 . 51696)) (51698 51882 (simple-var1 51698 - . 51882)) (51884 51991 (stray-of-type-error 51884 . 51991)) (51993 52278 (cl::symbol-macrolet 51993 - . 52278)) (52280 52714 (type-spec? 52280 . 52714)) (52716 52782 (until-clause 52716 . 52782)) (52784 -53365 (using-other-var 52784 . 53365)) (53367 53561 (variable-clause* 53367 . 53561)) (53563 53667 ( -while-clause 53563 . 53667)) (53669 53848 (with 53669 . 53848)) (53850 54295 (with-accumulators 53850 - . 54295)) (54297 54547 (with-binding-forms 54297 . 54547)) (54549 55780 (with-clause 54549 . 55780)) -(55782 56041 (with-iterator-forms 55782 . 56041)) (56043 57190 (with-list-accumulator 56043 . 57190)) -(57192 57629 (with-loop-context 57192 . 57629)) (57631 58869 (with-numeric-accumulator 57631 . 58869)) - (58871 59392 (with-temporaries 58871 . 59392)) (59394 59674 (zero 59394 . 59674)) (59676 59809 (loop -59676 . 59809))))) + (il:filemap (nil (6777 6862 (%keyword 6777 . 6862)) (6864 7047 (%list 6864 . 7047)) (7049 8306 ( +accumulate-in-list 7049 . 8306)) (8308 9988 (accumulation-clause 8308 . 9988)) (9990 10224 ( +accumulator-kind 9990 . 10224)) (10226 12115 (accumulator-spec 10226 . 12115)) (12117 12586 ( +along-with 12117 . 12586)) (12588 13080 (always-never-thereis-clause 12588 . 13080)) (13082 13441 ( +ambiguous-loop-result-error 13082 . 13441)) (13443 13658 (append-context 13443 . 13658)) (13737 14114 +(bindings 13737 . 14114)) (14116 14456 (bound-variables 14116 . 14456)) (14458 14548 (by-step-fun +14458 . 14548)) (14550 14656 (car-type 14550 . 14656)) (14658 14764 (cdr-type 14658 . 14764)) (14766 +15163 (check-multiple-bindings 14766 . 15163)) (15165 15385 (cl-external-p 15165 . 15385)) (15387 +15516 (clause* 15387 . 15516)) (15518 15918 (clause1 15518 . 15918)) (15920 16077 (compound-forms* +15920 . 16077)) (16079 16203 (compound-forms+ 16079 . 16203)) (16205 17463 (conditional-clause 16205 + . 17463)) (17465 18176 (constant-bindings 17465 . 18176)) (18178 18549 (constant-function-p 18178 . +18549)) (18551 18745 (constant-vector 18551 . 18745)) (18747 18838 (constant-vector-p 18747 . 18838)) +(18840 19032 (d-var-spec-p 18840 . 19032)) (19034 19264 (d-var-spec1 19034 . 19264)) (19266 19591 ( +d-var-type-spec 19266 . 19591)) (19593 20153 (declarations 19593 . 20153)) (20155 20265 ( +default-binding 20155 . 20265)) (20267 20880 (default-bindings 20267 . 20880)) (20882 21530 ( +default-type 20882 . 21530)) (21532 22302 (default-value 21532 . 22302)) (22304 23794 ( +destructuring-multiple-value-bind 22304 . 23794)) (23796 25081 (destructuring-multiple-value-setq +23796 . 25081)) (25083 25610 (dispatch-for-as-subclause 25083 . 25610)) (25612 25681 (do-clause 25612 + . 25681)) (25683 25859 (empty-p 25683 . 25859)) (25861 26135 (enumerate 25861 . 26135)) (26137 27863 +(extended-loop 26137 . 27863)) (27865 28036 (fill-in 27865 . 28036)) (28038 28115 (finally-clause +28038 . 28115)) (28117 28235 (for 28117 . 28235)) (28237 29593 (for-as-across-subclause 28237 . 29593) +) (29595 30517 (for-as-arithmetic-possible-prepositions 29595 . 30517)) (30519 31235 ( +for-as-arithmetic-step-and-test-functions 30519 . 31235)) (31237 33182 (for-as-arithmetic-subclause +31237 . 33182)) (33184 33634 (for-as-being-subclause 33184 . 33634)) (33636 34852 (for-as-clause 33636 + . 34852)) (34854 36382 (for-as-equals-then-subclause 34854 . 36382)) (36384 36662 (for-as-fill-in +36384 . 36662)) (36664 38630 (for-as-hash-subclause 36664 . 38630)) (38632 38878 ( +for-as-in-list-subclause 38632 . 38878)) (38880 40373 (for-as-on-list-subclause 38880 . 40373)) (40375 + 42077 (for-as-package-subclause 40375 . 42077)) (42079 42310 (for-as-parallel-p 42079 . 42310)) ( +42312 42460 (form-or-it 42312 . 42460)) (42462 42581 (form1 42462 . 42581)) (42583 42683 ( +gensym-ignorable 42583 . 42683)) (42685 42796 (globally-special-p 42685 . 42796)) (42798 42977 ( +hash-d-var-spec 42798 . 42977)) (42979 43060 (initially-clause 42979 . 43060)) (43062 43219 ( +invalid-accumulator-combination-error 43062 . 43219)) (43221 43838 (keyword1 43221 . 43838)) (43840 +44310 (keyword? 43840 . 44310)) (44312 44421 (let-form 44312 . 44421)) (44423 44577 (loop-error 44423 + . 44577)) (44579 44770 (loop-finish-test-forms 44579 . 44770)) (44772 44924 (loop-warn 44772 . 44924) +) (44926 45130 (lp 44926 . 45130)) (45132 45569 (main-clause* 45132 . 45569)) (45571 45667 (mapappend +45571 . 45667)) (45669 46199 (multiple-value-list-argument-form 45669 . 46199)) (46201 46594 ( +multiple-value-list-form-p 46201 . 46594)) (46596 46934 (name-clause? 46596 . 46934)) (46936 47215 ( +one 46936 . 47215)) (47217 48862 (ordinary-bindings 47217 . 48862)) (48864 49081 (preposition1 48864 + . 49081)) (49083 49284 (preposition? 49083 . 49284)) (49286 49446 (psetq-forms 49286 . 49446)) (49448 + 49628 (quoted-form-p 49448 . 49628)) (49630 49885 (quoted-object 49630 . 49885)) (49887 50691 ( +reduce-redundant-code 49887 . 50691)) (50693 50922 (repeat-clause 50693 . 50922)) (50924 51014 ( +return-clause 50924 . 51014)) (51016 51851 (selectable-clause 51016 . 51851)) (51853 52004 ( +simple-loop 51853 . 52004)) (52006 52084 (simple-var-p 52006 . 52084)) (52086 52270 (simple-var1 52086 + . 52270)) (52272 52379 (stray-of-type-error 52272 . 52379)) (52381 52666 (cl::symbol-macrolet 52381 + . 52666)) (52668 53102 (type-spec? 52668 . 53102)) (53104 53170 (until-clause 53104 . 53170)) (53172 +53753 (using-other-var 53172 . 53753)) (53755 53949 (variable-clause* 53755 . 53949)) (53951 54055 ( +while-clause 53951 . 54055)) (54057 54236 (with 54057 . 54236)) (54238 54683 (with-accumulators 54238 + . 54683)) (54685 54935 (with-binding-forms 54685 . 54935)) (54937 56168 (with-clause 54937 . 56168)) +(56170 56429 (with-iterator-forms 56170 . 56429)) (56431 57578 (with-list-accumulator 56431 . 57578)) +(57580 58017 (with-loop-context 57580 . 58017)) (58019 59257 (with-numeric-accumulator 58019 . 59257)) + (59259 59780 (with-temporaries 59259 . 59780)) (59782 60062 (zero 59782 . 60062)) (60064 60197 (loop +60064 . 60197))))) il:stop diff --git a/sources/XCL-LOOP.DFASL b/sources/XCL-LOOP.DFASL index ff0bfa60a..7a16e7c7f 100644 Binary files a/sources/XCL-LOOP.DFASL and b/sources/XCL-LOOP.DFASL differ