git » jacl.git » commit 4288788

diff --git a/boot.lisp b/boot.lisp
index b06b4af..e116887 100644
--- a/boot.lisp
+++ b/boot.lisp
@@ -77,6 +77,20 @@
   (when (not (null x))
     (jacl:\. x |cdr|)))
 
+(%export 'rplacd)
+(defun rplacd (cons obj)
+  ;; TODO type check
+  (jacl:%js "~{}.cdr=~{}" cons obj)
+  cons)
+
+(%export 'cadr)
+(defun cadr (x)
+  (car (cdr x)))
+
+(%export 'cddr)
+(defun cddr (x)
+  (cdr (cdr x)))
+
 (%export 'caar)
 (defun caar (x)
   (car (car x)))
@@ -181,6 +195,47 @@
 (defmacro lambda (params &rest body)
   `(jacl:%lambda ,params ,@body))
 
+(%export 'list)
+(defun list (&rest objects)
+  `(,@objects))
+
+(%export 'functionp)
+(defun functionp (x)
+  (jacl:%js "~{} instanceof Function ? true : null" x))
+
+(defun %as-array (list)
+  (jacl:%js "List.toArray(~{})" list))
+
+(%export 'funcall)
+(defun funcall (f &rest args)
+  (let ((func (cond ((symbolp f) (\. f (|func|)))
+                    ((functionp f) f)
+                    (t (%type-error "function or symbol")))))
+    (\. func (|apply| nil (%as-array args)))))
+
+(defun %map-pairs (fun pairs)
+  (let ((head nil)
+        (tail nil))
+    (tagbody
+     start
+     (when (not pairs) (go end))
+     (when (not head)
+       (jacl:%setq head (list (funcall fun (car pairs) (cadr pairs))))
+       (jacl:%setq tail head)
+       (go next))
+     (let ((new-tail (list (funcall fun (car pairs) (cadr pairs)))))
+       (rplacd tail new-tail)
+       (jacl:%setq tail new-tail))
+     next
+     (jacl:%setq pairs (cddr pairs))
+     (go start)
+     end)
+    head))
+;
+(%export 'setq)
+(defmacro setq (&rest pairs)
+  `(cl:progn
+    ,@(%map-pairs (lambda (x y) `(jacl:%setq ,x ,y)) pairs)))
 ;;(defun %designated-string (x)
 ;;  (cond ((stringp x) x)
 ;;        ((symbolp x)