Ignore:
Timestamp:
10/05/03 15:36:54 (19 years ago)
Author:
piso
Message:

Refactoring.

File:
1 edited

Legend:

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

    r4156 r4200  
    22;;;
    33;;; Copyright (C) 2003 Peter Graves
    4 ;;; $Id: defstruct.lisp,v 1.24 2003-10-01 13:59:52 piso Exp $
     4;;; $Id: defstruct.lisp,v 1.25 2003-10-05 15:36:54 piso Exp $
    55;;;
    66;;; This program is free software; you can redistribute it and/or
     
    2222(defvar *ds-name*)
    2323(defvar *ds-conc-name*)
    24 (defvar *ds-constructor*)
     24(defvar *ds-constructors*)
    2525(defvar *ds-copier*)
    2626(defvar *ds-named*)
     
    2828(defvar *ds-print-function*)
    2929
    30 (defun define-constructor (slots)
    31   (when *ds-constructor*
    32     (let* ((constructor (intern *ds-constructor*))
    33            (slot-names (mapcar #'(lambda (x) (if (atom x) x (car x))) slots))
    34            (inits (mapcar #'(lambda (x) (if (atom x) nil (cadr x))) slots))
    35            (slot-descriptions (mapcar #'(lambda (x y) (list x y)) slot-names inits))
    36            (keys (cons '&key slot-descriptions)))
    37       `((defun ,constructor ,keys
    38           (%make-structure ',*ds-name* (list ,@slot-names)))))))
     30(defun define-constructor (constructor slots)
     31  (let* ((constructor-name (intern (car constructor)))
     32         (slot-names (mapcar #'(lambda (x) (if (atom x) x (car x))) slots))
     33         (inits (mapcar #'(lambda (x) (if (atom x) nil (cadr x))) slots))
     34         (slot-descriptions (mapcar #'(lambda (x y) (list x y)) slot-names inits))
     35         (keys (cons '&key slot-descriptions)))
     36    `((defun ,constructor-name ,keys
     37        (%make-structure ',*ds-name* (list ,@slot-names))))))
     38
     39(defun default-constructor-name ()
     40  (concatenate 'string "MAKE-" (symbol-name *ds-name*)))
     41
     42(defun define-constructors (slots)
     43  (if *ds-constructors*
     44      (let ((results ()))
     45        (dolist (constructor *ds-constructors*)
     46          (when (car constructor)
     47            (setf results (append results (define-constructor constructor slots)))))
     48        results)
     49      (define-constructor (cons (default-constructor-name) nil) slots)))
    3950
    4051(defun define-predicate ()
     
    7485    (dolist (slot slots)
    7586      (let ((slot-name (if (atom slot) slot (car slot))))
    76         (setq result (append result (define-access-function slot-name index))))
     87        (setf result (append result (define-access-function slot-name index))))
    7788      (incf index))
    7889    result))
     
    89100                              (make-symbol (string (cadr option))))))
    90101    (:constructor
    91      (when (= (length option) 2)
    92        (if (null (cadr option))
    93            (setf *ds-constructor* nil)
    94            (setf *ds-constructor* (symbol-name (cadr option))))))
     102     (let* ((args (cdr option))
     103            (numargs (length args))
     104            name arglist)
     105       (case numargs
     106         (0 ; Use default name.
     107          (setf name (default-constructor-name))
     108          (setf arglist nil)
     109          (push (list name arglist) *ds-constructors*))
     110         (1
     111          (if (null (car args))
     112              (setf name nil) ; No constructor.
     113              (setf name (symbol-name (car args))))
     114          (setf arglist nil)
     115          (push (list name arglist) *ds-constructors*))
     116         (2))))
    95117    (:predicate
    96118     (when (= (length option) 2)
     
    102124  (setf *ds-name* (car name-and-options))
    103125  (setf *ds-conc-name* (make-symbol (concatenate 'string (symbol-name *ds-name*) "-")))
    104   (setf *ds-constructor* (concatenate 'string "MAKE-" (symbol-name *ds-name*)))
    105126  (setf *ds-predicate* (concatenate 'string (symbol-name *ds-name*) "-P"))
    106127  (let ((options (cdr name-and-options)))
     
    119140  (let ((*ds-name* nil)
    120141        (*ds-conc-name* nil)
    121         (*ds-constructor* nil)
     142        (*ds-constructors* nil)
    122143        (*ds-copier* nil)
    123144        (*ds-predicate* nil)
     
    130151    `(progn
    131152       (make-structure-class ',*ds-name*)
    132        ,@(define-constructor slots)
     153       ,@(define-constructors slots)
    133154       ,@(define-predicate)
    134155       ,@(define-access-functions slots)
Note: See TracChangeset for help on using the changeset viewer.