X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=ecmalisp.lisp;h=ac6f02b7d0b8c820ceeae986bd321097014f2e71;hb=b0e60d593040ed49161ced44aa42fa4f170b9be0;hp=cb89dfc00a43213f12029305a49d9f4663ddfb77;hpb=04eb2ffe0a6043e3d1f979088f4ca90463b07b79;p=jscl.git diff --git a/ecmalisp.lisp b/ecmalisp.lisp index cb89dfc..ac6f02b 100644 --- a/ecmalisp.lisp +++ b/ecmalisp.lisp @@ -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,32 @@ ;; 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)) + (symbols (%package-symbols package))) + (if (in name symbols) + (values (oget symbols name) 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) t)))))))) (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))) @@ -706,15 +708,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 +780,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 +968,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 +1030,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))) @@ -1321,12 +1350,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))) @@ -2156,10 +2190,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))