Changeset 4870


Ignore:
Timestamp:
11/22/03 18:57:34 (18 years ago)
Author:
piso
Message:

Added support for boa constructors.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/j/src/org/armedbear/lisp/defstruct.lisp

    r4868 r4870  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: defstruct.lisp,v 1.42 2003-11-22 16:32:39 piso Exp $
     4;;; $Id: defstruct.lisp,v 1.43 2003-11-22 18:57:34 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    103103  (let* ((constructor-name (intern (car constructor)))
    104104         (keys ())
    105          (elements ()))
     105         (values ()))
    106106    (dolist (slot *dd-slots*)
    107107      (let ((name (dsd-name slot))
     
    114114            (initform (dsd-initform dsd)))
    115115        (if name
    116             (push name elements)
    117             (push initform elements))))
    118     (setf elements (nreverse elements))
     116            (push name values)
     117            (push initform values))))
     118    (setf values (nreverse values))
    119119    (cond ((eq *dd-type* 'list)
    120120           `((defun ,constructor-name ,keys
    121                (list ,@elements))))
     121               (list ,@values))))
    122122          ((or (eq *dd-type* 'vector)
    123123               (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
    124124           (let ((element-type (if (consp *dd-type*) (cadr *dd-type*) t)))
    125125             `((defun ,constructor-name ,keys
    126                  (make-array ,(length elements)
     126                 (make-array ,(length values)
    127127                             :element-type ',element-type
    128                              :initial-contents (list ,@elements))))))
     128                             :initial-contents (list ,@values))))))
    129129          (t
    130130           `((defun ,constructor-name ,keys
    131                (%make-structure ',*dd-name* (list ,@elements))))))))
     131               (%make-structure ',*dd-name* (list ,@values))))))))
     132
     133(defun get-slot (name)
     134;;   (let ((res (find name (dd-slots defstruct) :test #'string= :key #'dsd-name)))
     135  (let ((res nil))
     136    (dolist (dsd *dd-slots*)
     137      (when (string= name (dsd-name dsd))
     138        (setf res dsd)
     139        (return)))
     140    (if res
     141        (values (dsd-type res) (dsd-initform res))
     142        (values t nil))))
    132143
    133144(defun define-boa-constructor (constructor)
    134   )
     145  (multiple-value-bind (req opt restp rest keyp keys allowp auxp aux)
     146    (parse-lambda-list (cadr constructor))
     147    (let ((arglist ())
     148          (vars ())
     149          (types ())
     150          (skipped-vars ()))
     151      (dolist (arg req)
     152        (push arg arglist)
     153        (push arg vars)
     154        (push (get-slot arg) types))
     155      (when opt
     156        (push '&optional arglist)
     157        (dolist (arg opt)
     158          (cond ((consp arg)
     159                 (destructuring-bind
     160                  (name
     161                   &optional
     162                   (def (nth-value 1 (get-slot name)))
     163                   (supplied-test nil supplied-test-p))
     164                  arg
     165                  (push `(,name ,def ,@(if supplied-test-p `(,supplied-test) nil)) arglist)
     166                  (push name vars)
     167                  (push (get-slot name) types)))
     168                (t
     169                 (multiple-value-bind (type default) (get-slot arg)
     170                   (push `(,arg ,default) arglist)
     171                   (push arg vars)
     172                   (push type types))))))
     173      (when restp
     174        (push '&rest arglist)
     175        (push rest arglist)
     176        (push rest vars)
     177        (push 'list types))
     178      (when keyp
     179        (push '&key arglist)
     180        (dolist (key keys)
     181          (if (consp key)
     182              (destructuring-bind (wot
     183                                   &optional
     184                                   (def nil def-p)
     185                                   (supplied-test nil supplied-test-p))
     186                                  key
     187                                  (let ((name (if (consp wot)
     188                                                  (destructuring-bind (key var) wot
     189                                                                      (declare (ignore key))
     190                                                                      var)
     191                                                  wot)))
     192                                    (multiple-value-bind (type slot-def)
     193                                      (get-slot name)
     194                                      (push `(,wot ,(if def-p def slot-def)
     195                                                   ,@(if supplied-test-p `(,supplied-test) nil))
     196                                            arglist)
     197                                      (push name vars)
     198                                      (push type types))))
     199              (multiple-value-bind (type default) (get-slot key)
     200                (push `(,key ,default) arglist)
     201                (push key vars)
     202                (push type types)))))
     203      (when allowp
     204        (push '&allow-other-keys arglist))
     205      (when auxp
     206        (push '&aux arglist)
     207        (dolist (arg aux)
     208          (push arg arglist)
     209          (if (and (consp arg) (= (length arg) 2))
     210              (let ((var (first arg)))
     211                (push var vars)
     212                (push (get-slot var) types))
     213              (push (if (consp arg) (first arg) arg) skipped-vars))))
     214      (setf arglist (nreverse arglist)
     215            var (nreverse vars)
     216            types (nreverse types)
     217            skipped-vars (nreverse skipped-vars))
     218      (let ((values ()))
     219        (dolist (dsd *dd-slots*)
     220          (let ((name (dsd-name dsd))
     221                var)
     222            (cond ((find name skipped-vars :test #'string=)
     223                   (push nil values))
     224                  ((setf var (find name vars :test #'string=))
     225                   (push var values))
     226                  (t
     227                   (push (dsd-initform dsd) values)))))
     228        (setf values (nreverse values))
     229        (let* ((constructor-name (intern (car constructor))))
     230          (cond ((eq *dd-type* 'list)
     231                 `((defun ,constructor-name ,arglist
     232                     (list ,@values))))
     233                ((or (eq *dd-type* 'vector)
     234                     (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
     235                 (let ((element-type (if (consp *dd-type*) (cadr *dd-type*) t)))
     236                   `((defun ,constructor-name ,arglist
     237                       (make-array ,(length values)
     238                                   :element-type ',element-type
     239                                   :initial-contents (list ,@values))))))
     240                (t
     241                 `((defun ,constructor-name ,arglist
     242                     (%make-structure ',*dd-name* (list ,@values)))))))))))
    135243
    136244(defun default-constructor-name ()
     
    248356       (case numargs
    249357         (0 ; Use default name.
    250           (setf name (default-constructor-name))
    251           (setf arglist nil)
     358          (setf name (default-constructor-name)
     359                arglist nil)
    252360          (push (list name arglist) *dd-constructors*))
    253361         (1
     
    257365          (setf arglist nil)
    258366          (push (list name arglist) *dd-constructors*))
    259          (2))))
     367         (2
     368          (setf name (symbol-name (car args))
     369                arglist (cadr args))
     370          (push (list name arglist) *dd-constructors*)))))
    260371    (:copier
    261372     (let* ((args (cdr option))
Note: See TracChangeset for help on using the changeset viewer.