github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-01-12 00:42:56 +00:00
Code Issues Projects Releases Wiki Activity

Fix issue #1749 - type-of NIL doesn't match CLtL2 (#1753)

Browse Source 
* Fix issue #1749 - type-of NIL doesn't match CLtL2

* Fix uses of cl:type-of in the LOOP macro to deal with the change to cl:type-of.
This commit is contained in:
Matt Heffron 2024-06-16 21:36:37 -07:00 committed by GitHub
parent 9e0fdd0283
commit 7dcc200c91
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
4 changed files with 177 additions and 150 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

196
sources/CMLTYPES
View File

@ -1,15 +1,20 @@
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP")
(IL:FILECREATED " 4-Jan-93 17:55:42" IL:|{DSK}<python>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}<python>lde>lispcore>sources>CMLTYPES.;1|
(IL:FILECREATED " 4-Jun-2024 23:32:50" IL:|{DSK}<home>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}<home>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

BIN
sources/CMLTYPES.LCOM
View File

Binary file not shown.

131
sources/XCL-LOOP
View File

@ -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}<home>larry>il>medley>sources>XCL-LOOP.;13| 61862
(il:filecreated "14-Jun-2024 23:09:54" il:|{DSK}<home>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}<home>larry>il>medley>sources>XCL-LOOP.;12|)
:previous-date " 8-Apr-2024 19:38:27" il:|{DSK}<home>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 <ggb01164@nifty.ne.jp>")
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

BIN
sources/XCL-LOOP.DFASL
View File

Binary file not shown.