Update of /project/movitz/cvsroot/movitz/losp/muerte In directory clnet:/tmp/cvs-serv3130

Modified Files: defstruct.lisp Log Message: Have macros in the run-time.

--- /project/movitz/cvsroot/movitz/losp/muerte/defstruct.lisp 2006/04/03 21:22:39 1.17 +++ /project/movitz/cvsroot/movitz/losp/muerte/defstruct.lisp 2008/03/15 20:57:34 1.18 @@ -9,7 +9,7 @@ ;;;; Created at: Mon Jan 22 13:10:59 2001 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: defstruct.lisp,v 1.17 2006/04/03 21:22:39 ffjeld Exp $ +;;;; $Id: defstruct.lisp,v 1.18 2008/03/15 20:57:34 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------

@@ -133,13 +133,13 @@ (defun (setf list-struct-accessor-prototype) (value s) (setf (nth 'slot-number s) value))

-(defmacro defstruct (name-and-options &optional documentation &rest slot-descriptions) +(defmacro/cross-compilation defstruct (name-and-options &optional documentation &rest slot-descriptions) (unless (stringp documentation) (push documentation slot-descriptions) (setf documentation nil)) (let ((struct-name (if (symbolp name-and-options) name-and-options - (car name-and-options)))) + (car name-and-options)))) (flet ((parse-option (option collector) (etypecase option (symbol @@ -154,7 +154,7 @@ (ecase (car option) (:conc-name (push "" (getf collector :conc-name))) (:constructor (push (intern (concatenate 'string - (string 'make-) (string struct-name))) + (string 'make-) (string struct-name))) (getf collector :constructor))) (:copier) ; do default (:predicate) ; do default @@ -184,13 +184,13 @@ collector)) (let ((options nil)) (when (listp name-and-options) - (loop for option in (cdr name-and-options) - do (setf options (parse-option option options)))) + (dolist (option (cdr name-and-options)) + (setf options (parse-option option options)))) (macrolet ((default ((option &optional (max-values 1000000)) default-form) - `(if (not (getf options ,option)) - (push ,default-form (getf options ,option)) + `(if (not (getf options ,option)) + (push ,default-form (getf options ,option)) (assert (<= 1 (length (getf options ,option)) ,max-values) () - "Option ~S given too many times." ,option)))) + "Option ~S given too many times." ,option)))) (default (:type 1) 'class-struct) (default (:superclass 1) 'structure-object) (default (:named 1) nil) @@ -209,17 +209,17 @@ (predicate-name (first (getf options :predicate))) (standard-name-and-options (if (not (consp name-and-options)) name-and-options - (remove :superclass name-and-options - :key (lambda (x) - (when (consp x) (car x)))))) + (remove :superclass name-and-options + :key (lambda (x) + (when (consp x) (car x)))))) (canonical-slot-descriptions (mapcar #'(lambda (d) "(<slot-name> <init-form> <type> <read-only-p> <initarg>)" (if (symbolp d) (list d nil nil nil (intern (symbol-name d) :keyword)) - (destructuring-bind (n &optional i &key type read-only) - d - (list n i type read-only (intern (symbol-name n) :keyword))))) + (destructuring-bind (n &optional i &key type read-only) + d + (list n i type read-only (intern (symbol-name n) :keyword))))) slot-descriptions)) (slot-names (mapcar #'car canonical-slot-descriptions)) (key-lambda (mapcar #'(lambda (d) (list (first d) (second d))) @@ -230,111 +230,107 @@ (eval-when (:compile-toplevel) (setf (gethash '(:translate-when :eval ,struct-name :cl :muerte.cl) (movitz::image-struct-slot-descriptions movitz:*image*)) - '(:translate-when :eval ,slot-descriptions :cl :muerte.cl)) + '(:translate-when :eval ,slot-descriptions :cl :muerte.cl)) (defstruct (:translate-when :eval ,standard-name-and-options :cl :muerte.cl) . (:translate-when :eval ,slot-names :cl :muerte.cl))) (defclass ,struct-name (,superclass) () - (:metaclass structure-class) - (:slots ,(loop for (name init-form type read-only init-arg) - in canonical-slot-descriptions - as location upfrom 0 - collect (movitz-make-instance 'structure-slot-definition - :name name - :initarg init-arg - :initform init-form - :type type - :readonly read-only - :location location)))) + (:metaclass structure-class) + (:slots ,(loop for (name init-form type read-only init-arg) in canonical-slot-descriptions + as location upfrom 0 + collect (movitz-make-instance 'structure-slot-definition + :name name + :initarg init-arg + :initform init-form + :type type + :readonly read-only + :location location)))) ,@(loop for copier in (getf options :copier) - if (and copier (symbolp copier)) - collect - `(defun ,copier (x) - (copy-structure x))) + if (and copier (symbolp copier)) + collect + `(defun ,copier (x) + (copy-structure x))) ,@(loop for constructor in (getf options :constructor) - if (and constructor (symbolp constructor)) - collect - `(defun ,constructor (&rest args) ; &key ,@key-lambda) - (declare (dynamic-extent args)) - (apply 'make-structure ',struct-name args)) - else if (and constructor (listp constructor)) - collect - (let* ((boa-constructor (car constructor)) - (boa-lambda-list (cdr constructor)) - (boa-variables (movitz::list-normal-lambda-list-variables boa-lambda-list))) - `(defun ,boa-constructor ,boa-lambda-list - (let ((class (compile-time-find-class ,struct-name))) - (with-allocation-assembly (,(+ 2 (length slot-names)) - :fixed-size-p t - :object-register :eax) - (:movl ,(dpb (length slot-names) - (byte 18 14) - (movitz:tag :defstruct)) - (:eax (:offset movitz-struct type))) - (:load-lexical (:lexical-binding class) :ebx) - (:movl :ebx (:eax (:offset movitz-struct class))) - ,@(loop for slot-name in slot-names as i upfrom 0 - if (member slot-name boa-variables) - append - `((:load-lexical (:lexical-binding ,slot-name) :ebx) - (:movl :ebx (:eax (:offset movitz-struct slot0) - ,(* 4 i)))) - else append - `((:movl :edi (:eax (:offset movitz-struct slot0) - ,(* 4 i))))) - ,@(when (oddp (length slot-names)) - `((:movl :edi (:eax (:offset movitz-struct slot0) - ,(* 4 (length slot-names)))))))))) - else if constructor - do (error "Don't know how to make class-struct constructor: ~S" constructor)) + if (and constructor (symbolp constructor)) + collect + `(defun ,constructor (&rest args) ; &key ,@key-lambda) + (declare (dynamic-extent args)) + (apply 'make-structure ',struct-name args)) + else if (and constructor (listp constructor)) + collect + (let* ((boa-constructor (car constructor)) + (boa-lambda-list (cdr constructor)) + (boa-variables (movitz::list-normal-lambda-list-variables boa-lambda-list))) + `(defun ,boa-constructor ,boa-lambda-list + (let ((class (compile-time-find-class ,struct-name))) + (with-allocation-assembly (,(+ 2 (length slot-names)) + :fixed-size-p t + :object-register :eax) + (:movl ,(dpb (length slot-names) + (byte 18 14) + (movitz:tag :defstruct)) + (:eax (:offset movitz-struct type))) + (:load-lexical (:lexical-binding class) :ebx) + (:movl :ebx (:eax (:offset movitz-struct class))) + ,@(loop for slot-name in slot-names as i upfrom 0 + if (member slot-name boa-variables) + append + `((:load-lexical (:lexical-binding ,slot-name) :ebx) + (:movl :ebx (:eax (:offset movitz-struct slot0) + ,(* 4 i)))) + else append + `((:movl :edi (:eax (:offset movitz-struct slot0) + ,(* 4 i))))) + ,@(when (oddp (length slot-names)) + `((:movl :edi (:eax (:offset movitz-struct slot0) + ,(* 4 (length slot-names)))))))))) + else if constructor + do (error "Don't know how to make class-struct constructor: ~S" constructor)) ,(when predicate-name - `(defun-by-proto ,predicate-name struct-predicate-prototype - (struct-class (:movitz-find-class ,struct-name)))) + `(defun-by-proto ,predicate-name struct-predicate-prototype + (struct-class (:movitz-find-class ,struct-name)))) ,@(loop for (slot-name nil nil read-only-p) in canonical-slot-descriptions - as accessor-name = (intern (concatenate 'string conc-name (string slot-name)) - (movitz::symbol-package-fix-cl struct-name)) - as slot-number upfrom 0 - unless read-only-p - collect - `(defun-by-proto (setf ,accessor-name) (setf struct-accessor-prototype) - (struct-name ,struct-name) - (slot-number ,slot-number)) - collect - `(defun-by-proto ,accessor-name struct-accessor-prototype - (struct-name ,struct-name) - (slot-number ,slot-number))) + as accessor-name = (intern (concatenate 'string conc-name (string slot-name)) + (movitz::symbol-package-fix-cl struct-name)) + as slot-number upfrom 0 + unless read-only-p + collect + `(defun-by-proto (setf ,accessor-name) (setf struct-accessor-prototype) + (struct-name ,struct-name) + (slot-number ,slot-number)) + collect + `(defun-by-proto ,accessor-name struct-accessor-prototype + (struct-name ,struct-name) + (slot-number ,slot-number))) ',struct-name)) (list `(progn ,@(if struct-named (append (loop for constructor in (getf options :constructor) - if (symbolp constructor) - collect - `(defun ,constructor (&key ,@key-lambda) - (list ',struct-name ,@(mapcar #'car key-lambda))) - else do (error "don't know how to make constructor: ~S" constructor)) + if (symbolp constructor) + collect + `(defun ,constructor (&key ,@key-lambda) + (list ',struct-name ,@(mapcar #'car key-lambda))) + else do (error "don't know how to make constructor: ~S" constructor)) (when predicate-name `((defun ,predicate-name (x) (and (consp x) (eq ',struct-name (car x))))))) - (loop for constructor in (getf options :constructor) - if (symbolp constructor) - collect - `(defun ,constructor (&key ,@key-lambda) - (list ,@(mapcar #'car key-lambda))) - else do (error "don't know how to make constructor: ~S" constructor))) + (loop for constructor in (getf options :constructor) + if (symbolp constructor) + collect + `(defun ,constructor (&key ,@key-lambda) + (list ,@(mapcar #'car key-lambda))) + else do (error "don't know how to make constructor: ~S" constructor))) ,@(loop for (slot-name nil nil read-only-p) in canonical-slot-descriptions - as accessor-name = (intern (concatenate 'string conc-name (string slot-name)) - (movitz::symbol-package-fix-cl struct-name)) - as slot-number upfrom (if struct-named 1 0) - unless read-only-p - collect - `(defun-by-proto (setf ,accessor-name) (setf list-struct-accessor-prototype) - (slot-number ,slot-number)) - collect - `(defun-by-proto ,accessor-name list-struct-accessor-prototype - (slot-number ,slot-number))) + as accessor-name = (intern (concatenate 'string conc-name (string slot-name)) + (movitz::symbol-package-fix-cl struct-name)) + as slot-number upfrom (if struct-named 1 0) + unless read-only-p + collect + `(defun-by-proto (setf ,accessor-name) (setf list-struct-accessor-prototype) + (slot-number ,slot-number)) + collect + `(defun-by-proto ,accessor-name list-struct-accessor-prototype + (slot-number ,slot-number))) ',struct-name)) )))))) - - -