X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=ecmalisp.lisp;h=20c68124f930d75f4e6268d27329b8f0a5fce5f7;hb=bfc35a4a1c2c0ba780ef686a166529534beb1be4;hp=7b46a86a9174608ee1b8902392416208b1a3d3b8;hpb=81db23f4ad7e7f6c632c25285e3bfe5b4b168e46;p=jscl.git diff --git a/ecmalisp.lisp b/ecmalisp.lisp index 7b46a86..20c6812 100644 --- a/ecmalisp.lisp +++ b/ecmalisp.lisp @@ -302,7 +302,7 @@ (setq ,@(!reduce #'append (mapcar #'butlast assignments) '()))))) (defmacro do (varlist endlist &body body) - `(block nil + `(block nil (let ,(mapcar (lambda (x) (list (first x) (second x))) varlist) (while t (when ,(car endlist) @@ -311,12 +311,12 @@ (psetq ,@(apply #'append (mapcar (lambda (v) - (and (consp (cdr v)) + (and (consp (cddr v)) (list (first v) (third v)))) varlist))))))) (defmacro do* (varlist endlist &body body) - `(block nil + `(block nil (let* ,(mapcar (lambda (x) (list (first x) (second x))) varlist) (while t (when ,(car endlist) @@ -325,10 +325,10 @@ (setq ,@(apply #'append (mapcar (lambda (v) - (and (consp (cdr v)) + (and (consp (cddr v)) (list (first v) (third v)))) varlist))))))) - + (defun list-length (list) (let ((l 0)) (while (not (null list)) @@ -437,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) @@ -519,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) @@ -588,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 + (values symbol foundp) (let ((symbols (%package-symbols package))) (oget symbols name) (let ((symbol (make-symbol name))) @@ -618,7 +625,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) @@ -706,15 +714,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 @@ -786,15 +786,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) @@ -972,6 +974,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) @@ -1000,9 +1036,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))) @@ -1079,7 +1114,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 @@ -1262,7 +1297,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))))) @@ -1319,12 +1356,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))) @@ -1438,7 +1480,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))) @@ -2154,10 +2196,10 @@ 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))