X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=ecmalisp.lisp;h=867c2835ab3265fe1f3c89115c6cbbb4a0149d98;hb=90d70940965a3c6348ef5046dcee2455bdbcda10;hp=d8806141993b254c4e1f0070e8e3d34d91dbc051;hpb=2d5ef7b50ce3a117e48eaa5bf04e6735a746b3a8;p=jscl.git diff --git a/ecmalisp.lisp b/ecmalisp.lisp index d880614..867c283 100644 --- a/ecmalisp.lisp +++ b/ecmalisp.lisp @@ -301,6 +301,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 +437,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 +510,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 +587,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 + symbol (let ((symbols (%package-symbols package))) (oget symbols name) (let ((symbol (make-symbol name))) @@ -623,11 +658,6 @@ (defun concat-two (s1 s2) (concatenate 'string s1 s2)) - (defun setcar (cons new) - (setf (car cons) new)) - (defun setcdr (cons new) - (setf (cdr cons) new)) - (defun aset (array idx value) (setf (aref array idx) value))) @@ -683,15 +713,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 @@ -763,15 +785,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) @@ -821,7 +845,7 @@ (defun %read-char (stream) (and (< (cdr stream) (length (car stream))) (prog1 (char (car stream) (cdr stream)) - (setcdr stream (1+ (cdr stream)))))) + (rplacd stream (1+ (cdr stream)))))) (defun whitespacep (ch) (or (char= ch #\space) (char= ch #\newline) (char= ch #\tab))) @@ -949,6 +973,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) @@ -977,9 +1035,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))) @@ -1010,10 +1067,10 @@ (defun binding-declarations (b) (fourth b)) (defun set-binding-value (b value) - (setcar (cddr b) value)) + (rplaca (cddr b) value)) (defun set-binding-declarations (b value) - (setcar (cdddr b) value)) + (rplaca (cdddr b) value)) (defun push-binding-declaration (decl b) (set-binding-declarations b (cons decl (binding-declarations b)))) @@ -1027,10 +1084,10 @@ (defun push-to-lexenv (binding lexenv namespace) (ecase namespace - (variable (setcar lexenv (cons binding (car lexenv)))) - (function (setcar (cdr lexenv) (cons binding (cadr lexenv)))) - (block (setcar (cddr lexenv) (cons binding (caddr lexenv)))) - (gotag (setcar (cdddr lexenv) (cons binding (cadddr lexenv)))))) + (variable (rplaca lexenv (cons binding (car lexenv)))) + (function (rplaca (cdr lexenv) (cons binding (cadr lexenv)))) + (block (rplaca (cddr lexenv) (cons binding (caddr lexenv)))) + (gotag (rplaca (cdddr lexenv) (cons binding (cadddr lexenv)))))) (defun extend-lexenv (bindings lexenv namespace) (let ((env (copy-lexenv lexenv))) @@ -1056,7 +1113,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 @@ -1239,7 +1296,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))))) @@ -1296,12 +1355,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))) @@ -1415,7 +1479,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))) @@ -1820,13 +1884,13 @@ (ls-compile nil) ": tmp.cdr;" *newline*)) -(define-builtin setcar (x new) +(define-builtin rplaca (x new) (type-check (("x" "object" x)) - (concat "(x.car = " new ")"))) + (concat "(x.car = " new ", x)"))) -(define-builtin setcdr (x new) +(define-builtin rplacd (x new) (type-check (("x" "object" x)) - (concat "(x.cdr = " new ")"))) + (concat "(x.cdr = " new ", x)"))) (define-builtin symbolp (x) (js!bool @@ -2123,20 +2187,20 @@ 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 + 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 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 + 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*)