New function: CONSTANTLY
[jscl.git] / ecmalisp.lisp
index 62fe386..a87a86e 100644 (file)
     (concat-two s1 s2))
 
   (defun mapcar (func list)
-    (if (null list)
-        '()
-        (cons (funcall func (car list))
-              (mapcar func (cdr list)))))
+    (let* ((head (cons 'sentinel nil))
+          (tail head))
+      (while (not (null list))
+       (let ((new (cons (funcall func (car list)) nil)))
+         (rplacd tail new)
+         (setq tail new
+               list (cdr list))))
+      (cdr head)))
 
   (defun identity (x) x)
 
+  (defun constantly (x)
+    (lambda (&rest args)
+      x))
+
   (defun copy-list (x)
     (mapcar #'identity x))
 
         (- x #\0)
         nil))
 
+  (defun digit-char (weight)
+    (and (<= 0 weight 9)
+        (char "0123456789" weight)))  
+
   (defun subseq (seq a &optional b)
     (cond
       ((stringp seq)
          do (write-string "    ")
          do (write-line line)))))
 
-
 (defun integer-to-string (x)
   (cond
     ((zerop x)
        (while (not (zerop x))
          (push (mod x 10) digits)
          (setq x (truncate x 10)))
-       (join (mapcar (lambda (d) (string (char "0123456789" d)))
-                     digits))))))
+       (mapconcat (lambda (x) (string (digit-char x)))
+                 digits)))))
 
 
 ;;; Wrap X with a Javascript code to convert the result from
     ((and (listp x) (eq (car x) 'lambda))
      (compile-lambda (cadr x) (cddr x)))
     ((symbolp x)
-     (ls-compile `(symbol-function ',x)))))
+     (let ((b (lookup-in-lexenv x *environment* 'function)))
+       (if b
+          (binding-value b)
+          (ls-compile `(symbol-function ',x)))))))
 
 
 (defun make-function-binding (fname)
 
 (define-compilation labels (definitions &rest body)
   (let* ((fnames (mapcar #'car definitions))
-         (fbody  (mapcar #'cdr definitions))
         (*environment*
           (extend-lexenv (mapcar #'make-function-binding fnames)
                          *environment*
-                         'function))
-         (cfuncs (mapcar #'compile-function-definition fbody)))
-    (concat "(function(){" *newline*
-           (join (mapcar (lambda (func)
-                           ())
-                         definitions))
-            (let ((body (ls-compile-block body t)))
-              (indent body))
-            "})")))
+                         'function)))
+    (js!selfcall
+      (mapconcat (lambda (func)
+                  (concat "var " (translate-function (car func))
+                          " = " (compile-lambda (cadr func) (cddr func))
+                          ";" *newline*))
+                definitions)
+      (ls-compile-block body t))))
 
 
 
   (defun eval (x)
     (js-eval (ls-compile-toplevel x t)))
 
-  (export '(&rest &optional &body * *gensym-counter* *package* + - / 1+ 1- < <= =
-            = > >= and append apply aref arrayp aset assoc atom block boundp
-            boundp butlast caar cadddr caddr cadr car car case catch cdar cdddr
-            cddr cdr cdr char char-code char= code-char cond cons consp copy-list
-            decf declaim defparameter defun defmacro defvar digit-char-p
-            disassemble do do* documentation dolist dotimes ecase eq eql equal
-           error eval every export fdefinition find-package find-symbol first
-           flet fourth fset funcall function functionp gensym get-universal-time
-            go identity if in-package incf integerp integerp intern keywordp lambda
-           last length let let* list-all-packages list listp make-array
-           make-package make-symbol mapcar member minusp mod multiple-value-bind
-            multiple-value-call multiple-value-list multiple-value-prog1 nil not
-            nth nthcdr null numberp or package-name package-use-list packagep
-            parse-integer plusp prin1-to-string print proclaim prog1 prog2 progn
-           psetq push quote remove remove-if remove-if-not return return-from
-           revappend reverse rplaca rplacd second set setq some string-upcase
-           string string= stringp subseq symbol-function symbol-name symbol-package
-            symbol-plist symbol-value symbolp t tagbody third throw truncate
-            unless unwind-protect values values-list variable warn when write-line
-            write-string zerop))
+  (export '(&rest &optional &body * *gensym-counter* *package* + - /
+            1+ 1- < <= = = > >= and append apply aref arrayp aset
+            assoc atom block boundp boundp butlast caar cadddr caddr
+            cadr car car case catch cdar cdddr cddr cdr cdr char
+            char-code char= code-char cond cons consp constantly
+            copy-list decf declaim defparameter defun defmacro defvar
+            digit-char digit-char-p disassemble do do* documentation
+            dolist dotimes ecase eq eql equal error eval every export
+            fdefinition find-package find-symbol first flet fourth
+            fset funcall function functionp gensym get-universal-time
+            go identity if in-package incf integerp integerp intern
+            keywordp labels lambda last length let let*
+            list-all-packages list listp make-array make-package
+            make-symbol mapcar member minusp mod multiple-value-bind
+            multiple-value-call multiple-value-list
+            multiple-value-prog1 nil not nth nthcdr null numberp or
+            package-name package-use-list packagep parse-integer plusp
+            prin1-to-string print proclaim prog1 prog2 progn psetq
+            push quote remove remove-if remove-if-not return
+            return-from revappend reverse rplaca rplacd second set
+            setq some string-upcase string string= stringp subseq
+            symbol-function symbol-name symbol-package symbol-plist
+            symbol-value symbolp t tagbody third throw truncate unless
+            unwind-protect values values-list variable warn when
+            write-line write-string zerop))
 
   (setq *package* *user-package*)