Changeset 4009

Timestamp:

09/22/03 22:56:12 (20 years ago)

Author:

piso

Message:

Support :PREDICATE option.

File:

• trunk/j/src/org/armedbear/lisp/defstruct.lisp (modified) (4 diffs)

trunk/j/src/org/armedbear/lisp/defstruct.lisp

@@ -2 +2 @@
 ;;;
 ;;; Copyright (C) 2003 Peter Graves
-;;; $Id: defstruct.lisp,v 1.20 2003-09-22 17:46:26 piso Exp $
+;;; $Id: defstruct.lisp,v 1.21 2003-09-22 22:56:12 piso Exp $
 ;;;
 ;;; This program is free software; you can redistribute it and/or
@@ -39 +39 @@
 
 (defun define-predicate ()
-  (let ((pred (intern (concatenate 'string (symbol-name *ds-name*) "-P"))))
-    `((defun ,pred (object)
-        (typep object ',*ds-name*)))))
+  (when *ds-predicate*
+    (let ((pred (intern *ds-predicate*)))
+      `((defun ,pred (object)
+          (typep object ',*ds-name*))))))
+
 
 (defmacro get-slot-accessor (slot)
@@ -88 +90 @@
                               (make-symbol (string (cadr option))))))
     (:constructor
-     (when (= (length (cdr option)) 1)
+     (when (= (length option) 2)
        (if (null (cadr option))
            (setf *ds-constructor* nil)
-           (setf *ds-constructor* (symbol-name (cadr option))))))))
+           (setf *ds-constructor* (symbol-name (cadr option))))))
+    (:predicate
+     (when (= (length option) 2)
+       (if (null (cadr option))
+           (setf *ds-predicate* nil)
+           (setf *ds-predicate* (symbol-name (cadr option))))))))
 
 (defun parse-name-and-options (name-and-options)
@@ -97 +104 @@
   (setf *ds-conc-name* (make-symbol (concatenate 'string (symbol-name *ds-name*) "-")))
   (setf *ds-constructor* (concatenate 'string "MAKE-" (symbol-name *ds-name*)))
+  (setf *ds-predicate* (concatenate 'string (symbol-name *ds-name*) "-P"))
   (let ((options (cdr name-and-options)))
     (dolist (option options)