Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

This patch makes defstructs able to be redefined. #498

Open
wants to merge 1 commit into
base: master
Choose a base branch
from
Open

This patch makes defstructs able to be redefined. #498

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion src/org/armedbear/lisp/LispClass.java
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -38,7 +38,7 @@

public abstract class LispClass extends StandardObject
{
private static final ConcurrentHashMap<Symbol, LispObject> map
public static final ConcurrentHashMap<Symbol, LispObject> map
= new ConcurrentHashMap<Symbol, LispObject>();

public static <T extends LispClass> T addClass(Symbol symbol, T c)
Expand Down
29 changes: 29 additions & 0 deletions src/org/armedbear/lisp/StructureClass.java
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -125,4 +125,33 @@ public LispObject execute(LispObject first, LispObject second,
return c;
}
};
// ### reinitialize-structure-class name direct-slots slots include => class
private static final Primitive REINITIALIZE_STRUCTURE_CLASS =
new Primitive("reinitialize-structure-class", PACKAGE_SYS, false)
{
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third, LispObject fourth)

{
Symbol symbol = checkSymbol(first);
LispObject directSlots = checkList(second);
LispObject slots = checkList(third);
Symbol include = checkSymbol(fourth);

StructureClass c = (StructureClass)LispClass.map.get(symbol);
if (include != NIL) {
LispClass includedClass = LispClass.findClass(include);
if (includedClass == null)
return error(new SimpleError("Class " + include +
" is undefined."));
c.setCPL(new Cons(c, includedClass.getCPL()));
} else
c.setCPL(c, BuiltInClass.STRUCTURE_OBJECT, BuiltInClass.CLASS_T);
c.setDirectSlotDefinitions(directSlots);
c.setSlotDefinitions(slots);
c.setFinalized(true);
return c;
}
};
}
144 changes: 84 additions & 60 deletions src/org/armedbear/lisp/defstruct.lisp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -126,7 +126,8 @@
(defvar *dd-slots*)
(defvar *dd-inherited-accessors*)
(defvar *dd-documentation*)

(defvar *dd-optimize* t)

(defun keywordify (symbol)
(intern (symbol-name symbol) +keyword-package+))

Expand Down Expand Up @@ -353,28 +354,30 @@
(type (dsd-type slot)))
(cond ((eq *dd-type* 'list)
`((declaim (ftype (function * ,type) ,accessor-name))
(record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
(record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
(setf (symbol-function ',accessor-name)
(make-list-reader ,index))))
((or (eq *dd-type* 'vector)
(and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
`((declaim (ftype (function * ,type) ,accessor-name))
(record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
(record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
(setf (symbol-function ',accessor-name)
(make-vector-reader ,index))
(record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
(define-source-transform ,accessor-name (instance)
`(aref (truly-the ,',*dd-type* ,instance) ,,index))))
(record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
,@(when *dd-optimize*
`((define-source-transform ,accessor-name (instance)
`(aref (truly-the ,',*dd-type* ,instance) ,,index))))))
(t
`((declaim (ftype (function * ,type) ,accessor-name))
(setf (symbol-function ',accessor-name)
(make-structure-reader ,index ',*dd-name*))
(record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
(define-source-transform ,accessor-name (instance)
(record-source-information-for-type ',accessor-name '(:structure-reader ,*dd-name*))
,@(when *dd-optimize*
`((define-source-transform ,accessor-name (instance)
,(if (eq type 't)
``(structure-ref (the ,',*dd-name* ,instance) ,,index)
``(the ,',type
(structure-ref (the ,',*dd-name* ,instance) ,,index)))))))))
(structure-ref (the ,',*dd-name* ,instance) ,,index)))))))))))

(defun make-list-writer (index)
#'(lambda (value instance)
Expand All @@ -400,22 +403,24 @@
(index (dsd-index slot)))
(cond ((eq *dd-type* 'list)
`((record-source-information-for-type '(setf ,accessor-name) '(:structure-writer ,*dd-name*))
(setf (get ',accessor-name 'setf-function)
(setf (get ',accessor-name 'setf-function)
(make-list-writer ,index))))
((or (eq *dd-type* 'vector)
(and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
`((setf (get ',accessor-name 'setf-function)
(make-vector-writer ,index))
(record-source-information-for-type '(setf ,accessor-name) '(:structure-writer ,*dd-name*))
(define-source-transform (setf ,accessor-name) (value instance)
`(aset (truly-the ,',*dd-type* ,instance) ,,index ,value))))
(record-source-information-for-type '(setf ,accessor-name) '(:structure-writer ,*dd-name*))
,@(when *dd-optimize*
`((define-source-transform (setf ,accessor-name) (value instance)
`(aset (truly-the ,',*dd-type* ,instance) ,,index ,value))))))
(t
`((setf (get ',accessor-name 'setf-function)
(make-structure-writer ,index ',*dd-name*))
(record-source-information-for-type '(setf ,accessor-name) '(:structure-writer ,*dd-name*))
(define-source-transform (setf ,accessor-name) (value instance)
`(structure-set (the ,',*dd-name* ,instance)
,,index ,value)))))))
(record-source-information-for-type '(setf ,accessor-name) '(:structure-writer ,*dd-name*))
,@(when *dd-optimize*
`((define-source-transform (setf ,accessor-name) (value instance)
`(structure-set (the ,',*dd-name* ,instance)
,,index ,value)))))))))

(defun define-access-functions ()
(let ((result ()))
Expand Down Expand Up @@ -493,7 +498,11 @@
(setf *dd-type* (cadr option))
(when (and (consp *dd-type*) (eq (car *dd-type*) 'vector))
(unless (eq (second *dd-type*) '*)
(setf *dd-default-slot-type* (second *dd-type*)))))))
(setf *dd-default-slot-type* (second *dd-type*)))))
(:optimize
(setf *dd-optimize* (if (null (cadr option)) nil t)))

))

(defun parse-name-and-options (name-and-options)
(setf *dd-name* (the symbol (car name-and-options)))
Expand All @@ -511,40 +520,43 @@
(t
(error "Unrecognized DEFSTRUCT option: ~S." option))))))

(defvar *allow-defstruct-redefinition* nil)

(defun compiler-defstruct (name &key
conc-name
default-constructor
constructors
copier
include
type
named
initial-offset
predicate
print-function
print-object
direct-slots
slots
inherited-accessors
documentation)
conc-name
default-constructor
constructors
copier
include
type
named
initial-offset
predicate
print-function
print-object
direct-slots
slots
inherited-accessors
documentation
optimize)
(let ((description
(make-defstruct-description :name name
:conc-name conc-name
:default-constructor default-constructor
:constructors constructors
:copier copier
:include include
:type type
:named named
:initial-offset initial-offset
:predicate predicate
:print-function print-function
:print-object print-object
:direct-slots direct-slots
:slots slots
:inherited-accessors inherited-accessors))
(make-defstruct-description :name name
:conc-name conc-name
:default-constructor default-constructor
:constructors constructors
:copier copier
:include include
:type type
:named named
:initial-offset initial-offset
:predicate predicate
:print-function print-function
:print-object print-object
:direct-slots direct-slots
:slots slots
:inherited-accessors inherited-accessors))
(old (get name 'structure-definition)))
(when old
(when (and old (not (and *allow-defstruct-redefinition* (not optimize))))
(unless
;; Assert that the structure definitions are exactly the same
;; we need to support this type of redefinition during bootstrap
Expand Down Expand Up @@ -572,15 +584,25 @@
:format-arguments (list name)))
;; Since they're the same, continue with the old one.
(setf description old))
(setf (get name 'structure-definition) description))
(%set-documentation name 'structure documentation)
(when (or (null type) named)
(let ((structure-class
(make-structure-class name direct-slots slots (car include))))
(%set-documentation name 'type documentation)
(%set-documentation structure-class t documentation)))
(when default-constructor
(proclaim `(ftype (function * t) ,default-constructor))))
(setf (get name 'structure-definition) description)
(%set-documentation name 'structure documentation)
(when (or (null type) named (and old *allow-defstruct-redefinition*))
(let ((structure-class
(if (and old *allow-defstruct-redefinition*)
(progn
(block warn
(dolist (slot slots)
(when (get-function-info-value (dsd-reader slot) :source-transform)
(warn "Redefining structure ~a, previously optimized. You should recompile code using accessors"
name)
(return-from warn nil))))
(dolist (slot slots) (set-function-info-value (dsd-reader slot) :source-transform nil))
(reinitialize-structure-class name direct-slots slots (car include)))
(make-structure-class name direct-slots slots (car include)))))
(%set-documentation name 'type documentation)
(%set-documentation structure-class t documentation)))
(when default-constructor
(proclaim `(ftype (function * t) ,default-constructor)))))

(defmacro defstruct (name-and-options &rest slots)
(let ((*dd-name* nil)
Expand All @@ -599,7 +621,8 @@
(*dd-direct-slots* ())
(*dd-slots* ())
(*dd-inherited-accessors* ())
(*dd-documentation* nil))
(*dd-documentation* nil)
(*dd-optimize* t))
(parse-name-and-options (if (atom name-and-options)
(list name-and-options)
name-and-options))
Expand Down Expand Up @@ -704,7 +727,8 @@
:direct-slots ',*dd-direct-slots*
:slots ',*dd-slots*
:inherited-accessors ',*dd-inherited-accessors*
:documentation ',*dd-documentation*))
:documentation ',*dd-documentation*
:optimize ',*dd-optimize*))
(record-source-information-for-type ',*dd-name* :structure)
,@(define-constructors)
,@(define-predicate)
Expand Down