New special form: labels

[jscl.git] / ecmalisp.lisp

diff --git a/ecmalisp.lisp b/ecmalisp.lisp
index 8574222..62fe386 100644 (file)
--- a/ecmalisp.lisp
+++ b/ecmalisp.lisp
@@ -133,6 +133,7 @@
   (defun second (x) (cadr x))
   (defun third (x) (caddr x))
   (defun fourth (x) (cadddr x))
   (defun second (x) (cadr x))
   (defun third (x) (caddr x))
   (defun fourth (x) (cadddr x))

+  (defun rest (x) (cdr x))

 
   (defun list (&rest args) args)
   (defun atom (x)
 
   (defun list (&rest args) args)
   (defun atom (x)

@@ -301,6 +302,34 @@
       `(let ,(mapcar #'cdr assignments)
         (setq ,@(!reduce #'append (mapcar #'butlast 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))
   (defun list-length (list)
     (let ((l 0))
       (while (not (null list))

@@ -409,15 +438,6 @@
       (t
        (error "Unsupported argument."))))
 
       (t
        (error "Unsupported argument."))))
 

-  (defun parse-integer (string)
-    (let ((value 0)
-          (index 0)
-          (size (length string)))
-      (while (< index size)
-        (setq value (+ (* value 10) (digit-char-p (char string index))))
-        (incf index))
-      value))
-

   (defun some (function seq)
     (cond
       ((stringp seq)
   (defun some (function seq)
     (cond
       ((stringp seq)

@@ -491,6 +511,14 @@
          (error "Wrong argument type! it should be a symbol"))
        (oget x "vardoc"))))
 
          (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))
+

   ;; Packages
 
   (defvar *package-list* nil)
   ;; Packages
 
   (defvar *package-list* nil)

@@ -560,29 +588,37 @@
   ;; This function is used internally to initialize the CL package
   ;; with the symbols built during bootstrap.
   (defun %intern-symbol (symbol)
   ;; This function is used internally to initialize the CL package
   ;; with the symbols built during bootstrap.
   (defun %intern-symbol (symbol)

-    (let ((symbols (%package-symbols *common-lisp-package*)))
-      (oset symbol "package" *common-lisp-package*)
+    (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)))
 
       (oset symbols (symbol-name symbol) symbol)))
 

-  (defun %find-symbol (name package)
-    (let ((package (find-package-or-fail package)))
-      (let ((symbols (%package-symbols package)))
-        (if (in name symbols)
-            (cons (oget symbols name) t)
-            (dolist (used (package-use-list package) (cons nil nil))
-              (let ((exports (%package-external-symbols used)))
-                (when (in name exports)
-                  (return-from %find-symbol
-                    (cons (oget exports name) t)))))))))
-

   (defun find-symbol (name &optional (package *package*))
   (defun find-symbol (name &optional (package *package*))

-    (car (%find-symbol name 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)))
 
   (defun intern (name &optional (package *package*))
     (let ((package (find-package-or-fail package)))

-      (let ((result (%find-symbol name package)))
-        (if (cdr result)
-            (car result)
+      (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)))
             (let ((symbols (%package-symbols package)))
               (oget symbols name)
               (let ((symbol (make-symbol name)))

@@ -590,7 +626,8 @@
                 (when (eq package *keyword-package*)
                   (oset symbol "value" symbol)
                   (export (list symbol) package))
                 (when (eq package *keyword-package*)
                   (oset symbol "value" symbol)
                   (export (list symbol) package))

-                (oset symbols name symbol)))))))
+                (oset symbols name symbol)
+                (values symbol nil)))))))

 
   (defun symbol-package (symbol)
     (unless (symbolp symbol)
 
   (defun symbol-package (symbol)
     (unless (symbolp symbol)

@@ -678,15 +715,7 @@
     (values-array (list-to-vector list)))
 
   (defun values (&rest args)
     (values-array (list-to-vector list)))
 
   (defun values (&rest args)

-    (values-list args))
-
-  (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)))
+    (values-list args)))

 
 
 ;;; Like CONCAT, but prefix each line with four spaces. Two versions
 
 
 ;;; Like CONCAT, but prefix each line with four spaces. Two versions

@@ -758,15 +787,17 @@
   (defun prin1-to-string (form)
     (cond
       ((symbolp form)
   (defun prin1-to-string (form)
     (cond
       ((symbolp form)

-       (if (cdr (%find-symbol (symbol-name form) *package*))
-           (symbol-name form)
-           (let ((package (symbol-package form))
-                 (name (symbol-name form)))
-             (concat (cond
-                       ((null package) "#")
-                       ((eq package (find-package "KEYWORD")) "")
-                       (t (package-name package)))
-                     ":" name))))
+       (multiple-value-bind (symbol foundp)
+           (find-symbol (symbol-name form) *package*)
+         (if (and foundp (eq symbol form))
+             (symbol-name form)
+             (let ((package (symbol-package form))
+                   (name (symbol-name form)))
+               (concat (cond
+                         ((null package) "#")
+                         ((eq package (find-package "KEYWORD")) "")
+                         (t (package-name package)))
+                       ":" name)))))

       ((integerp form) (integer-to-string form))
       ((stringp form) (concat "\"" (escape-string form) "\""))
       ((functionp form)
       ((integerp form) (integer-to-string form))
       ((stringp form) (concat "\"" (escape-string form) "\""))
       ((functionp form)

@@ -944,6 +975,40 @@
         (intern name package)
         (find-symbol name package))))
 
         (intern name package)
         (find-symbol name package))))
 

+
+(defun !parse-integer (string junk-allow)
+  (block nil
+    (let ((value 0)
+         (index 0)
+         (size (length string))
+         (sign 1))
+      (when (zerop size) (return (values nil 0)))
+      ;; Optional sign
+      (case (char string 0)
+       (#\+ (incf index))
+       (#\- (setq sign -1)
+            (incf index)))
+      ;; First digit
+      (unless (and (< index size)
+                  (setq value (digit-char-p (char string index))))
+       (return (values nil index)))
+      (incf index)
+      ;; Other digits
+      (while (< index size)
+       (let ((digit (digit-char-p (char string index))))
+         (unless digit (return))
+         (setq value (+ (* value 10) digit))
+         (incf index)))
+      (if (or junk-allow
+             (= index size)
+             (char= (char string index) #\space))
+         (values (* sign value) index)
+         (values nil index)))))
+
+#+ecmalisp
+(defun parse-integer (string)
+  (!parse-integer string nil))
+

 (defvar *eof* (gensym))
 (defun ls-read (stream)
   (skip-whitespaces-and-comments stream)
 (defvar *eof* (gensym))
 (defun ls-read (stream)
   (skip-whitespaces-and-comments stream)

@@ -972,9 +1037,8 @@
        (read-sharp stream))
       (t
        (let ((string (read-until stream #'terminalp)))
        (read-sharp stream))
       (t
        (let ((string (read-until stream #'terminalp)))

-         (if (every #'digit-char-p string)
-             (parse-integer string)
-             (read-symbol string)))))))
+        (or (values (!parse-integer string nil))
+            (read-symbol string)))))))

 
 (defun ls-read-from-string (string)
   (ls-read (make-string-stream string)))
 
 (defun ls-read-from-string (string)
   (ls-read (make-string-stream string)))

@@ -1051,7 +1115,7 @@
 (defun extend-local-env (args)
   (let ((new (copy-lexenv *environment*)))
     (dolist (symbol args new)
 (defun extend-local-env (args)
   (let ((new (copy-lexenv *environment*)))
     (dolist (symbol args new)

-      (let ((b (make-binding symbol 'lexical-variable (gvarname symbol))))
+      (let ((b (make-binding symbol 'variable (gvarname symbol))))

         (push-to-lexenv b new 'variable)))))
 
 ;;; Toplevel compilations
         (push-to-lexenv b new 'variable)))))
 
 ;;; Toplevel compilations

@@ -1234,7 +1298,9 @@
 
 (defun setq-pair (var val)
   (let ((b (lookup-in-lexenv var *environment* 'variable)))
 
 (defun setq-pair (var val)
   (let ((b (lookup-in-lexenv var *environment* 'variable)))

-    (if (eq (binding-type b) 'lexical-variable)
+    (if (and (eq (binding-type b) 'variable)
+             (not (member 'special (binding-declarations b)))
+             (not (member 'constant (binding-declarations b))))

         (concat (binding-value b) " = " (ls-compile val))
         (ls-compile `(set ',var ,val)))))
 
         (concat (binding-value b) " = " (ls-compile val))
         (ls-compile `(set ',var ,val)))))
 

@@ -1291,12 +1357,17 @@
     ((symbolp sexp)
      (or (cdr (assoc sexp *literal-symbols*))
         (let ((v (genlit))
     ((symbolp sexp)
      (or (cdr (assoc sexp *literal-symbols*))
         (let ((v (genlit))

-              (s #+common-lisp (concat "{name: \"" (escape-string (symbol-name sexp)) "\"}")
-                 #+ecmalisp
-                  (let ((package (symbol-package sexp)))
-                    (if (null package)
-                        (concat "{name: \"" (escape-string (symbol-name sexp)) "\"}")
-                        (ls-compile `(intern ,(symbol-name sexp) ,(package-name package)))))))
+              (s #+common-lisp
+                 (let ((package (symbol-package sexp)))
+                   (if (eq package (find-package "KEYWORD"))
+                       (concat "{name: \"" (escape-string (symbol-name sexp))
+                               "\", 'package': '" (package-name package) "'}")
+                       (concat "{name: \"" (escape-string (symbol-name sexp)) "\"}")))
+                 #+ecmalisp
+                 (let ((package (symbol-package sexp)))
+                   (if (null package)
+                       (concat "{name: \"" (escape-string (symbol-name sexp)) "\"}")
+                       (ls-compile `(intern ,(symbol-name sexp) ,(package-name package)))))))

           (push (cons sexp v) *literal-symbols*)
           (toplevel-compilation (concat "var " v " = " s))
           v)))
           (push (cons sexp v) *literal-symbols*)
           (toplevel-compilation (concat "var " v " = " s))
           v)))

@@ -1340,6 +1411,50 @@
     ((symbolp x)
      (ls-compile `(symbol-function ',x)))))
 
     ((symbolp x)
      (ls-compile `(symbol-function ',x)))))
 

+
+(defun make-function-binding (fname)
+  (make-binding fname 'function (gvarname fname)))
+
+(defun compile-function-definition (list)
+  (compile-lambda (car list) (cdr list)))
+
+(defun translate-function (name)
+  (let ((b (lookup-in-lexenv name *environment* 'function)))
+    (binding-value b)))
+
+(define-compilation flet (definitions &rest body)
+  (let* ((fnames (mapcar #'car definitions))
+         (fbody  (mapcar #'cdr definitions))
+         (cfuncs (mapcar #'compile-function-definition fbody))
+         (*environment*
+          (extend-lexenv (mapcar #'make-function-binding fnames)
+                         *environment*
+                         'function)))
+    (concat "(function("
+            (join (mapcar #'translate-function fnames) ",")
+            "){" *newline*
+            (let ((body (ls-compile-block body t)))
+              (indent body))
+            "})(" (join cfuncs ",") ")")))
+
+(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))
+            "})")))
+
+
+

 (defvar *compiling-file* nil)
 (define-compilation eval-when-compile (&rest body)
   (if *compiling-file*
 (defvar *compiling-file* nil)
 (define-compilation eval-when-compile (&rest body)
   (if *compiling-file*

@@ -1410,7 +1525,7 @@
 
 
 ;;; Return the code to initialize BINDING, and push it extending the
 
 
 ;;; Return the code to initialize BINDING, and push it extending the

-;;; current lexical environment if the variable is special.
+;;; current lexical environment if the variable is not special.

 (defun let*-initialize-value (binding)
   (let ((var (first binding))
         (value (second binding)))
 (defun let*-initialize-value (binding)
   (let ((var (first binding))
         (value (second binding)))

@@ -2030,18 +2145,17 @@
         form)))
 
 (defun compile-funcall (function args)
         form)))
 
 (defun compile-funcall (function args)

-  (let ((values-funcs (if *multiple-value-p* "values" "pv")))
-    (if (and (symbolp function)
-             #+ecmalisp (eq (symbol-package function) (find-package "COMMON-LISP"))
-             #+common-lisp t)
-        (concat (ls-compile `',function) ".fvalue("
-                (join (cons values-funcs (mapcar #'ls-compile args))
-                      ", ")
-                ")")
-        (concat (ls-compile `#',function) "("
-                (join (cons values-funcs (mapcar #'ls-compile args))
-                      ", ")
-                ")"))))
+  (let* ((values-funcs (if *multiple-value-p* "values" "pv"))
+         (arglist (concat "(" (join (cons values-funcs (mapcar #'ls-compile args)) ", ") ")")))
+    (cond
+      ((translate-function function)
+       (concat (translate-function function) arglist))
+      ((and (symbolp function)
+            #+ecmalisp (eq (symbol-package function) (find-package "COMMON-LISP"))
+            #+common-lisp t)
+       (concat (ls-compile `',function) ".fvalue" arglist))
+      (t
+       (concat (ls-compile `#',function) arglist)))))

 
 (defun ls-compile-block (sexps &optional return-last-p)
   (if return-last-p
 
 (defun ls-compile-block (sexps &optional return-last-p)
   (if return-last-p

@@ -2118,18 +2232,18 @@
             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
             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 documentation dolist dotimes ecase eq eql equal error eval
-            every export fdefinition find-package find-symbol first 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
+            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
             multiple-value-call multiple-value-list multiple-value-prog1 nil not
             nth nthcdr null numberp or package-name package-use-list packagep

-            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
+            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))
             symbol-plist symbol-value symbolp t tagbody third throw truncate
             unless unwind-protect values values-list variable warn when write-line
             write-string zerop))