(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))
(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
(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)
(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)
(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)))
(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)))
" throw cf;" *newline*
"}" *newline*))
-(define-compilation throw (id &optional value)
+(define-compilation throw (id value)
(js!selfcall
"throw ({"
"type: 'catch', "
(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))))))
(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)
projects / jscl.git / blobdiff