X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=ecmalisp.lisp;h=bf4810b5111f6474c8bf22bd5debff9112b23a23;hb=b500e8a044b964db4baff9e387d0ddd1748eb690;hp=4bc10b9f03d749e25cfd67a00c5c1b10ef665348;hpb=3dc57c3e0087b711cd7845b2c268b9f5c60d9a0d;p=jscl.git

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index 4bc10b9..bf4810b 100644
--- a/ecmalisp.lisp
+++ b/ecmalisp.lisp
@@ -383,6 +383,61 @@
            ,@body)
          (cdr ,head))))
 
+  ;; A very simple defstruct built on lists. It supports just slot with
+  ;; an optional default initform, and it will create a constructor,
+  ;; predicate and accessors for you.
+  (defmacro defstruct (name &rest slots)
+    (unless (symbolp name)
+      (error "It is not a full defstruct implementation."))
+    (let* ((name-string (symbol-name name))
+           (slot-descriptions
+            (mapcar (lambda (sd)
+                      (cond
+                        ((symbolp sd)
+                         (list sd))
+                        ((and (listp sd) (car sd) (cddr sd))
+                         sd)
+                        (t
+                         (error "Bad slot accessor."))))
+                    slots))
+           (predicate (intern (concat name-string "P"))))
+      `(progn
+         ;; Constructor
+         (defun ,(intern (concat "MAKE-" name-string)) (&key ,@slot-descriptions)
+           (list ',name ,@(mapcar #'car slot-descriptions)))
+         ;; Predicate
+         (defun ,predicate (x)
+           (and (consp x) (eq (car x) ',name)))
+         ;; Copier
+         (defun ,(intern (concat "COPY-" name-string)) (x)
+           (copy-list x))
+         ;; Slot accessors
+         ,@(with-collect
+            (let ((index 1))
+              (dolist (slot slot-descriptions)
+                (let* ((name (car slot))
+                       (accessor-name (intern (concat name-string "-" (string name)))))
+                  (collect
+                      `(defun ,accessor-name (x)
+                           (unless (,predicate x)
+                             (error ,(concat "The object is not a type " name-string)))
+                         (nth ,index x)))
+                  ;; TODO: Implement this with a higher level
+                  ;; abstraction like defsetf or (defun (setf ..))
+                  (collect
+                      `(define-setf-expander ,accessor-name (x)
+                         (let ((object (gensym))
+                               (new-value (gensym)))
+                           (values (list object)
+                                   (list x)
+                                   (list new-value)
+                                   `(progn
+                                      (rplaca (nthcdr ,',index ,object) ,new-value) 
+                                      ,new-value)
+                                   `(,',accessor-name ,object)))))
+                  (incf index)))))
+         ',name)))
+
   (defun map1 (func list)
     (with-collect
         (while list
@@ -966,7 +1021,9 @@
                        "()"
                        (prin1-to-string (vector-to-list form)))))
       ((packagep form)
-       (concat "#<PACKAGE " (package-name form) ">"))))
+       (concat "#<PACKAGE " (package-name form) ">"))
+      (t
+       (concat "#<javascript object>"))))
 
   (defun write-line (x)
     (write-string x)
@@ -1157,8 +1214,8 @@
 	  (values nil index)))))
 
 #+ecmalisp
-(defun parse-integer (string &key junk-allowed)
-  (!parse-integer string junk-allowed))
+(defun parse-integer (string)
+  (!parse-integer string nil))
 
 (defvar *eof* (gensym))
 (defun ls-read (stream)
@@ -2724,10 +2781,9 @@
 (defvar *compile-print-toplevels* nil)
 
 (defun truncate-string (string &optional (width 60))
-    (let ((size (length string))
-          (n (or (position #\newline string)
-                 (min width (length string)))))
-      (subseq string 0 n)))
+  (let ((n (or (position #\newline string)
+               (min width (length string)))))
+    (subseq string 0 n)))
 
 (defun ls-compile-toplevel (sexp &optional multiple-value-p)
   (let ((*toplevel-compilations* nil))