From 3e0882d5f82f4fcc12c75eb16355fb8a55f88b02 Mon Sep 17 00:00:00 2001 From: Blake McBride Date: Sat, 18 Apr 2026 14:30:56 -0500 Subject: [PATCH 1/3] Fix MAKE-LOAD-FORM data-flow ordering in the file compiler --- src/org/armedbear/lisp/Load.java | 13 +- src/org/armedbear/lisp/compile-file.lisp | 29 ++- src/org/armedbear/lisp/dump-form.lisp | 246 ++++++++++++++++++++++- 3 files changed, 274 insertions(+), 14 deletions(-) diff --git a/src/org/armedbear/lisp/Load.java b/src/org/armedbear/lisp/Load.java index db9290743..cce8e7286 100644 --- a/src/org/armedbear/lisp/Load.java +++ b/src/org/armedbear/lisp/Load.java @@ -394,7 +394,7 @@ public static final LispObject loadSystemFile(final String filename, // ### *fasl-version* // internal symbol static final Symbol _FASL_VERSION_ = - exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(43)); + exportConstant("*FASL-VERSION*", PACKAGE_SYS, Fixnum.getInstance(44)); // ### *fasl-external-format* // internal symbol @@ -413,6 +413,16 @@ public static final LispObject loadSystemFile(final String filename, public static final Symbol _FASL_UNINTERNED_SYMBOLS_ = internSpecial("*FASL-UNINTERNED-SYMBOLS*", PACKAGE_SYS, NIL); + // ### *fasl-instances* + /** + * Per-FASL vector of literal instances created by MAKE-LOAD-FORM. + * Bound to NIL upon FASL load; set to a fresh vector by a form + * emitted in the FASL prologue, then populated by creation forms + * emitted by the file compiler. + */ + public static final Symbol _FASL_INSTANCES_ = + internSpecial("*FASL-INSTANCES*", PACKAGE_SYS, NIL); + // Function to access the uninterned symbols "array" public final static LispObject getUninternedSymbol(int n) { LispThread thread = LispThread.currentThread(); @@ -453,6 +463,7 @@ public LispObject execute(LispObject first, LispObject second) if (second.eql(_FASL_VERSION_.getSymbolValue())) { // OK thread.bindSpecial(_FASL_UNINTERNED_SYMBOLS_, NIL); + thread.bindSpecial(_FASL_INSTANCES_, NIL); thread.bindSpecial(_SOURCE_, NIL); return faslLoadStream(thread); } diff --git a/src/org/armedbear/lisp/compile-file.lisp b/src/org/armedbear/lisp/compile-file.lisp index 94f31969a..08392bc43 100644 --- a/src/org/armedbear/lisp/compile-file.lisp +++ b/src/org/armedbear/lisp/compile-file.lisp @@ -146,19 +146,17 @@ zero-length jvm classfile corresponding to ~A." classfile) (defun output-form (form) (if *binary-fasls* (push form *forms-for-output*) - (progn - (dump-form form *fasl-stream*) - (%stream-terpri *fasl-stream*)))) + (%fasl-emit-toplevel-form form *fasl-stream*))) (defun finalize-fasl-output () (when *binary-fasls* (let ((*package* (find-package :keyword)) (*double-colon-package-separators* T)) - (dump-form (convert-toplevel-form (list* 'PROGN - (nreverse *forms-for-output*)) - t) - *fasl-stream*)) - (%stream-terpri *fasl-stream*))) + (%fasl-emit-toplevel-form + (convert-toplevel-form (list* 'PROGN + (nreverse *forms-for-output*)) + t) + *fasl-stream*)))) (declaim (ftype (function (t) t) simple-toplevel-form-p)) @@ -811,6 +809,13 @@ COMPILE-FILE was invoked." :stream out :length nil)) (%stream-terpri out) + (when (and (boundp '*fasl-instance-count*) + (plusp *fasl-instance-count*)) + (write (list 'cl:setq 'sys::*fasl-instances* + (list 'cl:make-array *fasl-instance-count*)) + :stream out) + (%stream-terpri out)) + (when (> *class-number* 0) (write (list 'cl:setq 'sys:*fasl-loader* `(sys::make-fasl-class-loader @@ -840,6 +845,14 @@ COMPILE-FILE was invoked." (namestring (namestring *compile-file-truename*)) (start (get-internal-real-time)) *fasl-uninterned-symbols* + (*fasl-instance-table* (make-hash-table :test 'eq)) + (*fasl-instance-forms* (make-hash-table :test 'eq)) + (*fasl-instance-refs* (make-hash-table :test 'eq)) + (*fasl-instance-created-p* (make-hash-table :test 'eq)) + (*fasl-instance-initialized-p* (make-hash-table :test 'eq)) + (*fasl-instance-in-creation-p* (make-hash-table :test 'eq)) + (*fasl-instance-in-init-p* (make-hash-table :test 'eq)) + (*fasl-instance-count* 0) (warnings-p nil) (in-package *package*) (failure-p nil)) diff --git a/src/org/armedbear/lisp/dump-form.lisp b/src/org/armedbear/lisp/dump-form.lisp index c1c8ae911..7307f5b7f 100644 --- a/src/org/armedbear/lisp/dump-form.lisp +++ b/src/org/armedbear/lisp/dump-form.lisp @@ -31,12 +31,228 @@ (in-package "SYSTEM") -(export '(dump-form dump-uninterned-symbol-index)) +(export '(dump-form dump-uninterned-symbol-index + %fasl-emit-toplevel-form + %fasl-init-instance-tables + *fasl-instance-count* + *fasl-stream*)) -(declaim (special *circularity* *circle-counter* *instance-forms*)) +(declaim (special *circularity* *circle-counter* *instance-forms* + *fasl-instance-table* + *fasl-instance-forms* + *fasl-instance-refs* + *fasl-instance-created-p* + *fasl-instance-initialized-p* + *fasl-instance-in-creation-p* + *fasl-instance-in-init-p* + *fasl-instance-count* + *fasl-emitting-to-fasl-stream* + *fasl-stream*)) +(defvar *fasl-emitting-to-fasl-stream* nil + "Bound to T while DUMP-FORM / %FASL-WRITE-RAW-FORM are writing +material destined for the fasl stream. When NIL, DUMP-INSTANCE and +DF-CHECK-INSTANCE fall back to inline creation/initialization.") + +;;;; MAKE-LOAD-FORM ordering for the file compiler. +;;;; +;;;; CLHS requires creation and initialization forms from MAKE-LOAD-FORM +;;;; to be dumped so that data-flow dependencies are honored: any object +;;;; referenced in a creation form must already exist, and initialization +;;;; forms run "as soon as possible" after their associated creation form +;;;; subject to the dependencies of the initialization form. +;;;; +;;;; We implement this by tracking referenced instances file-wide. For +;;;; each literal instance we emit two separate fasl top-level forms: +;;;; +;;;; (SETF (SVREF SYS::*FASL-INSTANCES* N) ) +;;;; +;;;; +;;;; and replace the original inline reference to the instance with +;;;; "#.(SVREF SYS::*FASL-INSTANCES* N)". The prologue allocates the +;;;; vector once the total count is known. + +(defun %fasl-candidate-p (object) + (or (structure-object-p object) + (standard-object-p object) + (java:java-object-p object))) + +(defun %fasl-init-instance-tables () + (setq *fasl-instance-table* (make-hash-table :test 'eq) + *fasl-instance-forms* (make-hash-table :test 'eq) + *fasl-instance-refs* (make-hash-table :test 'eq) + *fasl-instance-created-p* (make-hash-table :test 'eq) + *fasl-instance-initialized-p* (make-hash-table :test 'eq) + *fasl-instance-in-creation-p* (make-hash-table :test 'eq) + *fasl-instance-in-init-p* (make-hash-table :test 'eq) + *fasl-instance-count* 0)) + +(defun %fasl-register-instance (object) + "Assign an index to OBJECT, caching its creation and initialization +forms. Returns the index." + (or (gethash object *fasl-instance-table*) + (multiple-value-bind (creation-form initialization-form) + (make-load-form object) + (let ((index *fasl-instance-count*)) + (setf (gethash object *fasl-instance-table*) index) + (setf (gethash object *fasl-instance-forms*) + (cons creation-form initialization-form)) + (setf (gethash object *fasl-instance-refs*) + (list 'svref 'sys::*fasl-instances* index)) + (incf *fasl-instance-count*) + index)))) + +(declaim (ftype (function (t stream) t) + %fasl-walk-for-deps + %fasl-walk-creation-deps + %fasl-walk-init-deps + %fasl-ensure-created + %fasl-ensure-initialized)) + +(defun %fasl-map-embedded-instances (form fn) + "Call FN on every literal instance embedded in FORM, without +revisiting already-seen subobjects." + (let ((seen (make-hash-table :test #'eq))) + (labels ((walk (x) + (unless (or (null x) + (symbolp x) + (numberp x) + (characterp x) + (stringp x) + (bit-vector-p x) + (gethash x seen)) + (setf (gethash x seen) t) + (cond + ((consp x) + (walk (car x)) + (walk (cdr x))) + ((vectorp x) + (dotimes (i (length x)) (walk (aref x i)))) + ((%fasl-candidate-p x) + (funcall fn x)))))) + (walk form)))) + +(defun %fasl-walk-creation-deps (form stream) + "Ensure creation forms are emitted for every instance embedded in +FORM (creation-dep transitive closure)." + (%fasl-map-embedded-instances form + (lambda (x) (%fasl-ensure-created x stream)))) + +(defun %fasl-walk-init-deps (form stream) + "Ensure full init forms (and their creation prerequisites) are +emitted for every instance embedded in FORM." + (%fasl-map-embedded-instances form + (lambda (x) (%fasl-ensure-initialized x stream)))) + +(defun %fasl-walk-for-deps (form stream) + "Drive the two-phase dep walk for a top-level FORM: ensure every +embedded literal instance is fully created *and* initialized before +FORM is emitted." + (%fasl-walk-init-deps form stream)) + +(defun %fasl-init-deps-ready-p (object) + "Return T if every literal instance embedded in OBJECT's init form +is already initialized (ignoring OBJECT itself). This decides whether +we can run OBJECT's init form eagerly, right after its creation, per +the CLHS ASAP rule for init forms." + (let ((init-form (cdr (gethash object *fasl-instance-forms*))) + (ready t)) + (%fasl-map-embedded-instances + init-form + (lambda (y) + (unless (or (eq y object) + (gethash y *fasl-instance-initialized-p*)) + (setf ready nil)))) + ready)) + +(defun %fasl-ensure-created (object stream) + "Emit OBJECT's creation form (after its creation-dep transitive +closure) if not already emitted. After emission, eagerly emit +OBJECT's init form when all its init-deps are already initialized, so +inits run ASAP after creation per CLHS." + (unless (and *fasl-instance-table* (%fasl-candidate-p object)) + (return-from %fasl-ensure-created)) + (let ((index (%fasl-register-instance object))) + (when (gethash object *fasl-instance-created-p*) + (return-from %fasl-ensure-created)) + (when (gethash object *fasl-instance-in-creation-p*) + (error "Circular creation dependency in MAKE-LOAD-FORM for ~S" + object)) + (setf (gethash object *fasl-instance-in-creation-p*) t) + (let ((creation-form (car (gethash object *fasl-instance-forms*)))) + (%fasl-walk-creation-deps creation-form stream) + (%fasl-write-raw-form + `(setf (svref sys::*fasl-instances* ,index) ,creation-form) + stream)) + (setf (gethash object *fasl-instance-created-p*) t) + (remhash object *fasl-instance-in-creation-p*) + (when (%fasl-init-deps-ready-p object) + (%fasl-ensure-initialized object stream)))) + +(defun %fasl-ensure-initialized (object stream) + "Emit OBJECT's init form (after ensuring OBJECT is created and after +recursing through init-dep transitive closure) if not already emitted." + (unless (and *fasl-instance-table* (%fasl-candidate-p object)) + (return-from %fasl-ensure-initialized)) + (%fasl-ensure-created object stream) + (when (gethash object *fasl-instance-initialized-p*) + (return-from %fasl-ensure-initialized)) + (when (gethash object *fasl-instance-in-init-p*) + ;; In-progress init cycle: some earlier frame is already emitting + ;; OBJECT's init form. Per CLHS the ordering is unspecified for + ;; init-level cycles; break here. + (return-from %fasl-ensure-initialized)) + (setf (gethash object *fasl-instance-in-init-p*) t) + (let ((init-form (cdr (gethash object *fasl-instance-forms*)))) + (when init-form + (%fasl-walk-init-deps init-form stream) + (%fasl-write-raw-form init-form stream))) + (setf (gethash object *fasl-instance-initialized-p*) t) + (remhash object *fasl-instance-in-init-p*)) + +(defun %fasl-ensure-created-and-initialized (object stream) + "Compatibility shim retained for any external callers." + (%fasl-ensure-initialized object stream)) + +(defun %fasl-write-raw-form (form stream) + "Dump FORM as a complete fasl top-level expression without running +the dependency walk (the caller has already emitted deps)." + (let ((*print-fasl* t) + (*print-array* t) + (*print-base* 10) + (*print-case* :upcase) + (*print-circle* nil) + (*print-escape* t) + (*print-gensym* t) + (*print-length* nil) + (*print-level* nil) + (*print-lines* nil) + (*print-pretty* nil) + (*print-radix* nil) + (*print-right-margin* nil) + (*print-structure* t) + (*readtable* *the-fasl-printer-readtable*) + (*read-default-float-format* nil) + (*circularity* (make-hash-table :test #'eq)) + (*instance-forms* (make-hash-table :test #'eq)) + (*circle-counter* 0) + (*fasl-emitting-to-fasl-stream* t)) + (unless *prevent-fasl-circle-detection* + (df-check-object form)) + (dump-object form stream) + (%stream-terpri stream))) + +(defun %fasl-emit-toplevel-form (form stream) + "Public entry: emit FORM to the fasl STREAM, first pre-emitting any +creation and initialization forms required by embedded literal +instances." + (%fasl-walk-for-deps form stream) + (%fasl-write-raw-form form stream)) (defun get-instance-form (object) + "Legacy inline creation-plus-init expression for literal instances. +Used when dumping outside the fasl-stream context (e.g. embedding +constants into class files via SERIALIZE-OBJECT)." (multiple-value-bind (value presence) (gethash object *instance-forms*) @@ -83,7 +299,15 @@ (df-check-object (aref object index)))) (defun df-check-instance (object) - (df-check-object (get-instance-form object))) + (let ((ref (and *fasl-emitting-to-fasl-stream* + *fasl-instance-refs* + (gethash object *fasl-instance-refs*)))) + (if ref + ;; New fasl path: DUMP-INSTANCE will emit this exact ref cons; + ;; walk it here so the same cons is registered in *circularity* + ;; before DUMP-OBJECT reaches it. + (df-check-object ref) + (df-check-object (get-instance-form object))))) (defun df-check-object (object) (unless (eq :circular (df-register-circularity object)) @@ -164,8 +388,20 @@ (declaim (ftype (function (t stream) t) dump-instance)) (defun dump-instance (object stream) - (write-string "#." stream) - (dump-object (get-instance-form object) stream)) + (let ((ref (and *fasl-emitting-to-fasl-stream* + *fasl-instance-refs* + (gethash object *fasl-instance-refs*)))) + (cond + (ref + ;; File-compiler path: emit a reference to the pre-populated + ;; per-fasl instance table. + (write-string "#." stream) + (dump-object ref stream)) + (t + ;; Legacy path: inline creation and initialization at the + ;; point of reference. + (write-string "#." stream) + (dump-object (get-instance-form object) stream))))) (declaim (ftype (function (symbol) integer) dump-uninterned-symbol-index)) (defun dump-uninterned-symbol-index (symbol) From c4592c990bbf07b26cad32c735839b097790d9b8 Mon Sep 17 00:00:00 2001 From: Blake McBride Date: Sat, 18 Apr 2026 16:27:17 -0500 Subject: [PATCH 2/3] Fix CLOS, MAKE-LOAD-FORM, and TYPE-OF ANSI test failures --- .../lisp/FuncallableStandardObject.java | 13 +- src/org/armedbear/lisp/NilVector.java | 12 ++ src/org/armedbear/lisp/clos.lisp | 164 ++++++++++++++---- src/org/armedbear/lisp/compiler-pass2.lisp | 5 +- src/org/armedbear/lisp/defstruct.lisp | 24 +++ src/org/armedbear/lisp/subtypep.lisp | 3 +- 6 files changed, 177 insertions(+), 44 deletions(-) diff --git a/src/org/armedbear/lisp/FuncallableStandardObject.java b/src/org/armedbear/lisp/FuncallableStandardObject.java index c11c57bbd..7a9c3b718 100644 --- a/src/org/armedbear/lisp/FuncallableStandardObject.java +++ b/src/org/armedbear/lisp/FuncallableStandardObject.java @@ -76,13 +76,14 @@ protected FuncallableStandardObject(LispClass cls) @Override public LispObject typep(LispObject type) { + // A funcallable-standard-object (e.g. a generic function) is not + // itself a COMPILED-FUNCTION regardless of whether its installed + // dispatcher function happens to be compiled: COMPILED-FUNCTION + // characterizes the object, not an internal implementation detail. + // Returning T here breaks TYPE-OF invariants (SUBTYPEP of the + // object's type would have to cover COMPILED-FUNCTION). if (type == Symbol.COMPILED_FUNCTION) - { - if (function != null) - return function.typep(type); - else - return NIL; - } + return NIL; if (type == Symbol.FUNCALLABLE_STANDARD_OBJECT) return T; if (type == StandardClass.FUNCALLABLE_STANDARD_OBJECT) diff --git a/src/org/armedbear/lisp/NilVector.java b/src/org/armedbear/lisp/NilVector.java index 6d8740899..ba369ff69 100644 --- a/src/org/armedbear/lisp/NilVector.java +++ b/src/org/armedbear/lisp/NilVector.java @@ -95,6 +95,18 @@ public LispObject typep(LispObject type) return T; if (type == BuiltInClass.SIMPLE_ARRAY) return T; + // A NIL-vector has upgraded element type NIL, which is a distinct + // array specialization from BASE-STRING's (vector base-char). Per + // CLHS type upgrading rules these specializations are disjoint, so + // NIL-VECTOR is *not* a BASE-STRING. + if (type == Symbol.BASE_STRING) + return NIL; + if (type == BuiltInClass.BASE_STRING) + return NIL; + if (type == Symbol.SIMPLE_BASE_STRING) + return NIL; + if (type == BuiltInClass.SIMPLE_BASE_STRING) + return NIL; return super.typep(type); } diff --git a/src/org/armedbear/lisp/clos.lisp b/src/org/armedbear/lisp/clos.lisp index 4ac5b68b0..6e023d28e 100644 --- a/src/org/armedbear/lisp/clos.lisp +++ b/src/org/armedbear/lisp/clos.lisp @@ -1175,8 +1175,8 @@ Will not modify existing classes to avoid breaking std-generic-function-p." (loop for item in ',selecters thereis (method-group-p item qualifiers))) :description ',description - :order ',order - :required ',required-p + :order ,order + :required ,required-p :*-selecter ,(equal selecters '(*))))) (defun extract-required-part (lambda-list) @@ -1359,52 +1359,60 @@ Will not modify existing classes to avoid breaking std-generic-function-p." and i upfrom 0 for supplied-binding = (or supplied-var (gensym)) for var-binding = (gensym) - ;; check for excess parameters - ;; only assign initform if the parameter - ;; isn't in excess: the spec says explicitly - ;; to bind parameters in excess to forms evaluating - ;; to nil. - ;; This leaves initforms to be used with - ;; parameters not supplied in excess, but - ;; not available in the arguments list - ;; - ;; Also, if specified, bind "supplied-p" + ;; Optional parameters in excess of the + ;; generic function's optional parameters + ;; are bound to their initforms; their + ;; supplied-p parameters are bound to nil. + ;; Optional parameters within range use the + ;; usual supplied-p/initform protocol at + ;; effective-method invocation time. collect `(,supplied-binding - (when (< ,i nopt) - (setq ,needs-args-len-var t) + (cond ((< ,i nopt) + (setq ,needs-args-len-var t) ;; ### TODO: use a fresh symbol for the supplied binding ;; binding being generated and pushed into binding-forms - (push `(,',supplied-binding - (< ,(+ ,i nreq) ,',args-len-var)) - ,binding-forms) - ',supplied-binding)) - collect `(,var (when (< ,i nopt) - (push `(,',var-binding - (if ,',supplied-binding - (nth ,(+ ,i nreq) - ,',args-var) - ,',initform)) + (push `(,',supplied-binding + (< ,(+ ,i nreq) ,',args-len-var)) ,binding-forms) - ',var-binding))) + ',supplied-binding) + (t + (push `(,',supplied-binding nil) + ,binding-forms) + ',supplied-binding))) + collect `(,var (cond ((< ,i nopt) + (push `(,',var-binding + (if ,',supplied-binding + (nth ,(+ ,i nreq) + ,',args-var) + ,',initform)) + ,binding-forms) + ',var-binding) + (t + (push `(,',var-binding ,',initform) + ,binding-forms) + ',var-binding)))) ,@(loop for ((key var) initform supplied-var) in keys for supplied-binding = (or supplied-var (gensym)) for var-binding = (gensym) - ;; Same as optional parameters: - ;; even though keywords can't be supplied in - ;; excess, we should bind "supplied-p" in case - ;; the key isn't supplied in the arguments list + for member-binding = (gensym) + ;; Bind a hidden gensym to the tail returned + ;; by MEMBER on the &rest arguments, so that + ;; the user-visible supplied-p parameter is a + ;; boolean (T or NIL) and the value parameter + ;; can read (CADR ...) of the tail. collect `(,supplied-binding (progn - ;; ### TODO: use a fresh symbol for the rest - ;; binding being generated and pushed into binding-forms - (push `(,',supplied-binding + (push `(,',member-binding (member ,',key ,',rest)) ,binding-forms) + (push `(,',supplied-binding + (not (null ,',member-binding))) + ,binding-forms) ',supplied-binding)) collect `(,var (progn (push `(,',var-binding - (if ,',supplied-binding - (cadr ,',supplied-binding) + (if ,',member-binding + (cadr ,',member-binding) ,',initform)) ,binding-forms) ',var-binding))) @@ -2572,6 +2580,19 @@ to ~S with argument list ~S." (setf emfun (wrap-emfun-for-keyword-args-check gf emfun non-keyword-args applicable-keywords))) + ;; Wrap EMFUN so that CALL-NEXT-METHOD can see the generic + ;; function and the sorted applicable methods, to detect + ;; changed-argument calls that would produce a different + ;; set of applicable methods. + (let ((raw-emfun emfun) + (context-methods applicable-methods) + (context-gf gf)) + (setf emfun + #'(lambda (args) + (let ((*call-next-method-gf* context-gf) + (*call-next-method-applicable-methods* + context-methods)) + (funcall raw-emfun args))))) ;; The EMFCache only understand classes and EQL ;; specializers. Check the applicable methods and if any ;; have a specializer that isn't an eql-specializer or @@ -2774,8 +2795,25 @@ to ~S with argument list ~S." (walk-form (%car form)) (walk-form (%cdr form))))) +(defvar *call-next-method-gf* nil) +(defvar *call-next-method-applicable-methods* nil) + +(defun cnm-check-applicable-methods (cnm-args) + (let ((gf *call-next-method-gf*) + (expected *call-next-method-applicable-methods*)) + (when gf + (let ((actual (if (std-generic-function-p gf) + (std-compute-applicable-methods gf cnm-args) + (or (compute-applicable-methods-using-classes + gf (mapcar #'class-of cnm-args)) + (compute-applicable-methods gf cnm-args))))) + (unless (equal expected actual) + (error "CALL-NEXT-METHOD called with arguments that produce a different set of applicable methods than the original arguments.")))))) + (defmacro flet-call-next-method (args next-emfun &body body) `(flet ((call-next-method (&rest cnm-args) + (when cnm-args + (cnm-check-applicable-methods cnm-args)) (if (null ,next-emfun) (error "No next method for generic function.") (funcall ,next-emfun (or cnm-args ,args)))) @@ -3272,7 +3310,24 @@ instance and, for setters, `new-value' the new value." (unless (>= (length form) 3) (error 'program-error "Wrong number of arguments for DEFCLASS.")) (check-declaration-type name) + ;; CLHS: the compiler must make the class recognizable to later + ;; FIND-CLASS calls (including via a macro &environment argument) + ;; when DEFCLASS appears as a top-level form. Register a + ;; forward-referenced-class placeholder at compile time, then at + ;; load time clear that placeholder (only when no other class has + ;; claimed it as a superclass) so the subsequent ENSURE-CLASS goes + ;; through the primitive (null) path and bypasses a MOP superclass + ;; check that built-in classes like STREAM fail. `(progn + (eval-when (:compile-toplevel) + (unless (find-class ',name nil) + (setf (find-class ',name) + (make-instance +the-forward-referenced-class+ :name ',name)))) + (eval-when (:load-toplevel) + (let ((existing (find-class ',name nil))) + (when (and (typep existing 'forward-referenced-class) + (null (class-direct-subclasses existing))) + (sys::%set-find-class ',name nil)))) (sys::record-source-information-for-type ',name :class) (ensure-class ',name :direct-superclasses @@ -4207,9 +4262,44 @@ or T when any keyword is acceptable due to presence of (funcall #',report condition stream))) ',name))))) +(defun %resolve-compound-condition-type (type) + "Pick a concrete condition class from a compound type spec. For OR, +return the first disjunct that names a condition class. For AND, +prefer a conjunct that is a subtype of all the others (so the +resulting instance satisfies TYPEP against the whole AND); fall back +to any conjunct naming a condition class." + (cond + ((and (consp type) (eq (car type) 'or)) + (or (find-if (lambda (sub) (and (symbolp sub) (find-class sub nil))) + (cdr type)) + (error 'simple-error + :format-control "MAKE-CONDITION: no disjunct of ~S names a condition class." + :format-arguments (list type)))) + ((and (consp type) (eq (car type) 'and)) + (or (find-if (lambda (sub) + (and (symbolp sub) + (find-class sub nil) + (every (lambda (other) (subtypep sub other)) + (cdr type)))) + (cdr type)) + (find-if (lambda (sub) (and (symbolp sub) (find-class sub nil))) + (cdr type)) + (error 'simple-error + :format-control "MAKE-CONDITION: cannot resolve type ~S to a condition class." + :format-arguments (list type)))) + (t (error 'simple-error + :format-control "MAKE-CONDITION: unsupported type specifier ~S." + :format-arguments (list type))))) + (defun make-condition (type &rest initargs) (or (%make-condition type initargs) - (let ((class (if (symbolp type) (find-class type) type))) + (let ((class (cond ((symbolp type) (find-class type)) + ((classp type) type) + (t (let ((resolved + (%resolve-compound-condition-type type))) + (if (symbolp resolved) + (find-class resolved) + resolved)))))) (apply #'make-instance class initargs)))) ;; Adapted from SBCL. @@ -4601,7 +4691,9 @@ or T when any keyword is acceptable due to presence of (autoload-ref-p (second function-name)))) (fmakunbound function-name) (progn - (cerror "Redefine as generic function" "~A already names an ordinary function, macro, or special operator." function-name) + (error 'program-error + :format-control "~A already names an ordinary function, macro, or special operator." + :format-arguments (list function-name)) (fmakunbound function-name) ))) (apply (if (eq generic-function-class +the-standard-generic-function-class+) diff --git a/src/org/armedbear/lisp/compiler-pass2.lisp b/src/org/armedbear/lisp/compiler-pass2.lisp index 83e487ded..2017b2975 100644 --- a/src/org/armedbear/lisp/compiler-pass2.lisp +++ b/src/org/armedbear/lisp/compiler-pass2.lisp @@ -7647,7 +7647,10 @@ Could arguably better named as *SIGNAL-COMPILE-WARNINGS-P*.") (unless definition (resolve name) ;; Make sure the symbol has been resolved by the autoloader (setf definition (fdefinition name))) - (when (compiled-function-p definition) + (when (or (compiled-function-p definition) + ;; Generic functions are runtime-assembled dispatchers; the + ;; file compiler has no LAMBDA expression to work from. + (typep definition 'mop:funcallable-standard-object)) (return-from jvm-compile (values (or name definition) nil nil))) (let ((catch-errors *catch-errors*) (warnings-p nil) diff --git a/src/org/armedbear/lisp/defstruct.lisp b/src/org/armedbear/lisp/defstruct.lisp index 7438c0a1f..2095c7b05 100644 --- a/src/org/armedbear/lisp/defstruct.lisp +++ b/src/org/armedbear/lisp/defstruct.lisp @@ -604,6 +604,30 @@ (list name-and-options) name-and-options)) (check-declaration-type *dd-name*) + ;; CLHS: the :predicate option is limited to use with structures + ;; that have no :type option or are typed and :named. A non-default + ;; (user-supplied) predicate name is a symbol or NIL; the default is + ;; a string placeholder. + (when (and *dd-type* + (not *dd-named*) + *dd-predicate* + (symbolp *dd-predicate*)) + (error 'simple-error + :format-control + "DEFSTRUCT ~S: :PREDICATE is not allowed on a typed structure unless :NAMED is also supplied." + :format-arguments (list *dd-name*))) + ;; CLHS: if :type is supplied and :named is supplied, the type must + ;; be able to hold the structure's name (a symbol). + (when (and *dd-type* *dd-named* + (consp *dd-type*) (eq (car *dd-type*) 'vector)) + (let ((elt-type (second *dd-type*))) + (unless (or (eq elt-type '*) + (eq elt-type t) + (subtypep 'symbol elt-type)) + (error 'simple-error + :format-control + "DEFSTRUCT ~S: vector element type ~S cannot hold the structure's name symbol (required by :NAMED)." + :format-arguments (list *dd-name* elt-type))))) (if *dd-constructors* (dolist (constructor *dd-constructors*) (unless (cadr constructor) diff --git a/src/org/armedbear/lisp/subtypep.lisp b/src/org/armedbear/lisp/subtypep.lisp index 17828f786..e85acffa4 100644 --- a/src/org/armedbear/lisp/subtypep.lisp +++ b/src/org/armedbear/lisp/subtypep.lisp @@ -277,7 +277,8 @@ ((and (memq t1 '(simple-base-string base-string simple-string string nil-vector)) (memq t2 '(simple-base-string base-string simple-string string nil-vector))) (if (and (simple-subtypep t1 t2) - (or (eql (car i1) (car i2)) + (or (null i2) + (eql (car i1) (car i2)) (eq (car i2) '*))) (return-from csubtypep-array (values t t)) (return-from csubtypep-array (values nil t)))) From 1aa529f0988e2ce3eba40974f47df88a4aa31e0b Mon Sep 17 00:00:00 2001 From: Blake McBride Date: Sat, 18 Apr 2026 17:10:09 -0500 Subject: [PATCH 3/3] Fix DEFPACKAGE, reader , APROPOS, and DISASSEMBLE ANSI test failures --- src/org/armedbear/lisp/Stream.java | 17 +++++++++++++++-- src/org/armedbear/lisp/apropos.lisp | 16 +++++++++------- src/org/armedbear/lisp/defpackage.lisp | 3 ++- src/org/armedbear/lisp/disassemble.lisp | 8 ++++++++ 4 files changed, 34 insertions(+), 10 deletions(-) diff --git a/src/org/armedbear/lisp/Stream.java b/src/org/armedbear/lisp/Stream.java index d29db85d3..7620b52fb 100644 --- a/src/org/armedbear/lisp/Stream.java +++ b/src/org/armedbear/lisp/Stream.java @@ -626,9 +626,22 @@ public LispObject readSymbol() { public LispObject readSymbol(Readtable rt) { final StringBuilder sb = new StringBuilder(); final BitSet flags = _readToken(sb, rt); + final String token = sb.toString(); + // CLHS 2.4.8.7: the token after #: must not contain any unescaped + // package markers. Skip the check when *read-suppress* is true. + if (Symbol.READ_SUPPRESS.symbolValue() == NIL) { + final int len = token.length(); + for (int i = 0; i < len; i++) { + if (token.charAt(i) == ':' && (flags == null || !flags.get(i))) { + return error(new ReaderError( + "Package marker not allowed in #: token: \"" + token + "\"", + this)); + } + } + } return new Symbol(rt.getReadtableCase() == Keyword.INVERT - ? invert(sb.toString(), flags) - : sb.toString()); + ? invert(token, flags) + : token); } public LispObject readStructure(ReadtableAccessor rta) { diff --git a/src/org/armedbear/lisp/apropos.lisp b/src/org/armedbear/lisp/apropos.lisp index 50c965833..04068ac11 100644 --- a/src/org/armedbear/lisp/apropos.lisp +++ b/src/org/armedbear/lisp/apropos.lisp @@ -34,8 +34,7 @@ (in-package #:system) -(defun apropos-list (string-designator &optional package-designator - external-only) +(defun %apropos-list (string-designator package-designator external-only) (if package-designator (let ((package (find-package package-designator)) (string (string string-designator)) @@ -51,13 +50,16 @@ (push symbol result)))) result) (mapcan (lambda (package) - (apropos-list string-designator package external-only)) + (%apropos-list string-designator package external-only)) (list-all-packages)))) -(defun apropos (string-designator &optional package-designator external-only) - (dolist (symbol (remove-duplicates (apropos-list string-designator - package-designator - external-only))) +(defun apropos-list (string-designator &optional package-designator) + (%apropos-list string-designator package-designator nil)) + +(defun apropos (string-designator &optional package-designator) + (dolist (symbol (remove-duplicates (%apropos-list string-designator + package-designator + nil))) (fresh-line) (prin1 symbol) (when (boundp symbol) diff --git a/src/org/armedbear/lisp/defpackage.lisp b/src/org/armedbear/lisp/defpackage.lisp index a5a37029b..51798eb64 100644 --- a/src/org/armedbear/lisp/defpackage.lisp +++ b/src/org/armedbear/lisp/defpackage.lisp @@ -79,7 +79,8 @@ (error 'program-error "bad DEFPACKAGE option: ~S" option)) (case (car option) (:nicknames - (setq nicknames (stringify-names (cdr option)))) + (let ((new (stringify-names (cdr option)))) + (setq nicknames (append nicknames new)))) (:size (cond (size (error 'program-error "can't specify :SIZE twice")) diff --git a/src/org/armedbear/lisp/disassemble.lisp b/src/org/armedbear/lisp/disassemble.lisp index 384a659a5..6890811e0 100644 --- a/src/org/armedbear/lisp/disassemble.lisp +++ b/src/org/armedbear/lisp/disassemble.lisp @@ -210,6 +210,14 @@ CL:DISASSEMBLE." ;; (get-java-field (elt (#"get" (elt (#"getFields" (#"getClass" #'foo)) 0) #'foo) 0) "value") (defun disassemble (arg) + (unless (typep arg '(or function symbol + (cons (eql setf) (cons symbol null)) + (cons (eql lambda) t))) + (error 'type-error + :datum arg + :expected-type '(or function symbol + (cons (eql setf) (cons symbol null)) + (cons (eql lambda) t)))) (print-lines-with-prefix (disassemble-function arg))) (defun print-lines-with-prefix (string)