/[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.3 by camm, Thu Oct 2 17:55:58 2003 UTC revision 1.4 by camm, Thu Oct 23 15:14:07 2003 UTC
# Line 49  Line 49 
49                                    slot-name default-init slot-type read-only                                    slot-name default-init slot-type read-only
50                                    offset &optional predicate )                                    offset &optional predicate )
51    (declare (ignore named default-init predicate ))    (declare (ignore named default-init predicate ))
     
52    (let ((access-function    (let ((access-function
53           (if no-conc           (if no-conc
54               slot-name               slot-name
# Line 172  Line 171 
171            (push keydef res))))            (push keydef res))))
172      (nreverse res)))      (nreverse res)))
173    
174    (defun maybe-cons-keyname (x &optional y)
175      (unless (consp x)
176        (specific-error :invalid-form "x ~S is not a list~%" x))
177      (let ((sn (sixth x)))
178        (if sn
179            (if y
180                (list (list (car x) sn) y)
181              (list (list (car x) sn)))
182          (if y (list (car x) y) (car x)))))
183    
184  (defun make-constructor (name constructor type named  (defun make-constructor (name constructor type named
185                           slot-descriptions)                           slot-descriptions)
186    (declare (ignore named))    (declare (ignore named))
# Line 187  Line 196 
196                              ;;  it is the structure name.                              ;;  it is the structure name.
197                              ;;  This is for typed structures with names.                              ;;  This is for typed structures with names.
198                              (list 'quote (cadr x)))                              (list 'quote (cadr x)))
199                             (t (car x))))                             (t (let ((sn (sixth x))) (if sn sn (car x))))))
200                   slot-descriptions))                   slot-descriptions))
201          (keys          (keys
202           ;; Make the keyword parameters.           ;; Make the keyword parameters.
203           (mapcan #'(lambda (x)           (mapcan #'(lambda (x)
204                       (cond ((null x) nil)                       (cond ((null x) nil)
205                             ((null (car x)) nil)                             ((null (car x)) nil)
206                             ((null (cadr x)) (list (car x)))                             ((null (cadr x)) (list (maybe-cons-keyname x)))
207                             (t (list (list  (car x) (cadr x))))))                             (t (list (maybe-cons-keyname x (cadr x))))))
208                   slot-descriptions)))                   slot-descriptions)))
209      (cond ((consp constructor)      (cond ((consp constructor)
210             (setq keys (parse-boa-lambda-list (cadr constructor) keys))             (setq keys (parse-boa-lambda-list (cadr constructor) keys))
# Line 203  Line 212 
212            (t            (t
213             ;; If not a BOA constructor, just cons &KEY.             ;; If not a BOA constructor, just cons &KEY.
214             (setq keys (cons '&key keys))))             (setq keys (cons '&key keys))))
215      (cond ((null type)       (cond ((null type)
216             `(defun ,constructor ,keys              `(defun ,constructor ,keys
217                (si:make-structure ',name ,@slot-names)))                 (si:make-structure ',name ,@slot-names)))
218            ((or (eq type 'vector)             ((eq type 'vector)
219                 (and (consp type) (eq (car type) 'vector)))              `(defun ,constructor ,keys
220             `(defun ,constructor ,keys                 (vector ,@slot-names)))
221                (vector ,@slot-names)))             ((and (consp type) (eq (car type) 'vector))
222            ((eq type 'list)              (if (endp (cdr type))
223             `(defun ,constructor ,keys                  `(defun ,constructor ,keys
224                (list ,@slot-names)))                     (vector ,@slot-names)))
225            ((error "~S is an illegal structure type" type)))))                `(defun ,constructor ,keys
226                     (make-array ,(length slot-names)
227                                 :element-type ',(cadr type)
228                                 :initial-contents (list ,@slot-names))))
229               ((eq type 'list)
230                `(defun ,constructor ,keys
231                   (list ,@slot-names)))
232               ((error "~S is an illegal structure type" type)))))
233      
234  (defun make-predicate (name predicate type named name-offset)  (defun make-predicate (name predicate type named name-offset)
235    (cond ((null type))    (cond ((null type))
236           ; done in define-structure           ; done in define-structure
# Line 391  Line 407 
407               (list ar (round-up pos (size-of t)) has-holes)               (list ar (round-up pos (size-of t)) has-holes)
408               ))))               ))))
409    
   
   
   
                 
                         
                         
                         
                         
                         
                         
                       
               
           
           
   
   
                                         
                                   
                                 
                 
           
   
410  (defun define-structure (name conc-name no-conc type named slot-descriptions copier  (defun define-structure (name conc-name no-conc type named slot-descriptions copier
411                                static include print-function constructors                                static include print-function constructors
412                                offset predicate &optional documentation no-funs                                offset predicate &optional documentation no-funs
# Line 420  Line 414 
414    (and (consp type) (eq (car type) 'vector)(setq type 'vector))    (and (consp type) (eq (car type) 'vector)(setq type 'vector))
415    (setq leng(length slot-descriptions))    (setq leng(length slot-descriptions))
416    (dolist (x slot-descriptions)    (dolist (x slot-descriptions)
417             (and x (car x)      (and x (car x)
418                  (apply #'make-access-function           (apply #'make-access-function
419                                       name conc-name no-conc type named include no-funs                  name conc-name no-conc type named include no-funs
420                                       x )))                  x )))
421    (when (and copier (not no-funs))    (when (and copier (not no-funs))
422          (setf (symbol-function copier)          (setf (symbol-function copier)
423                (ecase type                (ecase type
# Line 492  Line 486 
486             (or tem (setf (get name 's-data) def)))             (or tem (setf (get name 's-data) def)))
487            (tem            (tem
488             (check-s-data tem def name))             (check-s-data tem def name))
489            (t  (setf (get name 's-data) def)))            (t (setf (get name 's-data) def)))
490      (when documentation      (when documentation
491            (setf (get name 'structure-documentation)            (setf (get name 'structure-documentation)
492                  documentation))                  documentation))
# Line 687  Line 681 
681      ;; Check the print-function.      ;; Check the print-function.
682      (when (and print-function type)      (when (and print-function type)
683            (error "A print function is supplied to a typed structure."))            (error "A print function is supplied to a typed structure."))
       
     `(progn  
        (define-structure ',name  ',conc-name ',no-conc ',type  
          ',named ',slot-descriptions ',copier ',static ',include ',print-function ',constructors  
          ',offset ',predicate ',documentation  
          )  
684    
685         ,@(mapcar #'(lambda (constructor)      (let* (new-slot-descriptions
686                       (make-constructor name constructor type named             (new-slot-descriptions ;(copy-list slot-descriptions)))
687                                         slot-descriptions))              (dolist (sd slot-descriptions (nreverse new-slot-descriptions))
688                   constructors)                (if (and (consp sd) (eql (length sd) 5))
689         ,@(if (and type predicate)                  (let* ((csd (car sd))
690               (list (make-predicate name predicate type named                         (sym (when (or (constantp csd) (keywordp csd) (si::specialp csd))
691                                     name-offset)))                                (make-symbol (symbol-name csd))))
692         ',name                         (nsd (if (or (constantp csd) (si::specialp csd))
693         )))                                  (cons (intern (symbol-name csd) 'keyword) (cdr sd))
694                                  sd)))
695                      (push (append nsd (list sym)) new-slot-descriptions)
696                      (when sym
697                        (setf (car sd) sym)))
698                    (push sd new-slot-descriptions)))))
699          `(progn
700             (define-structure ',name  ',conc-name ',no-conc ',type
701               ',named ',slot-descriptions ',copier ',static ',include
702               ',print-function ',constructors
703               ',offset ',predicate ',documentation
704               )
705            
706             ,@(mapcar #'(lambda (constructor)
707                           (make-constructor name constructor type named new-slot-descriptions))
708                       constructors)
709             ,@(if (and type predicate)
710                   (list (make-predicate name predicate type named
711                                         name-offset)))
712             ',name
713             ))))
714    
715  ;; First several fields of this must coincide with the C structure  ;; First several fields of this must coincide with the C structure
716  ;; s_data (see object.h).  ;; s_data (see object.h).

Legend:
Removed from v.1.3  
changed lines
  Added in v.1.4

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