X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler.lisp;h=8a9fc36d2ff85e9609126285bc2c31cc649783c2;hb=b475f84a4d2984899d62c35bde41fa10d9a5ef0f;hp=eadbf396593f8cef0c24083555a7e95d98791ff9;hpb=5f52a049c75fd0eeaa33656785891dea65b55a1f;p=jscl.git diff --git a/src/compiler.lisp b/src/compiler.lisp index eadbf39..8a9fc36 100644 --- a/src/compiler.lisp +++ b/src/compiler.lisp @@ -30,7 +30,7 @@ ((integerp arg) (integer-to-string arg)) ((floatp arg) (float-to-string arg)) ((stringp arg) arg) - (t (error "Unknown argument.")))) + (t (error "Unknown argument `~S'." arg)))) args)) ;;; Wrap X with a Javascript code to convert the result from @@ -102,7 +102,7 @@ ((and (listp sd) (car sd) (cddr sd)) sd) (t - (error "Bad slot accessor.")))) + (error "Bad slot description `~S'." sd)))) slots)) (predicate (intern (concat name-string "-P")))) `(progn @@ -124,7 +124,7 @@ (collect `(defun ,accessor-name (x) (unless (,predicate x) - (error ,(concat "The object is not a type " name-string))) + (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 ..)) @@ -291,7 +291,7 @@ (defun ll-rest-argument (ll) (let ((rest (ll-section '&rest ll))) (when (cdr rest) - (error "Bad lambda-list")) + (error "Bad lambda-list `~S'." ll)) (car rest))) (defun ll-keyword-arguments-canonical (ll) @@ -528,7 +528,7 @@ (cond ((null pairs) (return)) ((null (cdr pairs)) - (error "Odd paris in SETQ")) + (error "Odd pairs in SETQ")) (t (concatf result (concat (setq-pair (car pairs) (cadr pairs)) @@ -564,13 +564,13 @@ #+common-lisp (let ((package (symbol-package symbol))) (if (eq package (find-package "KEYWORD")) - (code "{name: \"" (escape-string (symbol-name symbol)) - "\", 'package': '" (package-name package) "'}") - (code "{name: \"" (escape-string (symbol-name symbol)) "\"}"))) + (code "{name: " (dump-string (symbol-name symbol)) + ", 'package': " (dump-string (package-name package)) "}") + (code "{name: " (dump-string (symbol-name symbol)) "}"))) #+jscl (let ((package (symbol-package symbol))) (if (null package) - (code "{name: \"" (escape-string (symbol-name symbol)) "\"}") + (code "{name: " (dump-symbol (symbol-name symbol)) "}") (ls-compile `(intern ,(symbol-name symbol) ,(package-name package)))))) (defun dump-cons (cons) @@ -587,17 +587,20 @@ (let ((elements (vector-to-list array))) (concat "[" (join (mapcar #'literal elements) ", ") "]"))) +(defun dump-string (string) + (code "make_lisp_string(\"" (escape-string string) "\")")) + (defun literal (sexp &optional recursive) (cond ((integerp sexp) (integer-to-string sexp)) ((floatp sexp) (float-to-string sexp)) ((characterp sexp) (code "\"" (escape-string (string sexp)) "\"")) - ((stringp sexp) (code "\"" (escape-string sexp) "\"")) (t - (or (cdr (assoc sexp *literal-table*)) + (or (cdr (assoc sexp *literal-table* :test #'equal)) (let ((dumped (typecase sexp (symbol (dump-symbol sexp)) (cons (dump-cons sexp)) + (string (dump-string sexp)) (array (dump-array sexp))))) (if (and recursive (not (symbolp sexp))) dumped @@ -830,7 +833,7 @@ (let* ((b (lookup-in-lexenv name *environment* 'block)) (multiple-value-p (member 'multiple-value (binding-declarations b)))) (when (null b) - (error (concat "Unknown block `" (symbol-name name) "'."))) + (error "Return from unknown block `~S'." (symbol-name name))) (push 'used (binding-declarations b)) ;; The binding value is the name of a variable, whose value is the ;; unique identifier of the block as exception. We can't use the @@ -934,7 +937,7 @@ ((symbolp label) (symbol-name label)) ((integerp label) (integer-to-string label))))) (when (null b) - (error (concat "Unknown tag `" n "'."))) + (error "Unknown tag `~S'" label)) (js!selfcall "throw ({" "type: 'tagbody', " @@ -988,7 +991,7 @@ (define-setf-expander %js-vref (var) (let ((new-value (gensym))) (unless (stringp var) - (error "a string was expected")) + (error "`~S' is not a string." var)) (values nil (list var) (list new-value) @@ -1071,8 +1074,7 @@ (bq-process (bq-completely-process (cadr x)))) ((eq (car x) *comma*) (cadr x)) ((eq (car x) *comma-atsign*) - ;; (error ",@~S after `" (cadr x)) - (error "ill-formed")) + (error ",@~S after `" (cadr x))) ;; ((eq (car x) *comma-dot*) ;; ;; (error ",.~S after `" (cadr x)) ;; (error "ill-formed")) @@ -1083,13 +1085,11 @@ (nreconc q (list (list *bq-quote* p))))) (when (eq (car p) *comma*) (unless (null (cddr p)) - ;; (error "Malformed ,~S" p) - (error "Malformed")) + (error "Malformed ,~S" p)) (return (cons *bq-append* (nreconc q (list (cadr p)))))) (when (eq (car p) *comma-atsign*) - ;; (error "Dotted ,@~S" p) - (error "Dotted")) + (error "Dotted ,@~S" p)) ;; (when (eq (car p) *comma-dot*) ;; ;; (error "Dotted ,.~S" p) ;; (error "Dotted")) @@ -1310,7 +1310,7 @@ (defmacro variable-arity (args &body body) (unless (symbolp args) - (error "Bad usage of VARIABLE-ARITY, you must pass a symbol")) + (error "`~S' is not a symbol." args)) `(variable-arity-call ,args (lambda (,args) (code "return " ,@body ";" *newline*)))) @@ -1385,7 +1385,7 @@ (define-builtin float-to-string (x) (type-check (("x" "number" x)) - "x.toString()")) + "make_lisp_string(x.toString())")) (define-builtin cons (x y) (code "({car: " x ", cdr: " y "})")) @@ -1425,8 +1425,7 @@ "return (typeof tmp == 'object' && 'name' in tmp);" *newline*))) (define-builtin make-symbol (name) - (type-check (("name" "string" name)) - "({name: name})")) + (code "({name: " name "})")) (define-builtin symbol-name (x) (code "(" x ").name")) @@ -1458,7 +1457,7 @@ (code "((" x ").plist || " (ls-compile nil) ")")) (define-builtin lambda-code (x) - (code "(" x ").toString()")) + (code "make_lisp_string((" x ").toString())")) (define-builtin eq (x y) (js!bool (code "(" x " === " y ")"))) @@ -1478,37 +1477,39 @@ "return (typeof(" x ") == \"string\") && x.length == 1;"))) (define-builtin char-to-string (x) - (type-check (("x" "number" x)) - "String.fromCharCode(x)")) + (js!selfcall + "var r = [" x "];" *newline* + "r.type = 'character';" + "return r")) (define-builtin stringp (x) - (js!bool (code "(typeof(" x ") == \"string\")"))) + (js!bool + (js!selfcall + "var x = " x ";" *newline* + "return typeof(x) == 'object' && 'length' in x && x.type == 'character';"))) (define-builtin string-upcase (x) - (type-check (("x" "string" x)) - "x.toUpperCase()")) + (code "make_lisp_string(" x ".join('').toUppercase())")) (define-builtin string-length (x) - (type-check (("x" "string" x)) - "x.length")) + (code x ".length")) -(define-raw-builtin slice (string a &optional b) +(define-raw-builtin slice (vector a &optional b) (js!selfcall - "var str = " (ls-compile string) ";" *newline* + "var vector = " (ls-compile vector) ";" *newline* "var a = " (ls-compile a) ";" *newline* "var b;" *newline* (when b (code "b = " (ls-compile b) ";" *newline*)) - "return str.slice(a,b);" *newline*)) + "return vector.slice(a,b);" *newline*)) (define-builtin char (string index) - (type-check (("string" "string" string) - ("index" "number" index)) - "string.charAt(index)")) + (code string "[" index "]")) (define-builtin concat-two (string1 string2) - (type-check (("string1" "string" string1) - ("string2" "string" string2)) - "string1.concat(string2)")) + (js!selfcall + "var r = " string1 ".concat(" string2 ");" *newline* + "r.type = 'character';" + "return r;" *newline*)) (define-raw-builtin funcall (func &rest args) (js!selfcall @@ -1541,14 +1542,13 @@ "return (typeof f === 'function'? f : f.fvalue).apply(this, args);" *newline*)))) (define-builtin js-eval (string) - (type-check (("string" "string" string)) - (if *multiple-value-p* - (js!selfcall - "var v = globalEval(string);" *newline* - "return values.apply(this, forcemv(v));" *newline*) - "globalEval(string)"))) + (if *multiple-value-p* + (js!selfcall + "var v = globalEval(" string ".join(''));" *newline* + "return values.apply(this, forcemv(v));" *newline*) + (code "globalEval(" string ".join(''))"))) -(define-builtin error (string) +(define-builtin %throw (string) (js!selfcall "throw " string ";" *newline*)) (define-builtin new () "{}") @@ -1571,8 +1571,7 @@ (js!bool (code "(typeof " x " == 'function')"))) (define-builtin write-string (x) - (type-check (("x" "string" x)) - "lisp.write(x)")) + (code "lisp.write(" x ".join(''))")) (define-builtin make-array (n) (js!selfcall @@ -1670,7 +1669,7 @@ (unless (or (symbolp function) (and (consp function) (eq (car function) 'lambda))) - (error "Bad function")) + (error "Bad function designator `~S'" function)) (cond ((translate-function function) (concat (translate-function function) arglist)) @@ -1706,11 +1705,8 @@ (code (ls-compile `',sexp) ".value")) (t (ls-compile `(symbol-value ',sexp)))))) - ((integerp sexp) (integer-to-string sexp)) - ((floatp sexp) (float-to-string sexp)) - ((characterp sexp) (code "\"" (escape-string (string sexp)) "\"")) - ((stringp sexp) (code "\"" (escape-string sexp) "\"")) - ((arrayp sexp) (literal sexp)) + ((or (integerp sexp) (floatp sexp) (characterp sexp) (stringp sexp) (arrayp sexp)) + (literal sexp)) ((listp sexp) (let ((name (car sexp)) (args (cdr sexp))) @@ -1727,7 +1723,7 @@ (t (compile-funcall name args))))) (t - (error (concat "How should I compile " (prin1-to-string sexp) "?"))))))) + (error "How should I compile `~S'?" sexp)))))) (defvar *compile-print-toplevels* nil) @@ -1748,10 +1744,7 @@ (t (when *compile-print-toplevels* (let ((form-string (prin1-to-string sexp))) - (write-string "Compiling ") - (write-string (truncate-string form-string)) - (write-line "..."))) - + (format t "Compiling ~a..." (truncate-string form-string)))) (let ((code (ls-compile sexp multiple-value-p))) (code (join-trailing (get-toplevel-compilations) (code ";" *newline*))