Defstruct copier function

[jscl.git] / ecmalisp.lisp

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index 9ab908e..bf4810b 100644 (file)
--- a/ecmalisp.lisp
+++ b/ecmalisp.lisp
@@ -163,7 +163,14 @@
     `(setq ,x (- ,x ,delta)))
 
   (defmacro push (x place)
     `(setq ,x (- ,x ,delta)))
 
   (defmacro push (x place)

-    `(setq ,place (cons ,x ,place)))
+    (multiple-value-bind (dummies vals newval setter getter)
+        (get-setf-expansion place)
+      (let ((g (gensym)))
+        `(let* ((,g ,x)
+                ,@(mapcar #'list dummies vals)
+                (,(car newval) (cons ,g ,getter))
+                ,@(cdr newval))
+           ,setter))))

 
   (defmacro dolist (iter &body body)
     (let ((var (first iter))
 
   (defmacro dolist (iter &body body)
     (let ((var (first iter))

@@ -376,6 +383,61 @@
            ,@body)
          (cdr ,head))))
 
            ,@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
   (defun map1 (func list)
     (with-collect
         (while list

@@ -466,6 +528,7 @@
       ((funcall func (car list))
        (remove-if func (cdr list)))
       (t
       ((funcall func (car list))
        (remove-if func (cdr list)))
       (t

+       ;;

        (cons (car list) (remove-if func (cdr list))))))
 
   (defun remove-if-not (func list)
        (cons (car list) (remove-if func (cdr list))))))
 
   (defun remove-if-not (func list)

@@ -495,39 +558,43 @@
       (t
        (error "Unsupported argument."))))
 
       (t
        (error "Unsupported argument."))))
 

+  (defmacro do-sequence (iteration &body body)
+    (let ((seq (gensym))
+          (index (gensym)))
+      `(let ((,seq ,(second iteration)))
+         (cond
+           ;; Strings
+           ((stringp ,seq)
+            (let ((,index 0))
+              (dotimes (,index (length ,seq))
+                (let ((,(first iteration)
+                       (char ,seq ,index)))
+                  ,@body))))
+           ;; Lists
+           ((listp ,seq)
+            (dolist (,(first iteration) ,seq)
+              ,@body))
+           (t
+            (error "type-error!"))))))
+

   (defun some (function seq)
   (defun some (function seq)

-    (cond
-      ((stringp seq)
-       (let ((index 0)
-             (size (length seq)))
-         (while (< index size)
-           (when (funcall function (char seq index))
-             (return-from some t))
-           (incf index))
-         nil))
-      ((listp seq)
-       (dolist (x seq nil)
-         (when (funcall function x)
-           (return t))))
-      (t
-       (error "Unknown sequence."))))
+    (do-sequence (elt seq)
+      (when (funcall function elt)
+        (return-from some t))))

 
   (defun every (function seq)
 
   (defun every (function seq)

-    (cond
-      ((stringp seq)
-       (let ((index 0)
-             (size (length seq)))
-         (while (< index size)
-           (unless (funcall function (char seq index))
-             (return-from every nil))
-           (incf index))
-         t))
-      ((listp seq)
-       (dolist (x seq t)
-         (unless (funcall function x)
-           (return))))
-      (t
-       (error "Unknown sequence."))))
+    (do-sequence (elt seq)
+      (unless (funcall function elt)
+        (return-from every nil)))
+    t)
+
+  (defun position (elt sequence)
+    (let ((pos 0))
+      (do-sequence (x seq)
+        (when (eq elt x)
+          (return))
+        (incf pos))
+      pos))

 
   (defun assoc (x alist)
     (while alist
 
   (defun assoc (x alist)
     (while alist

@@ -645,16 +712,6 @@
               `(progn (rplacd ,cons ,new-value) ,new-value)
               `(car ,cons))))
 
               `(progn (rplacd ,cons ,new-value) ,new-value)
               `(car ,cons))))
 

-  (defmacro push (x place)
-    (multiple-value-bind (dummies vals newval setter getter)
-        (get-setf-expansion place)
-      (let ((g (gensym)))
-        `(let* ((,g ,x)
-                ,@(mapcar #'list dummies vals)
-                (,(car newval) (cons ,g ,getter))
-                ,@(cdr newval))
-           ,setter))))
-

   ;; Incorrect typecase, but used in NCONC.
   (defmacro typecase (x &rest clausules)
     (let ((value (gensym)))
   ;; Incorrect typecase, but used in NCONC.
   (defmacro typecase (x &rest clausules)
     (let ((value (gensym)))

@@ -704,8 +761,8 @@
 
   (defun nreconc (x y)
     (do ((1st (cdr x) (if (endp 1st) 1st (cdr 1st)))
 
   (defun nreconc (x y)
     (do ((1st (cdr x) (if (endp 1st) 1st (cdr 1st)))

-         (2nd x 1st) ; 2nd follows first down the list.
-         (3rd y 2nd)) ;3rd follows 2nd down the list.
+         (2nd x 1st)                ; 2nd follows first down the list.
+         (3rd y 2nd))               ;3rd follows 2nd down the list.

         ((atom 2nd) 3rd)
       (rplacd 2nd 3rd)))
 
         ((atom 2nd) 3rd)
       (rplacd 2nd 3rd)))
 

@@ -960,9 +1017,13 @@
                      (concat (prin1-to-string (car last)) " . " (prin1-to-string (cdr last)))))
                ")"))
       ((arrayp form)
                      (concat (prin1-to-string (car last)) " . " (prin1-to-string (cdr last)))))
                ")"))
       ((arrayp form)

-       (concat "#" (prin1-to-string (vector-to-list form))))
+       (concat "#" (if (zerop (length form))
+                       "()"
+                       (prin1-to-string (vector-to-list form)))))

       ((packagep form)
       ((packagep form)

-       (concat "#<PACKAGE " (package-name form) ">"))))
+       (concat "#<PACKAGE " (package-name form) ">"))
+      (t
+       (concat "#<javascript object>"))))

 
   (defun write-line (x)
     (write-string x)
 
   (defun write-line (x)
     (write-string x)

@@ -2716,6 +2777,14 @@
       (t
        (error (concat "How should I compile " (prin1-to-string sexp) "?"))))))
 
       (t
        (error (concat "How should I compile " (prin1-to-string sexp) "?"))))))
 

+
+(defvar *compile-print-toplevels* nil)
+
+(defun truncate-string (string &optional (width 60))
+  (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))
     (cond
 (defun ls-compile-toplevel (sexp &optional multiple-value-p)
   (let ((*toplevel-compilations* nil))
     (cond

@@ -2725,6 +2794,12 @@
                            (cdr sexp))))
          (join (remove-if #'null-or-empty-p subs))))
       (t
                            (cdr sexp))))
          (join (remove-if #'null-or-empty-p subs))))
       (t

+       (when *compile-print-toplevels*
+         (let ((form-string (prin1-to-string sexp)))
+           (write-string "Compiling ")
+           (write-string (truncate-string form-string))
+           (write-line "...")))
+       

        (let ((code (ls-compile sexp multiple-value-p)))
          (code (join-trailing (get-toplevel-compilations)
                               (code ";" *newline*))
        (let ((code (ls-compile sexp multiple-value-p)))
          (code (join-trailing (get-toplevel-compilations)
                               (code ";" *newline*))

@@ -2808,8 +2883,9 @@
         (read-sequence seq in)
         seq)))
 
         (read-sequence seq in)
         seq)))
 

-  (defun ls-compile-file (filename output)
-    (let ((*compiling-file* t))
+  (defun ls-compile-file (filename output &key print)
+    (let ((*compiling-file* t)
+          (*compile-print-toplevels* print))

       (with-open-file (out output :direction :output :if-exists :supersede)
         (write-string (read-whole-file "prelude.js") out)
         (let* ((source (read-whole-file filename))
       (with-open-file (out output :direction :output :if-exists :supersede)
         (write-string (read-whole-file "prelude.js") out)
         (let* ((source (read-whole-file filename))

@@ -2828,4 +2904,4 @@
           *gensym-counter* 0
           *literal-counter* 0
           *block-counter* 0)
           *gensym-counter* 0
           *literal-counter* 0
           *block-counter* 0)

-    (ls-compile-file "ecmalisp.lisp" "ecmalisp.js")))
+    (ls-compile-file "ecmalisp.lisp" "ecmalisp.js" :print t)))