X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler.lisp;h=4a274133e68418e58f875825f528b228a9d8e9e2;hb=25702fbbf0ddd2e5386bbf257eee8150adfc7b47;hp=7bf3dc9ea910a7415880add787ab06687c59524f;hpb=0beeb9eb073f547213d21bd5ecf4a6bc7a596210;p=jscl.git diff --git a/src/compiler.lisp b/src/compiler.lisp index 7bf3dc9..4a27413 100644 --- a/src/compiler.lisp +++ b/src/compiler.lisp @@ -68,7 +68,7 @@ (incf index)) output))) -#+common-lisp +#-jscl (defun indent (&rest string) (with-output-to-string (*standard-output*) (with-input-from-string (input (apply #'code string)) @@ -87,62 +87,6 @@ ;;; function call. (defvar *multiple-value-p* nil) -;; A very simple defstruct built on lists. It supports just slot with -;; an optional default initform, and it will create a constructor, -;; predicate and accessors for you. -(defmacro def!struct (name &rest slots) - (unless (symbolp name) - (error "It is not a full defstruct implementation.")) - (let* ((name-string (symbol-name name)) - (slot-descriptions - (mapcar (lambda (sd) - (cond - ((symbolp sd) - (list sd)) - ((and (listp sd) (car sd) (cddr sd)) - sd) - (t - (error "Bad slot description `~S'." sd)))) - slots)) - (predicate (intern (concat name-string "-P")))) - `(progn - ;; Constructor - (defun ,(intern (concat "MAKE-" name-string)) (&key ,@slot-descriptions) - (list ',name ,@(mapcar #'car slot-descriptions))) - ;; Predicate - (defun ,predicate (x) - (and (consp x) (eq (car x) ',name))) - ;; Copier - (defun ,(intern (concat "COPY-" name-string)) (x) - (copy-list x)) - ;; Slot accessors - ,@(with-collect - (let ((index 1)) - (dolist (slot slot-descriptions) - (let* ((name (car slot)) - (accessor-name (intern (concat name-string "-" (string name))))) - (collect - `(defun ,accessor-name (x) - (unless (,predicate x) - (error "The object `~S' is not of type `~S'" x ,name-string)) - (nth ,index x))) - ;; TODO: Implement this with a higher level - ;; abstraction like defsetf or (defun (setf ..)) - (collect - `(define-setf-expander ,accessor-name (x) - (let ((object (gensym)) - (new-value (gensym))) - (values (list object) - (list x) - (list new-value) - `(progn - (rplaca (nthcdr ,',index ,object) ,new-value) - ,new-value) - `(,',accessor-name ,object))))) - (incf index))))) - ',name))) - - ;;; Environment (def!struct binding @@ -537,7 +481,8 @@ (code "(" result ")"))) -;;; Literals +;;; Compilation of literals an object dumping + (defun escape-string (string) (let ((output "") (index 0) @@ -553,6 +498,24 @@ (incf index)) output)) +;;; BOOTSTRAP MAGIC: We record the macro definitions as lists during +;;; the bootstrap. Once everything is compiled, we want to dump the +;;; whole global environment to the output file to reproduce it in the +;;; run-time. However, the environment must contain expander functions +;;; rather than lists. We do not know how to dump function objects +;;; itself, so we mark the list definitions with this object and the +;;; compiler will be called when this object has to be dumped. +;;; Backquote/unquote does a similar magic, but this use is exclusive. +;;; +;;; Indeed, perhaps to compile the object other macros need to be +;;; evaluated. For this reason we define a valid macro-function for +;;; this symbol. +(defvar *magic-unquote-marker* (gensym "MAGIC-UNQUOTE")) +#-jscl +(setf (macro-function *magic-unquote-marker*) + (lambda (form &optional environment) + (declare (ignore environment)) + (second form))) (defvar *literal-table* nil) (defvar *literal-counter* 0) @@ -561,16 +524,15 @@ (code "l" (incf *literal-counter*))) (defun dump-symbol (symbol) - #+common-lisp + #-jscl (let ((package (symbol-package symbol))) (if (eq package (find-package "KEYWORD")) - (code "{name: " (dump-string (symbol-name symbol)) - ", 'package': " (dump-string (package-name package)) "}") - (code "{name: " (dump-string (symbol-name symbol)) "}"))) + (code "(new Symbol(" (dump-string (symbol-name symbol)) ", " (dump-string (package-name package)) "))") + (code "(new Symbol(" (dump-string (symbol-name symbol)) "))"))) #+jscl (let ((package (symbol-package symbol))) (if (null package) - (code "{name: " (dump-symbol (symbol-name symbol)) "}") + (code "(new Symbol(" (dump-string (symbol-name symbol)) "))") (ls-compile `(intern ,(symbol-name symbol) ,(package-name package)))))) (defun dump-cons (cons) @@ -599,16 +561,26 @@ (or (cdr (assoc sexp *literal-table* :test #'equal)) (let ((dumped (typecase sexp (symbol (dump-symbol sexp)) - (cons (dump-cons sexp)) (string (dump-string sexp)) + (cons + ;; BOOTSTRAP MAGIC: See the root file + ;; jscl.lisp and the function + ;; `dump-global-environment' for futher + ;; information. + (if (eq (car sexp) *magic-unquote-marker*) + (ls-compile (second sexp)) + (dump-cons sexp))) (array (dump-array sexp))))) (if (and recursive (not (symbolp sexp))) dumped (let ((jsvar (genlit))) (push (cons sexp jsvar) *literal-table*) (toplevel-compilation (code "var " jsvar " = " dumped)) + (when (keywordp sexp) + (toplevel-compilation (code jsvar ".value = " jsvar))) jsvar))))))) + (define-compilation quote (sexp) (literal sexp)) @@ -981,24 +953,6 @@ "return args;" *newline*)) -;;; Javascript FFI - -(define-compilation %js-vref (var) var) - -(define-compilation %js-vset (var val) - (code "(" var " = " (ls-compile val) ")")) - -(define-setf-expander %js-vref (var) - (let ((new-value (gensym))) - (unless (stringp var) - (error "`~S' is not a string." var)) - (values nil - (list var) - (list new-value) - `(%js-vset ,var ,new-value) - `(%js-vref ,var)))) - - ;;; Backquote implementation. ;;; ;;; Author: Guy L. Steele Jr. Date: 27 December 1985 @@ -1419,13 +1373,10 @@ (code "(x.cdr = " new ", x)"))) (define-builtin symbolp (x) - (js!bool - (js!selfcall - "var tmp = " x ";" *newline* - "return (typeof tmp == 'object' && 'name' in tmp);" *newline*))) + (js!bool (code "(" x " instanceof Symbol)"))) (define-builtin make-symbol (name) - (code "({name: " name "})")) + (code "(new Symbol(" name "))")) (define-builtin symbol-name (x) (code "(" x ").name")) @@ -1482,6 +1433,12 @@ "r.type = 'character';" "return r")) +(define-builtin char-upcase (x) + (code x ".toUpperCase()")) + +(define-builtin char-downcase (x) + (code x ".toLowerCase()")) + (define-builtin stringp (x) (js!bool (js!selfcall @@ -1580,6 +1537,14 @@ (indent "r.push(" (ls-compile nil) ");" *newline*) "return r;" *newline*)) +;;; FIXME: should take optional min-extension. +;;; FIXME: should use fill-pointer instead of the absolute end of array +(define-builtin vector-push-extend (new vector) + (js!selfcall + "var v = " vector ";" *newline* + "v.push(" new ");" *newline* + "return v;")) + (define-builtin arrayp (x) (js!bool (js!selfcall @@ -1599,6 +1564,18 @@ "if (i < 0 || i >= x.length) throw 'Out of range';" *newline* "return x[i] = " value ";" *newline*)) +(define-builtin afind (value array) + (js!selfcall + "var v = " value ";" *newline* + "var x = " array ";" *newline* + "return x.indexOf(v);" *newline*)) + +(define-builtin aresize (array new-size) + (js!selfcall + "var x = " array ";" *newline* + "var n = " new-size ";" *newline* + "return x.length = n;" *newline*)) + (define-builtin get-internal-real-time () "(new Date()).getTime()") @@ -1612,51 +1589,66 @@ (code "values(" (join (mapcar #'ls-compile args) ", ") ")") (code "pv(" (join (mapcar #'ls-compile args) ", ") ")"))) -;; Receives the JS function as first argument as a literal string. The -;; second argument is compiled and should evaluate to a vector of -;; values to apply to the the function. The result returned. -(define-builtin %js-call (fun args) - (code fun ".apply(this, " args ")")) -(defun macro (x) - (and (symbolp x) - (let ((b (lookup-in-lexenv x *environment* 'function))) - (if (and b (eq (binding-type b) 'macro)) - b - nil)))) +;;; Javascript FFI + +(define-compilation %js-vref (var) + (code "js_to_lisp(" var ")")) + +(define-compilation %js-vset (var val) + (code "(" var " = lisp_to_js(" (ls-compile val) "))")) + +(define-setf-expander %js-vref (var) + (let ((new-value (gensym))) + (unless (stringp var) + (error "`~S' is not a string." var)) + (values nil + (list var) + (list new-value) + `(%js-vset ,var ,new-value) + `(%js-vref ,var)))) + -#+common-lisp +#-jscl (defvar *macroexpander-cache* (make-hash-table :test #'eq)) -(defun ls-macroexpand-1 (form) +(defun !macro-function (symbol) + (unless (symbolp symbol) + (error "`~S' is not a symbol." symbol)) + (let ((b (lookup-in-lexenv symbol *environment* 'function))) + (if (and b (eq (binding-type b) 'macro)) + (let ((expander (binding-value b))) + (cond + #-jscl + ((gethash b *macroexpander-cache*) + (setq expander (gethash b *macroexpander-cache*))) + ((listp expander) + (let ((compiled (eval expander))) + ;; The list representation are useful while + ;; bootstrapping, as we can dump the definition of the + ;; macros easily, but they are slow because we have to + ;; evaluate them and compile them now and again. So, let + ;; us replace the list representation version of the + ;; function with the compiled one. + ;; + #+jscl (setf (binding-value b) compiled) + #-jscl (setf (gethash b *macroexpander-cache*) compiled) + (setq expander compiled)))) + expander) + nil))) + +(defun !macroexpand-1 (form) (cond ((symbolp form) (let ((b (lookup-in-lexenv form *environment* 'variable))) (if (and b (eq (binding-type b) 'macro)) (values (binding-value b) t) (values form nil)))) - ((consp form) - (let ((macro-binding (macro (car form)))) - (if macro-binding - (let ((expander (binding-value macro-binding))) - (cond - #+common-lisp - ((gethash macro-binding *macroexpander-cache*) - (setq expander (gethash macro-binding *macroexpander-cache*))) - ((listp expander) - (let ((compiled (eval expander))) - ;; The list representation are useful while - ;; bootstrapping, as we can dump the definition of the - ;; macros easily, but they are slow because we have to - ;; evaluate them and compile them now and again. So, let - ;; us replace the list representation version of the - ;; function with the compiled one. - ;; - #+jscl (setf (binding-value macro-binding) compiled) - #+common-lisp (setf (gethash macro-binding *macroexpander-cache*) compiled) - (setq expander compiled)))) - (values (apply expander (cdr form)) t)) + ((and (consp form) (symbolp (car form))) + (let ((macrofun (!macro-function (car form)))) + (if macrofun + (values (funcall macrofun (cdr form)) t) (values form nil)))) (t (values form nil)))) @@ -1675,7 +1667,7 @@ (concat (translate-function function) arglist)) ((and (symbolp function) #+jscl (eq (symbol-package function) (find-package "COMMON-LISP")) - #+common-lisp t) + #-jscl t) (code (ls-compile `',function) ".fvalue" arglist)) (t (code (ls-compile `#',function) arglist))))) @@ -1689,7 +1681,7 @@ (concat ";" *newline*)))) (defun ls-compile (sexp &optional multiple-value-p) - (multiple-value-bind (sexp expandedp) (ls-macroexpand-1 sexp) + (multiple-value-bind (sexp expandedp) (!macroexpand-1 sexp) (when expandedp (return-from ls-compile (ls-compile sexp multiple-value-p))) ;; The expression has been macroexpanded. Now compile it!