X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=inline;f=ecmalisp.lisp;h=62fe386f3220aa574a0d28f58c833240afe3c746;hb=34b79808c580ec5155548212586eb2b6a88e174e;hp=85742223f4c4584ca32b76de615866b14be2b611;hpb=36dfabf41ef61177f8dba87b58bde0639d8d369a;p=jscl.git diff --git a/ecmalisp.lisp b/ecmalisp.lisp index 8574222..62fe386 100644 --- 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 rest (x) (cdr x)) (defun list (&rest args) args) (defun atom (x) @@ -301,6 +302,34 @@ `(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)) @@ -409,15 +438,6 @@ (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) @@ -491,6 +511,14 @@ (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) @@ -560,29 +588,37 @@ ;; 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))) - (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*)) - (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))) - (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))) @@ -590,7 +626,8 @@ (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) @@ -678,15 +715,7 @@ (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 @@ -758,15 +787,17 @@ (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) @@ -944,6 +975,40 @@ (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) @@ -972,9 +1037,8 @@ (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))) @@ -1051,7 +1115,7 @@ (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 @@ -1234,7 +1298,9 @@ (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))))) @@ -1291,12 +1357,17 @@ ((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))) @@ -1340,6 +1411,50 @@ ((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* @@ -1410,7 +1525,7 @@ ;;; 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))) @@ -2030,18 +2145,17 @@ 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 @@ -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 - 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 - 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))