(defun second (x) (cadr x))
(defun third (x) (caddr x))
(defun fourth (x) (cadddr x))
+ (defun rest (x) (cdr x))
(defun list (&rest args) args)
(defun atom (x)
;; 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 &optional (package *package*))
(let* ((package (find-package-or-fail package))
+ (externals (%package-external-symbols 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))))))))
+ (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)))
(multiple-value-bind (symbol foundp)
(find-symbol name package)
(if foundp
- symbol
+ (values symbol foundp)
(let ((symbols (%package-symbols package)))
(oget symbols name)
(let ((symbol (make-symbol name)))
(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)
((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)))
((symbolp x)
(ls-compile `(symbol-function ',x)))))
+
+(defun make-function-binding (fname)
+ (make-binding fname 'function (gvarname fname)))
+
+(defun compile-function-definition (list)
+ (compile-lambda (car list) (cdr list)))
+
+(defun translate-function (name)
+ (let ((b (lookup-in-lexenv name *environment* 'function)))
+ (binding-value b)))
+
+(define-compilation flet (definitions &rest body)
+ (let* ((fnames (mapcar #'car definitions))
+ (fbody (mapcar #'cdr definitions))
+ (cfuncs (mapcar #'compile-function-definition fbody))
+ (*environment*
+ (extend-lexenv (mapcar #'make-function-binding fnames)
+ *environment*
+ 'function)))
+ (concat "(function("
+ (join (mapcar #'translate-function fnames) ",")
+ "){" *newline*
+ (let ((body (ls-compile-block body t)))
+ (indent body))
+ "})(" (join cfuncs ",") ")")))
+
+(define-compilation labels (definitions &rest body)
+ (let* ((fnames (mapcar #'car definitions))
+ (fbody (mapcar #'cdr definitions))
+ (*environment*
+ (extend-lexenv (mapcar #'make-function-binding fnames)
+ *environment*
+ 'function))
+ (cfuncs (mapcar #'compile-function-definition fbody)))
+ (concat "(function(){" *newline*
+ (join (mapcar (lambda (func)
+ ())
+ definitions))
+ (let ((body (ls-compile-block body t)))
+ (indent body))
+ "})")))
+
+
+
(defvar *compiling-file* nil)
(define-compilation eval-when-compile (&rest body)
(if *compiling-file*
form)))
(defun compile-funcall (function args)
- (let ((values-funcs (if *multiple-value-p* "values" "pv")))
- (if (and (symbolp function)
- #+ecmalisp (eq (symbol-package function) (find-package "COMMON-LISP"))
- #+common-lisp t)
- (concat (ls-compile `',function) ".fvalue("
- (join (cons values-funcs (mapcar #'ls-compile args))
- ", ")
- ")")
- (concat (ls-compile `#',function) "("
- (join (cons values-funcs (mapcar #'ls-compile args))
- ", ")
- ")"))))
+ (let* ((values-funcs (if *multiple-value-p* "values" "pv"))
+ (arglist (concat "(" (join (cons values-funcs (mapcar #'ls-compile args)) ", ") ")")))
+ (cond
+ ((translate-function function)
+ (concat (translate-function function) arglist))
+ ((and (symbolp function)
+ #+ecmalisp (eq (symbol-package function) (find-package "COMMON-LISP"))
+ #+common-lisp t)
+ (concat (ls-compile `',function) ".fvalue" arglist))
+ (t
+ (concat (ls-compile `#',function) arglist)))))
(defun ls-compile-block (sexps &optional return-last-p)
(if return-last-p
decf declaim defparameter defun defmacro defvar digit-char-p
disassemble do do* documentation dolist dotimes ecase eq eql equal
error eval every export fdefinition find-package find-symbol first
- fourth fset funcall function functionp gensym get-universal-time go
- identity if in-package incf integerp integerp intern keywordp lambda
+ flet fourth fset funcall function functionp gensym get-universal-time
+ go identity if in-package incf integerp integerp intern keywordp lambda
last length let let* list-all-packages list listp make-array
make-package make-symbol mapcar member minusp mod multiple-value-bind
multiple-value-call multiple-value-list multiple-value-prog1 nil not
projects / jscl.git / blobdiff