From: David Vázquez <davazp@gmail.com>
Date: Thu, 25 Apr 2013 12:18:41 +0000 (+0100)
Subject: Move CL-compatibility code to compat.lisp
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=5ca0069cfc0e15bfb7b144950c9ce5c450cd91fb;p=jscl.git

Move CL-compatibility code to compat.lisp
---

diff --git a/boot.lisp b/boot.lisp
index 595fd07..fe5fb66 100644
--- a/boot.lisp
+++ b/boot.lisp
@@ -252,3 +252,595 @@
 
 (defmacro prog2 (form1 result &body body)
   `(prog1 (progn ,form1 ,result) ,@body))
+
+
+
+;;; Go on growing the Lisp language in Ecmalisp, with more high level
+;;; utilities as well as correct versions of other constructions.
+
+(defun + (&rest args)
+  (let ((r 0))
+    (dolist (x args r)
+      (incf r x))))
+
+(defun - (x &rest others)
+  (if (null others)
+      (- x)
+      (let ((r x))
+        (dolist (y others r)
+          (decf r y)))))
+
+(defun append-two (list1 list2)
+  (if (null list1)
+      list2
+      (cons (car list1)
+            (append (cdr list1) list2))))
+
+(defun append (&rest lists)
+  (!reduce #'append-two lists))
+
+(defun revappend (list1 list2)
+  (while list1
+    (push (car list1) list2)
+    (setq list1 (cdr list1)))
+  list2)
+
+(defun reverse (list)
+  (revappend list '()))
+
+(defmacro psetq (&rest pairs)
+  (let (;; For each pair, we store here a list of the form
+        ;; (VARIABLE GENSYM VALUE).
+        (assignments '()))
+    (while t
+      (cond
+        ((null pairs) (return))
+        ((null (cdr pairs))
+         (error "Odd paris in PSETQ"))
+        (t
+         (let ((variable (car pairs))
+               (value (cadr pairs)))
+           (push `(,variable ,(gensym) ,value)  assignments)
+           (setq pairs (cddr pairs))))))
+    (setq assignments (reverse assignments))
+    ;;
+    `(let ,(mapcar #'cdr assignments)
+       (setq ,@(!reduce #'append (mapcar #'butlast assignments))))))
+
+(defmacro do (varlist endlist &body body)
+  `(block nil
+     (let ,(mapcar (lambda (x) (list (first x) (second x))) varlist)
+       (while t
+         (when ,(car endlist)
+           (return (progn ,@(cdr endlist))))
+         (tagbody ,@body)
+         (psetq
+          ,@(apply #'append
+                   (mapcar (lambda (v)
+                             (and (consp (cddr v))
+                                  (list (first v) (third v))))
+                           varlist)))))))
+
+(defmacro do* (varlist endlist &body body)
+  `(block nil
+     (let* ,(mapcar (lambda (x) (list (first x) (second x))) varlist)
+       (while t
+         (when ,(car endlist)
+           (return (progn ,@(cdr endlist))))
+         (tagbody ,@body)
+         (setq
+          ,@(apply #'append
+                   (mapcar (lambda (v)
+                             (and (consp (cddr v))
+                                  (list (first v) (third v))))
+                           varlist)))))))
+
+(defun list-length (list)
+  (let ((l 0))
+    (while (not (null list))
+      (incf l)
+      (setq list (cdr list)))
+    l))
+
+(defun length (seq)
+  (cond
+    ((stringp seq)
+     (string-length seq))
+    ((arrayp seq)
+     (oget seq "length"))
+    ((listp seq)
+     (list-length seq))))
+
+(defun concat-two (s1 s2)
+  (concat-two s1 s2))
+
+(defmacro with-collect (&body body)
+  (let ((head (gensym))
+        (tail (gensym)))
+    `(let* ((,head (cons 'sentinel nil))
+            (,tail ,head))
+       (flet ((collect (x)
+                (rplacd ,tail (cons x nil))
+                (setq ,tail (cdr ,tail))
+                x))
+         ,@body)
+       (cdr ,head))))
+
+(defun map1 (func list)
+  (with-collect
+    (while list
+      (collect (funcall func (car list)))
+      (setq list (cdr list)))))
+
+(defmacro loop (&body body)
+  `(while t ,@body))
+
+(defun mapcar (func list &rest lists)
+  (let ((lists (cons list lists)))
+    (with-collect
+      (block loop
+        (loop
+           (let ((elems (map1 #'car lists)))
+             (do ((tail lists (cdr tail)))
+                 ((null tail))
+               (when (null (car tail)) (return-from loop))
+               (rplaca tail (cdar tail)))
+             (collect (apply func elems))))))))
+
+(defun identity (x) x)
+
+(defun constantly (x)
+  (lambda (&rest args)
+    x))
+
+(defun copy-list (x)
+  (mapcar #'identity x))
+
+(defun list* (arg &rest others)
+  (cond ((null others) arg)
+        ((null (cdr others)) (cons arg (car others)))
+        (t (do ((x others (cdr x)))
+               ((null (cddr x)) (rplacd x (cadr x))))
+           (cons arg others))))
+
+(defun code-char (x) x)
+(defun char-code (x) x)
+(defun char= (x y) (= x y))
+
+(defun integerp (x)
+  (and (numberp x) (= (floor x) x)))
+
+(defun plusp (x) (< 0 x))
+(defun minusp (x) (< x 0))
+
+(defun listp (x)
+  (or (consp x) (null x)))
+
+(defun nthcdr (n list)
+  (while (and (plusp n) list)
+    (setq n (1- n))
+    (setq list (cdr list)))
+  list)
+
+(defun nth (n list)
+  (car (nthcdr n list)))
+
+(defun last (x)
+  (while (consp (cdr x))
+    (setq x (cdr x)))
+  x)
+
+(defun butlast (x)
+  (and (consp (cdr x))
+       (cons (car x) (butlast (cdr x)))))
+
+(defun member (x list)
+  (while list
+    (when (eql x (car list))
+      (return list))
+    (setq list (cdr list))))
+
+(defun find (item list &key key (test #'eql))
+  (dolist (x list)
+    (when (funcall test (funcall key x) item)
+      (return x))))
+
+(defun remove (x list)
+  (cond
+    ((null list)
+     nil)
+    ((eql x (car list))
+     (remove x (cdr list)))
+    (t
+     (cons (car list) (remove x (cdr list))))))
+
+(defun remove-if (func list)
+  (cond
+    ((null list)
+     nil)
+    ((funcall func (car list))
+     (remove-if func (cdr list)))
+    (t
+     ;;
+     (cons (car list) (remove-if func (cdr list))))))
+
+(defun remove-if-not (func list)
+  (cond
+    ((null list)
+     nil)
+    ((funcall func (car list))
+     (cons (car list) (remove-if-not func (cdr list))))
+    (t
+     (remove-if-not func (cdr list)))))
+
+(defun digit-char-p (x)
+  (if (and (<= #\0 x) (<= x #\9))
+      (- x #\0)
+      nil))
+
+(defun digit-char (weight)
+  (and (<= 0 weight 9)
+       (char "0123456789" weight)))
+
+(defun subseq (seq a &optional b)
+  (cond
+    ((stringp seq)
+     (if b
+         (slice seq a b)
+         (slice seq a)))
+    (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)
+  (do-sequence (elt seq)
+    (when (funcall function elt)
+      (return-from some t))))
+
+(defun every (function seq)
+  (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
+    (if (eql x (caar alist))
+        (return)
+        (setq alist (cdr alist))))
+  (car alist))
+
+(defun string (x)
+  (cond ((stringp x) x)
+        ((symbolp x) (symbol-name x))
+        (t (char-to-string x))))
+
+(defun string= (s1 s2)
+  (equal s1 s2))
+
+(defun fdefinition (x)
+  (cond
+    ((functionp x)
+     x)
+    ((symbolp x)
+     (symbol-function x))
+    (t
+     (error "Invalid function"))))
+
+(defun disassemble (function)
+  (write-line (lambda-code (fdefinition function)))
+  nil)
+
+(defun documentation (x type)
+  "Return the documentation of X. TYPE must be the symbol VARIABLE or FUNCTION."
+  (ecase type
+    (function
+     (let ((func (fdefinition x)))
+       (oget func "docstring")))
+    (variable
+     (unless (symbolp x)
+       (error "Wrong argument type! it should be a symbol"))
+     (oget x "vardoc"))))
+
+(defmacro multiple-value-bind (variables value-from &body body)
+  `(multiple-value-call (lambda (&optional ,@variables &rest ,(gensym))
+                          ,@body)
+     ,value-from))
+
+(defmacro multiple-value-list (value-from)
+  `(multiple-value-call #'list ,value-from))
+
+
+;;; Generalized references (SETF)
+
+(defvar *setf-expanders* nil)
+
+(defun get-setf-expansion (place)
+  (if (symbolp place)
+      (let ((value (gensym)))
+        (values nil
+                nil
+                `(,value)
+                `(setq ,place ,value)
+                place))
+      (let ((place (ls-macroexpand-1 place)))
+        (let* ((access-fn (car place))
+               (expander (cdr (assoc access-fn *setf-expanders*))))
+          (when (null expander)
+            (error "Unknown generalized reference."))
+          (apply expander (cdr place))))))
+
+(defmacro define-setf-expander (access-fn lambda-list &body body)
+  (unless (symbolp access-fn)
+    (error "ACCESS-FN must be a symbol."))
+  `(progn (push (cons ',access-fn (lambda ,lambda-list ,@body))
+                *setf-expanders*)
+          ',access-fn))
+
+(defmacro setf (&rest pairs)
+  (cond
+    ((null pairs)
+     nil)
+    ((null (cdr pairs))
+     (error "Odd number of arguments to setf."))
+    ((null (cddr pairs))
+     (let ((place (ls-macroexpand-1 (first pairs)))
+           (value (second pairs)))
+       (multiple-value-bind (vars vals store-vars writer-form reader-form)
+           (get-setf-expansion place)
+         ;; TODO: Optimize the expansion a little bit to avoid let*
+         ;; or multiple-value-bind when unnecesary.
+         `(let* ,(mapcar #'list vars vals)
+            (multiple-value-bind ,store-vars
+                ,value
+              ,writer-form)))))
+    (t
+     `(progn
+        ,@(do ((pairs pairs (cddr pairs))
+               (result '() (cons `(setf ,(car pairs) ,(cadr pairs)) result)))
+              ((null pairs)
+               (reverse result)))))))
+
+(define-setf-expander car (x)
+  (let ((cons (gensym))
+        (new-value (gensym)))
+    (values (list cons)
+            (list x)
+            (list new-value)
+            `(progn (rplaca ,cons ,new-value) ,new-value)
+            `(car ,cons))))
+
+(define-setf-expander cdr (x)
+  (let ((cons (gensym))
+        (new-value (gensym)))
+    (values (list cons)
+            (list x)
+            (list new-value)
+            `(progn (rplacd ,cons ,new-value) ,new-value)
+            `(car ,cons))))
+
+;; Incorrect typecase, but used in NCONC.
+(defmacro typecase (x &rest clausules)
+  (let ((value (gensym)))
+    `(let ((,value ,x))
+       (cond
+         ,@(mapcar (lambda (c)
+                     (if (eq (car c) t)
+                         `((t ,@(rest c)))
+                         `((,(ecase (car c)
+                                    (integer 'integerp)
+                                    (cons 'consp)
+                                    (string 'stringp)
+                                    (atom 'atom)
+                                    (null 'null))
+                             ,value)
+                           ,@(or (rest c)
+                                 (list nil)))))
+                   clausules)))))
+
+;; The NCONC function is based on the SBCL's one.
+(defun nconc (&rest lists)
+  (flet ((fail (object)
+           (error "type-error in nconc")))
+    (do ((top lists (cdr top)))
+        ((null top) nil)
+      (let ((top-of-top (car top)))
+        (typecase top-of-top
+          (cons
+           (let* ((result top-of-top)
+                  (splice result))
+             (do ((elements (cdr top) (cdr elements)))
+                 ((endp elements))
+               (let ((ele (car elements)))
+                 (typecase ele
+                   (cons (rplacd (last splice) ele)
+                         (setf splice ele))
+                   (null (rplacd (last splice) nil))
+                   (atom (if (cdr elements)
+                             (fail ele)
+                             (rplacd (last splice) ele))))))
+             (return result)))
+          (null)
+          (atom
+           (if (cdr top)
+               (fail top-of-top)
+               (return top-of-top))))))))
+
+(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.
+      ((atom 2nd) 3rd)
+    (rplacd 2nd 3rd)))
+
+(defun notany (fn seq)
+  (not (some fn seq)))
+
+
+;; Packages
+
+(defvar *package-list* nil)
+
+(defun list-all-packages ()
+  *package-list*)
+
+(defun make-package (name &key use)
+  (let ((package (new))
+        (use (mapcar #'find-package-or-fail use)))
+    (oset package "packageName" name)
+    (oset package "symbols" (new))
+    (oset package "exports" (new))
+    (oset package "use" use)
+    (push package *package-list*)
+    package))
+
+(defun packagep (x)
+  (and (objectp x) (in "symbols" x)))
+
+(defun find-package (package-designator)
+  (when (packagep package-designator)
+    (return-from find-package package-designator))
+  (let ((name (string package-designator)))
+    (dolist (package *package-list*)
+      (when (string= (package-name package) name)
+        (return package)))))
+
+(defun find-package-or-fail (package-designator)
+  (or (find-package package-designator)
+      (error "Package unknown.")))
+
+(defun package-name (package-designator)
+  (let ((package (find-package-or-fail package-designator)))
+    (oget package "packageName")))
+
+(defun %package-symbols (package-designator)
+  (let ((package (find-package-or-fail package-designator)))
+    (oget package "symbols")))
+
+(defun package-use-list (package-designator)
+  (let ((package (find-package-or-fail package-designator)))
+    (oget package "use")))
+
+(defun %package-external-symbols (package-designator)
+  (let ((package (find-package-or-fail package-designator)))
+    (oget package "exports")))
+
+(defvar *common-lisp-package*
+  (make-package "CL"))
+
+(defvar *js-package*
+  (make-package "JS"))
+
+(defvar *user-package*
+  (make-package "CL-USER" :use (list *common-lisp-package*)))
+
+(defvar *keyword-package*
+  (make-package "KEYWORD"))
+
+(defun keywordp (x)
+  (and (symbolp x) (eq (symbol-package x) *keyword-package*)))
+
+(defvar *package* *common-lisp-package*)
+
+(defmacro in-package (package-designator)
+  `(eval-when-compile
+     (setq *package* (find-package-or-fail ,package-designator))))
+
+;; This function is used internally to initialize the CL package
+;; with the symbols built during bootstrap.
+(defun %intern-symbol (symbol)
+  (let* ((package
+          (if (in "package" symbol)
+              (find-package-or-fail (oget symbol "package"))
+              *common-lisp-package*))
+         (symbols (%package-symbols package)))
+    (oset symbol "package" package)
+    (when (eq package *keyword-package*)
+      (oset symbol "value" symbol))
+    (oset symbols (symbol-name symbol) symbol)))
+
+(defun find-symbol (name &optional (package *package*))
+  (let* ((package (find-package-or-fail package))
+         (externals (%package-external-symbols package))
+         (symbols (%package-symbols package)))
+    (cond
+      ((in name externals)
+       (values (oget externals name) :external))
+      ((in name symbols)
+       (values (oget symbols name) :internal))
+      (t
+       (dolist (used (package-use-list package) (values nil nil))
+         (let ((exports (%package-external-symbols used)))
+           (when (in name exports)
+             (return (values (oget exports name) :inherit)))))))))
+
+(defun intern (name &optional (package *package*))
+  (let ((package (find-package-or-fail package)))
+    (multiple-value-bind (symbol foundp)
+        (find-symbol name package)
+      (if foundp
+          (values symbol foundp)
+          (let ((symbols (%package-symbols package)))
+            (oget symbols name)
+            (let ((symbol (make-symbol name)))
+              (oset symbol "package" package)
+              (when (eq package *keyword-package*)
+                (oset symbol "value" symbol)
+                (export (list symbol) package))
+              (when (eq package *js-package*)
+                (let ((sym-name (symbol-name symbol))
+                      (args (gensym)))
+                  ;; Generate a trampoline to call the JS function
+                  ;; properly. This trampoline is very inefficient,
+                  ;; but it still works. Ideas to optimize this are
+                  ;; provide a special lambda keyword
+                  ;; cl::&rest-vector to avoid list argument
+                  ;; consing, as well as allow inline declarations.
+                  (fset symbol
+                        (eval `(lambda (&rest ,args)
+                                 (let ((,args (list-to-vector ,args)))
+                                   (%js-call (%js-vref ,sym-name) ,args)))))
+                  ;; Define it as a symbol macro to access to the
+                  ;; Javascript variable literally.
+                  (%define-symbol-macro symbol `(%js-vref ,(string symbol)))))
+              (oset symbols name symbol)
+              (values symbol nil)))))))
+
+(defun symbol-package (symbol)
+  (unless (symbolp symbol)
+    (error "it is not a symbol"))
+  (oget symbol "package"))
+
+(defun export (symbols &optional (package *package*))
+  (let ((exports (%package-external-symbols package)))
+    (dolist (symb symbols t)
+      (oset exports (symbol-name symb) symb))))
+
+(defun get-universal-time ()
+  (+ (get-unix-time) 2208988800))
diff --git a/compat.lisp b/compat.lisp
new file mode 100644
index 0000000..c9680c3
--- /dev/null
+++ b/compat.lisp
@@ -0,0 +1,45 @@
+;;; compat.lisp --- Create some definitions to fix CL compatibility
+
+;; Copyright (C) 2012, 2013 David Vazquez
+;; Copyright (C) 2012 Raimon Grau
+
+;; This program is free software: you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Duplicate from boot.lisp by now
+(defmacro with-collect (&body body)
+  (let ((head (gensym))
+        (tail (gensym)))
+    `(let* ((,head (cons 'sentinel nil))
+            (,tail ,head))
+       (flet ((collect (x)
+                (rplacd ,tail (cons x nil))
+                (setq ,tail (cdr ,tail))
+                x))
+         ,@body)
+       (cdr ,head))))
+
+(defmacro while (condition &body body)
+  `(do ()
+       ((not ,condition))
+     ,@body))
+
+(defmacro eval-when-compile (&body body)
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     ,@body))
+
+(defun concat-two (s1 s2)
+  (concatenate 'string s1 s2))
+
+(defun aset (array idx value)
+  (setf (aref array idx) value))
diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index f3c1f93..4bb93ea 100644
--- a/ecmalisp.lisp
+++ b/ecmalisp.lisp
@@ -16,632 +16,9 @@
 ;; You should have received a copy of the GNU General Public License
 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
 
-;;; This couple of helper functions will be defined in both Common
-;;; Lisp and in Ecmalisp.
-(defun ensure-list (x)
-  (if (listp x)
-      x
-      (list x)))
-
-(defun !reduce (func list &key initial-value)
-  (if (null list)
-      initial-value
-      (!reduce func
-               (cdr list)
-               :initial-value (funcall func initial-value (car list)))))
-
-(defmacro with-collect (&body body)
-  (let ((head (gensym))
-        (tail (gensym)))
-    `(let* ((,head (cons 'sentinel nil))
-            (,tail ,head))
-       (flet ((collect (x)
-                (rplacd ,tail (cons x nil))
-                (setq ,tail (cdr ,tail))
-                x))
-         ,@body)
-       (cdr ,head))))
-
-;;; Go on growing the Lisp language in Ecmalisp, with more high
-;;; level utilities as well as correct versions of other
-;;; constructions.
-#+ecmalisp
-(progn
-  (defun + (&rest args)
-    (let ((r 0))
-      (dolist (x args r)
-	(incf r x))))
-
-  (defun - (x &rest others)
-    (if (null others)
-	(- x)
-	(let ((r x))
-	  (dolist (y others r)
-	    (decf r y)))))
-
-  (defun append-two (list1 list2)
-    (if (null list1)
-        list2
-        (cons (car list1)
-              (append (cdr list1) list2))))
-
-  (defun append (&rest lists)
-    (!reduce #'append-two lists))
-
-  (defun revappend (list1 list2)
-    (while list1
-      (push (car list1) list2)
-      (setq list1 (cdr list1)))
-    list2)
-
-  (defun reverse (list)
-    (revappend list '()))
-
-  (defmacro psetq (&rest pairs)
-    (let ( ;; For each pair, we store here a list of the form
-	  ;; (VARIABLE GENSYM VALUE).
-	  (assignments '()))
-      (while t
-	(cond
-	  ((null pairs) (return))
-	  ((null (cdr pairs))
-	   (error "Odd paris in PSETQ"))
-	  (t
-	   (let ((variable (car pairs))
-		 (value (cadr pairs)))
-	     (push `(,variable ,(gensym) ,value)  assignments)
-	     (setq pairs (cddr pairs))))))
-      (setq assignments (reverse assignments))
-      ;;
-      `(let ,(mapcar #'cdr assignments)
-	 (setq ,@(!reduce #'append (mapcar #'butlast assignments))))))
-
-  (defmacro do (varlist endlist &body body)
-    `(block nil
-       (let ,(mapcar (lambda (x) (list (first x) (second x))) varlist)
-	 (while t
-	   (when ,(car endlist)
-	     (return (progn ,@(cdr endlist))))
-	   (tagbody ,@body)
-	   (psetq
-	    ,@(apply #'append
-		     (mapcar (lambda (v)
-			       (and (consp (cddr v))
-				    (list (first v) (third v))))
-			     varlist)))))))
-
-  (defmacro do* (varlist endlist &body body)
-    `(block nil
-       (let* ,(mapcar (lambda (x) (list (first x) (second x))) varlist)
-	 (while t
-	   (when ,(car endlist)
-	     (return (progn ,@(cdr endlist))))
-	   (tagbody ,@body)
-	   (setq
-	    ,@(apply #'append
-		     (mapcar (lambda (v)
-			       (and (consp (cddr v))
-				    (list (first v) (third v))))
-			     varlist)))))))
-
-  (defun list-length (list)
-    (let ((l 0))
-      (while (not (null list))
-        (incf l)
-        (setq list (cdr list)))
-      l))
-
-  (defun length (seq)
-    (cond
-      ((stringp seq)
-       (string-length seq))
-      ((arrayp seq)
-       (oget seq "length"))
-      ((listp seq)
-       (list-length seq))))
-
-  (defun concat-two (s1 s2)
-    (concat-two s1 s2))
-
-  (defun map1 (func list)
-    (with-collect
-        (while list
-          (collect (funcall func (car list)))
-          (setq list (cdr list)))))
-
-  (defmacro loop (&body body)
-    `(while t ,@body))
-
-  (defun mapcar (func list &rest lists)
-    (let ((lists (cons list lists)))
-      (with-collect
-          (block loop
-            (loop
-               (let ((elems (map1 #'car lists)))
-                 (do ((tail lists (cdr tail)))
-                     ((null tail))
-                   (when (null (car tail)) (return-from loop))
-                   (rplaca tail (cdar tail)))
-                 (collect (apply func elems))))))))
-
-  (defun identity (x) x)
-
-  (defun constantly (x)
-    (lambda (&rest args)
-      x))
-
-  (defun copy-list (x)
-    (mapcar #'identity x))
-
-  (defun list* (arg &rest others)
-    (cond ((null others) arg)
-          ((null (cdr others)) (cons arg (car others)))
-          (t (do ((x others (cdr x)))
-                 ((null (cddr x)) (rplacd x (cadr x))))
-             (cons arg others))))
-
-  (defun code-char (x) x)
-  (defun char-code (x) x)
-  (defun char= (x y) (= x y))
-
-  (defun integerp (x)
-    (and (numberp x) (= (floor x) x)))
-
-  (defun plusp (x) (< 0 x))
-  (defun minusp (x) (< x 0))
-
-  (defun listp (x)
-    (or (consp x) (null x)))
-
-  (defun nthcdr (n list)
-    (while (and (plusp n) list)
-      (setq n (1- n))
-      (setq list (cdr list)))
-    list)
-
-  (defun nth (n list)
-    (car (nthcdr n list)))
-
-  (defun last (x)
-    (while (consp (cdr x))
-      (setq x (cdr x)))
-    x)
-
-  (defun butlast (x)
-    (and (consp (cdr x))
-         (cons (car x) (butlast (cdr x)))))
-
-  (defun member (x list)
-    (while list
-      (when (eql x (car list))
-        (return list))
-      (setq list (cdr list))))
-
-  (defun find (item list &key key (test #'eql))
-    (dolist (x list)
-      (when (funcall test (funcall key x) item)
-        (return x))))
-
-  (defun remove (x list)
-    (cond
-      ((null list)
-       nil)
-      ((eql x (car list))
-       (remove x (cdr list)))
-      (t
-       (cons (car list) (remove x (cdr list))))))
-
-  (defun remove-if (func list)
-    (cond
-      ((null list)
-       nil)
-      ((funcall func (car list))
-       (remove-if func (cdr list)))
-      (t
-       ;;
-       (cons (car list) (remove-if func (cdr list))))))
-
-  (defun remove-if-not (func list)
-    (cond
-      ((null list)
-       nil)
-      ((funcall func (car list))
-       (cons (car list) (remove-if-not func (cdr list))))
-      (t
-       (remove-if-not func (cdr list)))))
-
-  (defun digit-char-p (x)
-    (if (and (<= #\0 x) (<= x #\9))
-        (- x #\0)
-        nil))
-
-  (defun digit-char (weight)
-    (and (<= 0 weight 9)
-	 (char "0123456789" weight)))
-
-  (defun subseq (seq a &optional b)
-    (cond
-      ((stringp seq)
-       (if b
-           (slice seq a b)
-           (slice seq a)))
-      (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)
-    (do-sequence (elt seq)
-      (when (funcall function elt)
-        (return-from some t))))
-
-  (defun every (function seq)
-    (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
-      (if (eql x (caar alist))
-          (return)
-          (setq alist (cdr alist))))
-    (car alist))
-
-  (defun string (x)
-    (cond ((stringp x) x)
-          ((symbolp x) (symbol-name x))
-          (t (char-to-string x))))
-
-  (defun string= (s1 s2)
-    (equal s1 s2))
-
-  (defun fdefinition (x)
-    (cond
-      ((functionp x)
-       x)
-      ((symbolp x)
-       (symbol-function x))
-      (t
-       (error "Invalid function"))))
-
-  (defun disassemble (function)
-    (write-line (lambda-code (fdefinition function)))
-    nil)
-
-  (defun documentation (x type)
-    "Return the documentation of X. TYPE must be the symbol VARIABLE or FUNCTION."
-    (ecase type
-      (function
-       (let ((func (fdefinition x)))
-         (oget func "docstring")))
-      (variable
-       (unless (symbolp x)
-         (error "Wrong argument type! it should be a symbol"))
-       (oget x "vardoc"))))
-
-  (defmacro multiple-value-bind (variables value-from &body body)
-    `(multiple-value-call (lambda (&optional ,@variables &rest ,(gensym))
-                            ,@body)
-       ,value-from))
-
-  (defmacro multiple-value-list (value-from)
-    `(multiple-value-call #'list ,value-from))
-
-
-;;; Generalized references (SETF)
-
-  (defvar *setf-expanders* nil)
-
-  (defun get-setf-expansion (place)
-    (if (symbolp place)
-        (let ((value (gensym)))
-          (values nil
-                  nil
-                  `(,value)
-                  `(setq ,place ,value)
-                  place))
-        (let ((place (ls-macroexpand-1 place)))
-          (let* ((access-fn (car place))
-                 (expander (cdr (assoc access-fn *setf-expanders*))))
-            (when (null expander)
-              (error "Unknown generalized reference."))
-            (apply expander (cdr place))))))
-
-  (defmacro define-setf-expander (access-fn lambda-list &body body)
-    (unless (symbolp access-fn)
-      (error "ACCESS-FN must be a symbol."))
-    `(progn (push (cons ',access-fn (lambda ,lambda-list ,@body))
-                  *setf-expanders*)
-            ',access-fn))
-
-  (defmacro setf (&rest pairs)
-    (cond
-      ((null pairs)
-       nil)
-      ((null (cdr pairs))
-       (error "Odd number of arguments to setf."))
-      ((null (cddr pairs))
-       (let ((place (ls-macroexpand-1 (first pairs)))
-             (value (second pairs)))
-         (multiple-value-bind (vars vals store-vars writer-form reader-form)
-             (get-setf-expansion place)
-           ;; TODO: Optimize the expansion a little bit to avoid let*
-           ;; or multiple-value-bind when unnecesary.
-           `(let* ,(mapcar #'list vars vals)
-              (multiple-value-bind ,store-vars
-                  ,value
-                ,writer-form)))))
-      (t
-       `(progn
-          ,@(do ((pairs pairs (cddr pairs))
-                 (result '() (cons `(setf ,(car pairs) ,(cadr pairs)) result)))
-                ((null pairs)
-                 (reverse result)))))))
-
-  (define-setf-expander car (x)
-    (let ((cons (gensym))
-          (new-value (gensym)))
-      (values (list cons)
-              (list x)
-              (list new-value)
-              `(progn (rplaca ,cons ,new-value) ,new-value)
-              `(car ,cons))))
-
-  (define-setf-expander cdr (x)
-    (let ((cons (gensym))
-          (new-value (gensym)))
-      (values (list cons)
-              (list x)
-              (list new-value)
-              `(progn (rplacd ,cons ,new-value) ,new-value)
-              `(car ,cons))))
-
-  ;; Incorrect typecase, but used in NCONC.
-  (defmacro typecase (x &rest clausules)
-    (let ((value (gensym)))
-      `(let ((,value ,x))
-         (cond
-           ,@(mapcar (lambda (c)
-                       (if (eq (car c) t)
-                           `((t ,@(rest c)))
-                           `((,(ecase (car c)
-                                      (integer 'integerp)
-                                      (cons 'consp)
-                                      (string 'stringp)
-                                      (atom 'atom)
-                                      (null 'null))
-                               ,value)
-                             ,@(or (rest c)
-                                   (list nil)))))
-                     clausules)))))
-
-  ;; The NCONC function is based on the SBCL's one.
-  (defun nconc (&rest lists)
-    (flet ((fail (object)
-             (error "type-error in nconc")))
-      (do ((top lists (cdr top)))
-          ((null top) nil)
-        (let ((top-of-top (car top)))
-          (typecase top-of-top
-            (cons
-             (let* ((result top-of-top)
-                    (splice result))
-               (do ((elements (cdr top) (cdr elements)))
-                   ((endp elements))
-                 (let ((ele (car elements)))
-                   (typecase ele
-                     (cons (rplacd (last splice) ele)
-                           (setf splice ele))
-                     (null (rplacd (last splice) nil))
-                     (atom (if (cdr elements)
-                               (fail ele)
-                               (rplacd (last splice) ele))))))
-               (return result)))
-            (null)
-            (atom
-             (if (cdr top)
-                 (fail top-of-top)
-                 (return top-of-top))))))))
-
-  (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.
-        ((atom 2nd) 3rd)
-      (rplacd 2nd 3rd)))
-
-  (defun notany (fn seq)
-    (not (some fn seq)))
-
-
-  ;; Packages
-
-  (defvar *package-list* nil)
-
-  (defun list-all-packages ()
-    *package-list*)
-
-  (defun make-package (name &key use)
-    (let ((package (new))
-          (use (mapcar #'find-package-or-fail use)))
-      (oset package "packageName" name)
-      (oset package "symbols" (new))
-      (oset package "exports" (new))
-      (oset package "use" use)
-      (push package *package-list*)
-      package))
-
-  (defun packagep (x)
-    (and (objectp x) (in "symbols" x)))
-
-  (defun find-package (package-designator)
-    (when (packagep package-designator)
-      (return-from find-package package-designator))
-    (let ((name (string package-designator)))
-      (dolist (package *package-list*)
-        (when (string= (package-name package) name)
-          (return package)))))
-
-  (defun find-package-or-fail (package-designator)
-    (or (find-package package-designator)
-        (error "Package unknown.")))
-
-  (defun package-name (package-designator)
-    (let ((package (find-package-or-fail package-designator)))
-      (oget package "packageName")))
-
-  (defun %package-symbols (package-designator)
-    (let ((package (find-package-or-fail package-designator)))
-      (oget package "symbols")))
-
-  (defun package-use-list (package-designator)
-    (let ((package (find-package-or-fail package-designator)))
-      (oget package "use")))
-
-  (defun %package-external-symbols (package-designator)
-    (let ((package (find-package-or-fail package-designator)))
-      (oget package "exports")))
-
-  (defvar *common-lisp-package*
-    (make-package "CL"))
-
-  (defvar *js-package*
-    (make-package "JS"))
-
-  (defvar *user-package*
-    (make-package "CL-USER" :use (list *common-lisp-package*)))
-
-  (defvar *keyword-package*
-    (make-package "KEYWORD"))
-
-  (defun keywordp (x)
-    (and (symbolp x) (eq (symbol-package x) *keyword-package*)))
-
-  (defvar *package* *common-lisp-package*)
-
-  (defmacro in-package (package-designator)
-    `(eval-when-compile
-       (setq *package* (find-package-or-fail ,package-designator))))
-
-  ;; This function is used internally to initialize the CL package
-  ;; with the symbols built during bootstrap.
-  (defun %intern-symbol (symbol)
-    (let* ((package
-            (if (in "package" symbol)
-                (find-package-or-fail (oget symbol "package"))
-                *common-lisp-package*))
-           (symbols (%package-symbols package)))
-      (oset symbol "package" package)
-      (when (eq package *keyword-package*)
-        (oset symbol "value" symbol))
-      (oset symbols (symbol-name symbol) symbol)))
-
-  (defun find-symbol (name &optional (package *package*))
-    (let* ((package (find-package-or-fail package))
-           (externals (%package-external-symbols package))
-           (symbols (%package-symbols package)))
-      (cond
-        ((in name externals)
-         (values (oget externals name) :external))
-        ((in name symbols)
-         (values (oget symbols name) :internal))
-        (t
-         (dolist (used (package-use-list package) (values nil nil))
-           (let ((exports (%package-external-symbols used)))
-             (when (in name exports)
-               (return (values (oget exports name) :inherit)))))))))
-
-  (defun intern (name &optional (package *package*))
-    (let ((package (find-package-or-fail package)))
-      (multiple-value-bind (symbol foundp)
-          (find-symbol name package)
-        (if foundp
-            (values symbol foundp)
-            (let ((symbols (%package-symbols package)))
-              (oget symbols name)
-              (let ((symbol (make-symbol name)))
-                (oset symbol "package" package)
-                (when (eq package *keyword-package*)
-                  (oset symbol "value" symbol)
-                  (export (list symbol) package))
-		(when (eq package *js-package*)
-		  (let ((sym-name (symbol-name symbol))
-                        (args (gensym)))
-                    ;; Generate a trampoline to call the JS function
-                    ;; properly. This trampoline is very inefficient,
-                    ;; but it still works. Ideas to optimize this are
-                    ;; provide a special lambda keyword
-                    ;; cl::&rest-vector to avoid list argument
-                    ;; consing, as well as allow inline declarations.
-		    (fset symbol
-                          (eval `(lambda (&rest ,args)
-                                   (let ((,args (list-to-vector ,args)))
-                                     (%js-call (%js-vref ,sym-name) ,args)))))
-                    ;; Define it as a symbol macro to access to the
-                    ;; Javascript variable literally.
-                    (%define-symbol-macro symbol `(%js-vref ,(string symbol)))))
-                (oset symbols name symbol)
-                (values symbol nil)))))))
-
-  (defun symbol-package (symbol)
-    (unless (symbolp symbol)
-      (error "it is not a symbol"))
-    (oget symbol "package"))
-
-  (defun export (symbols &optional (package *package*))
-    (let ((exports (%package-external-symbols package)))
-      (dolist (symb symbols t)
-        (oset exports (symbol-name symb) symb))))
-
-  (defun get-universal-time ()
-    (+ (get-unix-time) 2208988800)))
-
-
-;;; The compiler offers some primitives and special forms which are
-;;; not found in Common Lisp, for instance, while. So, we grow Common
-;;; Lisp a bit to it can execute the rest of the file.
 #+common-lisp
-(progn
-  (defmacro while (condition &body body)
-    `(do ()
-         ((not ,condition))
-       ,@body))
-
-  (defmacro eval-when-compile (&body body)
-    `(eval-when (:compile-toplevel :load-toplevel :execute)
-       ,@body))
-
-  (defun concat-two (s1 s2)
-    (concatenate 'string s1 s2))
-
-  (defun aset (array idx value)
-    (setf (aref array idx) value)))
+(eval-when (:load-toplevel :compile-toplevel :execute)
+  (load "compat"))
 
 ;;; At this point, no matter if Common Lisp or ecmalisp is compiling
 ;;; from here, this code will compile on both. We define some helper
@@ -661,6 +38,20 @@
 (defmacro concatf (variable &body form)
   `(setq ,variable (concat ,variable (progn ,@form))))
 
+;;; This couple of helper functions will be defined in both Common
+;;; Lisp and in Ecmalisp.
+(defun ensure-list (x)
+  (if (listp x)
+      x
+      (list x)))
+
+(defun !reduce (func list &key initial-value)
+  (if (null list)
+      initial-value
+      (!reduce func
+               (cdr list)
+               :initial-value (funcall func initial-value (car list)))))
+
 ;;; Concatenate a list of strings, with a separator
 (defun join (list &optional (separator ""))
   (cond