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

Diff of /gcl/lsp/defstruct.lsp

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

revision 1.2 by camm, Sat Oct 5 18:34:15 2002 UTC revision 1.3 by camm, Tue Feb 18 04:06:52 2003 UTC
# Line 44  Line 44 
44  (or (fboundp 'record-fn) (setf (symbol-function 'record-fn)  (or (fboundp 'record-fn) (setf (symbol-function 'record-fn)
45                                 #'(lambda (&rest l) l nil)))                                 #'(lambda (&rest l) l nil)))
46    
47  (defun make-access-function (name conc-name type named include no-fun  (defun make-access-function (name conc-name no-conc type named include no-fun
48                                    ;; from apply                                    ;; from apply
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        
53    (let ((access-function    (let ((access-function
54            (intern (si:string-concatenate (string conc-name)           (if no-conc
55                                           (string slot-name))))               slot-name
56               (intern (si:string-concatenate (string conc-name)
57                                              (string slot-name)))))
58          accsrs dont-overwrite)          accsrs dont-overwrite)
59      (ecase type      (ecase type
60        ((nil)        ((nil)
# Line 478  Line 480 
480                                
481                    
482    
483  (defun define-structure (name conc-name type named slot-descriptions copier  (defun define-structure (name conc-name no-conc type named slot-descriptions copier
484                                static include print-function constructors                                static include print-function constructors
485                                offset predicate &optional documentation no-funs                                offset predicate &optional documentation no-funs
486                                &aux def leng)                                &aux def leng)
# Line 487  Line 489 
489    (dolist (x slot-descriptions)    (dolist (x slot-descriptions)
490             (and x (car x)             (and x (car x)
491                  (apply #'make-access-function                  (apply #'make-access-function
492                                       name conc-name type named include no-funs                                       name conc-name no-conc type named include no-funs
493                                       x )))                                       x )))
494    (when (and copier (not no-funs))    (when (and copier (not no-funs))
495          (setf (symbol-function copier)          (setf (symbol-function copier)
# Line 585  Line 587 
587          print-function type named initial-offset          print-function type named initial-offset
588          offset name-offset          offset name-offset
589          documentation          documentation
590          static)          static
591            (no-conc nil))
592    
593      (when (consp name)      (when (consp name)
594            ;; The defstruct options are supplied.            ;; The defstruct options are supplied.
# Line 612  Line 615 
615                 (setq o (caar os) v (cadar os))                 (setq o (caar os) v (cadar os))
616                 (case o                 (case o
617                   (:conc-name                   (:conc-name
618                     (if (null v)                     (if (null v)
619                         (setq conc-name "")                         (progn
620                             (setq conc-name "")
621                             (setq no-conc t))
622                       (setq conc-name v)))                       (setq conc-name v)))
623                   (:constructor                   (:constructor
624                     (if (null v)                     (if (null v)
# Line 645  Line 650 
650                    (:constructor                    (:constructor
651                      (setq constructors                      (setq constructors
652                            (cons default-constructor constructors)))                            (cons default-constructor constructors)))
653                    ((:conc-name :copier :predicate :print-function))                    ((:copier :predicate :print-function))
654                      (:conc-name
655                       (progn
656                         (setq conc-name "")
657                         (setq no-conc t)))
658                    (:named (setq named t))                    (:named (setq named t))
659                    (t (error "~S is an illegal defstruct option." o))))))                    (t (error "~S is an illegal defstruct option." o))))))
660    
# Line 747  Line 756 
756            (error "A print function is supplied to a typed structure."))            (error "A print function is supplied to a typed structure."))
757            
758      `(progn      `(progn
759         (define-structure ',name  ',conc-name ',type         (define-structure ',name  ',conc-name ',no-conc ',type
760           ',named ',slot-descriptions ',copier ',static ',include ',print-function ',constructors           ',named ',slot-descriptions ',copier ',static ',include ',print-function ',constructors
761           ',offset ',predicate ',documentation           ',offset ',predicate ',documentation
762           )           )

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

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