X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=ecmalisp.lisp;h=8cb2b9f8ef436a99eeaa7dec4c7269cd29cce767;hb=18e9b9400e56500abf7a05de3418aa9f569c2fbf;hp=4ed550d0535010c7a52c1c67a7cea42b4170149b;hpb=074ea419432183745005ee18871b55bfc167dd5b;p=jscl.git diff --git a/ecmalisp.lisp b/ecmalisp.lisp index 4ed550d..8cb2b9f 100644 --- a/ecmalisp.lisp +++ b/ecmalisp.lisp @@ -456,10 +456,16 @@ (defvar *package-list* nil) - (defun make-package (name) - (let ((package (new))) + (defun list-all-packages () + *package-list*) + + (defun make-package (name &optional use) + (let ((package (new)) + (use (mapcar #'find-package-or-fail use))) (oset package "packageName" name) (oset package "symbols" (new)) + (oset package "exports" (new)) + (oset package "use" use) (push package *package-list*) package)) @@ -486,33 +492,76 @@ (let ((package (find-package-or-fail package-designator))) (oget package "symbols"))) - (defvar *package* + (defun package-use-list (package-designator) + (let ((package (find-package-or-fail package-designator))) + (oget package "use"))) + + (defun %package-external-symbols (package-designator) + (let ((package (find-package-or-fail package-designator))) + (oget package "exports"))) + + (defvar *common-lisp-package* (make-package "CL")) + (defvar *user-package* + (make-package "CL-USER" (list *common-lisp-package*))) + + (defvar *keyword-package* + (make-package "KEYWORD")) + + (defun keywordp (x) + (and (symbolp x) (eq (symbol-package x) *keyword-package*))) + + (defvar *package* *common-lisp-package*) + + (defmacro in-package (package-designator) + `(eval-when-compile + (setq *package* (find-package-or-fail ,package-designator)))) + ;; This function is used internally to initialize the CL package ;; with the symbols built during bootstrap. (defun %intern-symbol (symbol) - (let ((symbols (%package-symbols *package*))) - (oset symbol "package" *package*) + (let ((symbols (%package-symbols *common-lisp-package*))) + (oset symbol "package" *common-lisp-package*) (oset symbols (symbol-name symbol) symbol))) - (defun intern (name &optional (package *package*)) - (let ((symbols (%package-symbols package))) - (if (in name symbols) - (oget symbols name) - (let ((symbol (make-symbol name))) - (oset symbol "package" package) - (oset symbols name 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*)) - (let ((symbols (%package-symbols package))) - (oget *package* name))) + (car (%find-symbol name 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) + (let ((symbols (%package-symbols package))) + (oget symbols name) + (let ((symbol (make-symbol name))) + (oset symbol "package" package) + (when (eq package *keyword-package*) + (oset symbol "value" symbol) + (export (list symbol) package)) + (oset symbols name symbol))))))) (defun symbol-package (symbol) (unless (symbolp symbol) (error "it is not a symbol")) - (oget symbol "package"))) + (oget symbol "package")) + (defun export (symbols &optional (package *package*)) + (let ((exports (%package-external-symbols package))) + (dolist (symb symbols t) + (oset exports (symbol-name symb) symb))))) ;;; The compiler offers some primitives and special forms which are @@ -638,7 +687,15 @@ (progn (defun prin1-to-string (form) (cond - ((symbolp form) (symbol-name form)) + ((symbolp form) + (if (cdr (%find-symbol (symbol-name form) *package*)) + (symbol-name form) + (let ((package (symbol-package form)) + (name (symbol-name form))) + (concat (if (eq package (find-package "KEYWORD")) + "" + (package-name package)) + ":" name)))) ((integerp form) (integer-to-string form)) ((stringp form) (concat "\"" (escape-string form) "\"")) ((functionp form) @@ -776,12 +833,48 @@ (t (error "Unknown reader form."))))))) -(defvar *eof* (make-symbol "EOF")) +;;; Parse a string of the form NAME, PACKAGE:NAME or +;;; PACKAGE::NAME and return the name. If the string is of the +;;; form 1) or 3), but the symbol does not exist, it will be created +;;; and interned in that package. +(defun read-symbol (string) + (let ((size (length string)) + package name internalp index) + (setq index 0) + (while (and (< index size) + (not (char= (char string index) #\:))) + (incf index)) + (cond + ;; No package prefix + ((= index size) + (setq name string) + (setq package *package*) + (setq internalp t)) + (t + ;; Package prefix + (if (zerop index) + (setq package "KEYWORD") + (setq package (string-upcase (subseq string 0 index)))) + (incf index) + (when (char= (char string index) #\:) + (setq internalp t) + (incf index)) + (setq name (subseq string index)))) + ;; Canonalize symbol name and package + (setq name (string-upcase name)) + (setq package (find-package package)) + ;; TODO: PACKAGE:SYMBOL should signal error if SYMBOL is not an + ;; external symbol from PACKAGE. + (if (or internalp (eq package (find-package "KEYWORD"))) + (intern name package) + (find-symbol name package)))) + +(defvar *eof* (gensym)) (defun ls-read (stream) (skip-whitespaces-and-comments stream) (let ((ch (%peek-char stream))) (cond - ((null ch) + ((or (null ch) (char= ch #\))) *eof*) ((char= ch #\() (%read-char stream) @@ -806,7 +899,7 @@ (let ((string (read-until stream #'terminalp))) (if (every #'digit-char-p string) (parse-integer string) - (intern (string-upcase string)))))))) + (read-symbol string))))))) (defun ls-read-from-string (string) (ls-read (make-string-stream string))) @@ -1087,7 +1180,9 @@ (or (cdr (assoc sexp *literal-symbols*)) (let ((v (genlit)) (s #+common-lisp (concat "{name: \"" (escape-string (symbol-name sexp)) "\"}") - #+ecmalisp (ls-compile `(intern ,(symbol-name sexp))))) + #+ecmalisp (ls-compile + `(intern ,(symbol-name sexp) + ,(package-name (symbol-package sexp)))))) (push (cons sexp v) *literal-symbols*) (toplevel-compilation (concat "var " v " = " s)) v))) @@ -1221,7 +1316,7 @@ " throw cf;" *newline* "}" *newline*)) -(define-compilation throw (id &optional value) +(define-compilation throw (id value) (js!selfcall "throw ({" "type: 'catch', " @@ -1623,7 +1718,7 @@ (cond ((eq (binding-type b) 'lexical-variable) (binding-value b)) - ((claimp sexp 'variable 'constant) + ((or (keywordp sexp) (claimp sexp 'variable 'constant)) (concat (ls-compile `',sexp) ".value")) (t (ls-compile `(symbol-value ',sexp)))))) @@ -1682,6 +1777,29 @@ (ls-compile-toplevel x)))) (js-eval code))) + (export '(* *gensym-counter* *package* + - / 1+ 1- < <= = = > >= and append + apply assoc atom block boundp 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 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 go identity + in-package incf integerp integerp intern keywordp + lambda-code last length let list-all-packages list listp + make-package make-symbol mapcar member minusp mod nil not + nth nthcdr null numberp or package-name package-use-list + packagep plusp prin1-to-string print proclaim prog1 prog2 + pron 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 variable warn when write-line write-string + zerop)) + + (setq *package* *user-package*) + (js-eval "var lisp") (js-vset "lisp" (new)) (js-vset "lisp.read" #'ls-read-from-string)