Changeset 8618


Ignore:
Timestamp:
02/20/05 19:13:55 (16 years ago)
Author:
piso
Message:

DEFSTRUCT-DEFAULT-CONSTRUCTOR

Location:
trunk/j/src/org/armedbear/lisp
Files:
2 edited

Legend:

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

    r8540 r8618  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: autoloads.lisp,v 1.176 2005-02-12 02:34:11 piso Exp $
     4;;; $Id: autoloads.lisp,v 1.177 2005-02-20 19:13:55 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    101101(autoload '(tpl::top-level-loop) "top-level")
    102102
    103 (autoload 'make-defstruct-description "defstruct")
     103(autoload '(make-defstruct-description defstruct-default-constructor)
     104          "defstruct")
    104105
    105106(autoload-macro 'defstruct)
  • trunk/j/src/org/armedbear/lisp/defstruct.lisp

    r8616 r8618  
    22;;;
    33;;; Copyright (C) 2003-2005 Peter Graves
    4 ;;; $Id: defstruct.lisp,v 1.61 2005-02-20 18:23:08 piso Exp $
     4;;; $Id: defstruct.lisp,v 1.62 2005-02-20 19:13:29 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    114114
    115115(defun define-keyword-constructor (constructor)
    116   (let* ((constructor-name (intern (car constructor)))
     116  (let* ((constructor-name (car constructor))
    117117         (keys ())
    118118         (values ()))
     
    242242                   (push (dsd-initform dsd) values)))))
    243243        (setf values (nreverse values))
    244         (let* ((constructor-name (intern (car constructor))))
     244        (let* ((constructor-name (car constructor)))
    245245          (cond ((eq *dd-type* 'list)
    246246                 `((defun ,constructor-name ,arglist
     
    258258
    259259(defun default-constructor-name ()
    260   (concatenate 'string "MAKE-" (symbol-name *dd-name*)))
     260  (intern (concatenate 'string "MAKE-" (symbol-name *dd-name*))))
    261261
    262262(defun define-constructors ()
     
    384384    (:constructor
    385385     (let* ((args (cdr option))
    386             (numargs (length args))
    387             name arglist)
     386            (numargs (length args)))
    388387       (case numargs
    389388         (0 ; Use default name.
    390           (setf name (default-constructor-name)
    391                 arglist nil)
    392           (push (list name arglist) *dd-constructors*)
    393           )
     389          (push (list (default-constructor-name) nil) *dd-constructors*))
    394390         (1
    395           (if (null (car args))
    396               (setf name nil) ; No constructor.
    397               (setf name (symbol-name (car args))))
    398           (setf arglist nil)
    399           (push (list name arglist) *dd-constructors*))
     391          (push (list (car args) nil) *dd-constructors*))
    400392         (2
    401           (setf name (symbol-name (car args))
    402                 arglist (cadr args))
    403           (push (list name arglist) *dd-constructors*)))))
     393          (push args *dd-constructors*)))))
    404394    (:copier
    405395     (let* ((args (cdr option))
     
    458448                                (list name-and-options)
    459449                                name-and-options))
     450    (if *dd-constructors*
     451        (dolist (constructor *dd-constructors*)
     452          (unless (cadr constructor)
     453            (setf *dd-default-constructor* (car constructor))
     454            (return)))
     455        (setf *dd-default-constructor* (default-constructor-name)))
    460456    (when (stringp (car slots))
    461457      (%set-documentation *dd-name* 'structure (pop slots)))
     
    566562           ,@(define-print-function)
    567563           ',*dd-name*))))
     564
     565(defun defstruct-default-constructor (arg)
     566  (let ((type (cond ((symbolp arg)
     567                     arg)
     568                    ((classp arg)
     569                     (class-name arg))
     570                    (t
     571                     (type-of arg)))))
     572    (when type
     573      (let ((dd (get type 'structure-definition)))
     574        (and dd (dd-default-constructor dd))))))
Note: See TracChangeset for help on using the changeset viewer.