/[gcl]/gcl/lsp/gcl_defstruct.lsp
ViewVC logotype

Diff of /gcl/lsp/gcl_defstruct.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.9 by camm, Wed Sep 7 02:45:51 2005 UTC revision 1.10 by camm, Sun Sep 18 02:08:49 2005 UTC
# Line 30  Line 30 
30  (in-package 'system)  (in-package 'system)
31    
32    
33  (proclaim '(optimize (safety 2) (space 3)))  ;(proclaim '(optimize (safety 2) (space 3)))
34    
35    
36    
# Line 43  Line 43 
43  (defvar *vector-accessors* (make-array 2 :adjustable t))  (defvar *vector-accessors* (make-array 2 :adjustable t))
44    
45  (or (fboundp 'record-fn) (setf (symbol-function 'record-fn)  (or (fboundp 'record-fn) (setf (symbol-function 'record-fn)
46                                 #'(lambda (&rest l) l nil)))                                 (lambda (&rest l) l nil)))
47    
48  (defun make-access-function (name conc-name no-conc type named include no-fun  (defun make-access-function (name conc-name no-conc type named include no-fun
49                                    ;; from apply                                    ;; from apply
# Line 75  Line 75 
75             (or (aref accsrs offset)             (or (aref accsrs offset)
76                 (setf (aref accsrs offset)                 (setf (aref accsrs offset)
77                       (cond  ((eq accsrs *accessors*)                       (cond  ((eq accsrs *accessors*)
78                                  #'(lambda (x)                                  (lambda (x)
79                                      (or (structurep x)                                    (declare (optimize (safety 1)))
80                                          (error "~a is not a structure" x))                                    (or (structurep x)
81                                          (error "~a is not a structure" x))
82                                      (structure-ref1 x offset)))                                      (structure-ref1 x offset)))
83                                 ((eq accsrs *list-accessors*)                                 ((eq accsrs *list-accessors*)
84                                  #'(lambda(x)                                  (lambda(x)
85                                        (declare (optimize (safety 1)))
86                                      (si:list-nth offset x)))                                      (si:list-nth offset x)))
87                                 ((eq accsrs *vector-accessors*)                                 ((eq accsrs *vector-accessors*)
88                                  #'(lambda(x)                                  (lambda(x)
89                                      (aref x offset)))))))))                                    (declare (optimize (safety 1)))
90                                      (aref x offset)))))))))
91      (cond (read-only      (cond (read-only
92              (remprop access-function 'structure-access)              (remprop access-function 'structure-access)
93              (setf (get access-function 'struct-read-only) t))              (setf (get access-function 'struct-read-only) t))
# Line 122  Line 125 
125  (defmacro maybe-add-keydef (key keydefs prior-keyword)  (defmacro maybe-add-keydef (key keydefs prior-keyword)
126    `(let ((def (cadar    `(let ((def (cadar
127                 (member (key-name ,key ,prior-keyword) ,keydefs                 (member (key-name ,key ,prior-keyword) ,keydefs
128                         :key #'(lambda (k) (when (consp k) (car k)))))))                         :key (lambda (k)
129                                  (declare (optimize (safety 1)))
130                                  (when (consp k) (car k)))))))
131       (if def       (if def
132           (cond ((not (consp ,key))           (cond ((not (consp ,key))
133                  (list ,key def))                  (list ,key def))
# Line 187  Line 192 
192    (declare (ignore named))    (declare (ignore named))
193    (let ((slot-names    (let ((slot-names
194           ;; Collect the slot-names.           ;; Collect the slot-names.
195           (mapcar #'(lambda (x)           (mapcar (lambda (x)
196                       (cond ((null x)                       (cond ((null x)
197                              ;; If the slot-description is NIL,                              ;; If the slot-description is NIL,
198                              ;;  it is in the padding of initial-offset.                              ;;  it is in the padding of initial-offset.
# Line 201  Line 206 
206                   slot-descriptions))                   slot-descriptions))
207          (keys          (keys
208           ;; Make the keyword parameters.           ;; Make the keyword parameters.
209           (mapcan #'(lambda (x)           (mapcan (lambda (x)
210                       (cond ((null x) nil)                       (cond ((null x) nil)
211                             ((null (car x)) nil)                             ((null (car x)) nil)
212                             ((null (cadr x)) (list (maybe-cons-keyname x)))                             ((null (cadr x)) (list (maybe-cons-keyname x)))
# Line 320  Line 325 
325                 (cons (car olds)                 (cons (car olds)
326                       (overwrite-slot-descriptions news (cdr olds))))))))                       (overwrite-slot-descriptions news (cdr olds))))))))
327    
328  (defvar *all-t-s-type* (make-array 50 :element-type 'unsigned-char :static t))  (defconstant +aet-type-object+ (aet-type nil))
329  (defvar *alignment-t* (alignment t))  (defconstant +all-t-s-type+
330      (make-array 50 :element-type 'unsigned-char :static t :initial-element +aet-type-object+))
331    (defconstant +alignment-t+ (alignment t))
332    
333  (defun make-t-type (n include slot-descriptions &aux i)  (defun make-t-type (n include slot-descriptions &aux i)
334    (let ((res  (make-array n :element-type 'unsigned-char :static t)))    (let ((res  (make-array n :element-type 'unsigned-char :static t)))
# Line 334  Line 341 
341      (dolist (v slot-descriptions)      (dolist (v slot-descriptions)
342              (setq i (nth 4 v))              (setq i (nth 4 v))
343              (let ((type (third v)))              (let ((type (third v)))
344                (cond ((<= (the fixnum (alignment type)) *alignment-t*)                (cond ((<= (the fixnum (alignment type)) +alignment-t+)
345                       (setf (aref res i) (aet-type type))))))                       (setf (aref res i) (aet-type type))))))
346      (cond ((< n (length *all-t-s-type*))      (cond ((< n (length +all-t-s-type+))
347             (dotimes (i n)             (let ((def +aet-type-object+))
348                    (cond ((not (eql (the fixnum (aref res i)) 0))               (dotimes (i n)
349                           (return-from make-t-type res))))                 (cond ((not (= (the fixnum (aref res i)) def))
350             *all-t-s-type*)                        (return-from make-t-type res)))))
351               +all-t-s-type+)
352            (t res))))            (t res))))
353    
354  (defvar *standard-slot-positions*  (defvar *standard-slot-positions*
# Line 351  Line 359 
359               (setf (aref ar i)(*  (size-of t) i)))               (setf (aref ar i)(*  (size-of t) i)))
360      ar))      ar))
361    
362  (eval-when (compile )  ;(eval-when (compile )
363  (proclaim '(function round-up (fixnum fixnum ) fixnum))  ;(proclaim '(function round-up (fixnum fixnum ) fixnum))
364  )  ;)
365    
366  (defun round-up (a b)  (defun round-up (a b)
367    (declare (fixnum a b))    (declare (fixnum a b))
# Line 394  Line 402 
402                 (v slot-descriptions)                 (v slot-descriptions)
403                 (setq type (caddr v))                 (setq type (caddr v))
404                 (setq align (alignment type))                 (setq align (alignment type))
405                 (unless (<= align *alignment-t*)                 (unless (<= align +alignment-t+)
406                         (setq type t)                         (setq type t)
407                         (setf (caddr v) t)                         (setf (caddr v) t)
408                         (setq align *alignment-t*)                         (setq align +alignment-t+)
409                         (setq v (nconc v '(t))))                         (setq v (nconc v '(t))))
410                 (setq next-pos (round-up pos align))                     (setq next-pos (round-up pos align))    
411                 (or (eql pos next-pos) (setq has-holes t))                 (or (eql pos next-pos) (setq has-holes t))
# Line 432  Line 440 
440           ;bootstrapping code!           ;bootstrapping code!
441           (setq def (make-s-data-structure           (setq def (make-s-data-structure
442                       (make-array (* leng (size-of t))                       (make-array (* leng (size-of t))
443                                   :element-type 'string-char :static t)                                   :element-type 'unsigned-char :static t :initial-element +aet-type-object+)
444                       (make-t-type leng nil slot-descriptions)                       (make-t-type leng nil slot-descriptions)
445                       *standard-slot-positions*                       *standard-slot-positions*
446                       slot-descriptions                       slot-descriptions
# Line 495  Line 503 
503            (record-fn predicate 'defun '(t) t)            (record-fn predicate 'defun '(t) t)
504            (or no-funs            (or no-funs
505                (setf (symbol-function predicate)                (setf (symbol-function predicate)
506                      #'(lambda (x)                      (lambda (x)
507                          (si::structure-subtype-p x name))))                        (declare (optimize (safety 1)))
508                          (si::structure-subtype-p x name))))
509            (setf (get predicate 'compiler::co1)            (setf (get predicate 'compiler::co1)
510                  'compiler::co1structure-predicate)                  'compiler::co1structure-predicate)
511            (setf (get predicate 'struct-predicate) name)            (setf (get predicate 'struct-predicate) name)
# Line 505  Line 514 
514    
515                                        
516  (defmacro defstruct (name &rest slots)  (defmacro defstruct (name &rest slots)
517      (declare (optimize (safety 1)))
518    (let ((slot-descriptions slots)    (let ((slot-descriptions slots)
519          options          options
520          conc-name          conc-name
# Line 595  Line 605 
605      (when (and print-function print-object)      (when (and print-function print-object)
606        (error "Cannot specify both :print-function and :print-object."))        (error "Cannot specify both :print-function and :print-object."))
607      (when print-object      (when print-object
608        (setq print-function (lambda (x y z) (declare (ignore z)) (funcall print-object x y))))        (setq print-function (lambda (x y z)
609                                 (declare (optimize (safety 1)))
610                                 (declare (ignore z)) (funcall print-object x y))))
611    
612      (and include (not print-function)      (and include (not print-function)
613           (setq print-function (s-data-print-function (get (car include)  's-data))))           (setq print-function (s-data-print-function (get (car include)  's-data))))
# Line 656  Line 668 
668            (t            (t
669              (setq slot-descriptions              (setq slot-descriptions
670                    (append (overwrite-slot-descriptions                    (append (overwrite-slot-descriptions
671                              (mapcar #'(lambda (sd)                              (mapcar (lambda (sd)
672                                          (parse-slot-description sd 0))                                          (parse-slot-description sd 0))
673                                      (cdr include))                                      (cdr include))
674                              (s-data-slot-descriptions                              (s-data-slot-descriptions
# Line 713  Line 725 
725             ',offset ',predicate ',documentation             ',offset ',predicate ',documentation
726             )             )
727                    
728           ,@(mapcar #'(lambda (constructor)           ,@(mapcar (lambda (constructor)
729                         (make-constructor name constructor type named new-slot-descriptions))                         (make-constructor name constructor type named new-slot-descriptions))
730                     constructors)                     constructors)
731           ,@(if (and type predicate)           ,@(if (and type predicate)

Legend:
Removed from v.1.9  
changed lines
  Added in v.1.10

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26