(defvar *package-list* nil)
- (defun make-package (name)
- (let ((package (new)))
+ (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 *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)))))))
(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 ((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)
+ (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
(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.
+ (intern 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)))
" throw cf;" *newline*
"}" *newline*))
-(define-compilation throw (id &optional value)
+(define-compilation throw (id value)
(js!selfcall
"throw ({"
"type: 'catch', "
(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 lambda-code last
+ length let 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