├── .gitignore ├── utils.lisp ├── README.md ├── cl-js.asd ├── bench.lisp ├── package.lisp ├── LICENSE ├── js.lisp ├── inline-op.lisp ├── api.lisp ├── url-encode.lisp ├── operators.lisp ├── json.lisp ├── deflib.lisp ├── test.js ├── infer.lisp ├── index.html ├── translate.lisp ├── bench ├── ray.js └── codemirror.js └── jsos.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | -------------------------------------------------------------------------------- /utils.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-js) 2 | 3 | (defun js-intern (sym) 4 | (intern (concatenate 'string (symbol-name :js) (symbol-name sym)) :cl-js)) 5 | 6 | (defmacro with-ignored-style-warnings (&body body) 7 | `(locally #+sbcl (declare (sb-ext:muffle-conditions style-warning)) ,@body)) 8 | 9 | (defmacro trunc32 (int) 10 | (let ((r1 (gensym))) 11 | `(let ((,r1 (ldb (byte 32 0) ,int))) 12 | (if (>= ,r1 #.(expt 2 31)) (- ,r1 #.(expt 2 32)) ,r1)))) 13 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | CL-Javascript 2 | ============= 3 | 4 | See [http://marijnhaverbeke.nl/cl-javascript][home] for the project 5 | homepage. 6 | 7 | CL-JavaScript is a compiler (translator) aimed to enable scripting 8 | software written in Common Lisp with JavaScript. It is developed by 9 | Alan Pavičić, Marijn Haverbeke (also the author of [parse-js 10 | library][parse]) and Iva Jurišić. 11 | 12 | CL-JavaScript is licensed under MIT public license. 13 | 14 | [home]: http://marijnhaverbeke.nl/cl-javascript 15 | [parse]: http://marijnhaverbeke.nl/parse-js/ 16 | -------------------------------------------------------------------------------- /cl-js.asd: -------------------------------------------------------------------------------- 1 | (when (asdf:find-system :local-time nil) (pushnew :js-dates *features*)) 2 | 3 | (asdf:defsystem :cl-js 4 | :description "JavaScript-to-CL compiler and runtime" 5 | :author "Marijn Haverbeke " 6 | :license "MIT" 7 | :depends-on (:parse-js :cl-ppcre #+js-dates :local-time) 8 | :serial t 9 | :components 10 | ((:file "package") 11 | (:file "utils") 12 | (:file "js") 13 | (:file "jsos") 14 | (:file "url-encode") 15 | (:file "json") 16 | (:file "deflib") 17 | (:file "runtime") 18 | (:file "infer") 19 | (:file "inline-op") 20 | (:file "translate") 21 | (:file "operators") 22 | (:file "api"))) 23 | -------------------------------------------------------------------------------- /bench.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-js) 2 | 3 | (defun ray () 4 | (with-js-env (*printlib*) 5 | (run-js-file (asdf:system-relative-pathname :cl-js "bench/ray.js")) 6 | (time (wrap-js (js-funcall (js-prop *env* "renderScene")))))) 7 | 8 | (defun slurp-file (file) 9 | (with-open-file (in file) 10 | (apply #'concatenate 'string 11 | (loop :for buf := (make-string 4096) :for chars := (read-sequence buf in) 12 | :if (< chars 4096) :collect (subseq buf 0 chars) :into all :and :do (return all) 13 | :else :collect buf :into all)))) 14 | 15 | (defun codemirror () 16 | (with-js-env (*printlib*) 17 | (let ((file (asdf:system-relative-pathname :cl-js "bench/codemirror.js"))) 18 | (run-js-file file) 19 | (let ((code (slurp-file file))) 20 | (time (wrap-js (js-funcall (js-prop *env* "codemirrorBench") code))))))) 21 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :cl-js 2 | (:use :cl :parse-js) 3 | (:export #:run-js-file #:run-js #:js-repl 4 | #:*env* #:with-js-env #:create-env #:add-to-env 5 | #:*enable-Function.caller* 6 | 7 | #:*printlib* #:requirelib 8 | 9 | #:empty-lib #:add-to-lib #:.prototype #:.constructor 10 | #:.object #:.value #:.func #:.active #:.active-r 11 | #:integrate-type #:define-js-obj 12 | 13 | #:to-number #:to-string #:to-integer #:to-boolean 14 | #:this 15 | #:js-error #:js-condition #:js-condition-value 16 | 17 | #:void #:js-null #:js-number #:js-special-number 18 | #:js-func #:js-call #:js-method 19 | #:js-array #:js-array-length #:js-aref #:js-array-vec 20 | #:js-obj #:js-prop #:js-for-in #:delete-prop 21 | 22 | #:nan #:infinity #:-infinity #:is-nan)) 23 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2010 Alan Pavičić, Marijn Haverbeke and Iva Jurišić 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /js.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-js) 2 | 3 | ;; Float special values 4 | 5 | #+sbcl 6 | (progn 7 | (defmacro without-traps (&body body) 8 | `(sb-int:with-float-traps-masked (:overflow :invalid :divide-by-zero) ,@body)) 9 | (defun make-nan-helper (x) ;; It's not so easy to get a NaN value on SBCL 10 | (sb-int:with-float-traps-masked (:overflow :invalid :divide-by-zero) 11 | (- x sb-ext:double-float-positive-infinity))) 12 | (defparameter *nan* (make-nan-helper sb-ext:double-float-positive-infinity))) 13 | 14 | (defparameter *float-traps* 15 | #+(or allegro sbcl) nil 16 | #-(or allegro sbcl) t) 17 | 18 | (defmacro wrap-js (&body body) 19 | #+sbcl 20 | `(sb-int:with-float-traps-masked (:overflow :invalid :divide-by-zero) 21 | ,@body) 22 | #-sbcl `(progn ,@body)) 23 | 24 | (defmacro infinity () 25 | #+allegro #.excl:*infinity-double* 26 | #+sbcl sb-ext:double-float-positive-infinity 27 | #-(or allegro sbcl) :Inf) 28 | (defmacro -infinity () 29 | #+allegro #.excl:*negative-infinity-double* 30 | #+sbcl sb-ext:double-float-negative-infinity 31 | #-(or allegro sbcl) :-Inf) 32 | (defmacro nan () 33 | #+allegro #.excl:*nan-double* 34 | #+sbcl '*nan* 35 | #-(or allegro sbcl) :NaN) 36 | (defmacro is-nan (val) 37 | #+allegro `(and (excl::nan-p ,val) t) 38 | #+sbcl (let ((name (gensym))) 39 | `(let ((,name ,val)) 40 | (and (floatp ,name) (sb-ext:float-nan-p ,name)))) 41 | #-(or allegro sbcl) `(eq ,val :NaN)) 42 | 43 | ;; Intended for from-lisp use 44 | (defun js-funcall (func &rest args) 45 | (wrap-js 46 | (apply (the function (proc func)) nil args))) 47 | 48 | ;; Indented for use inside of JS code 49 | (defmacro js-call (func this &rest args) 50 | `(funcall (the function (proc ,func)) ,this ,@args)) 51 | (defmacro js-method (obj name &rest args) 52 | (let ((o (gensym))) 53 | `(let ((,o ,obj)) 54 | (js-call ,(expand-cached-lookup o name) ,o ,@args)))) 55 | 56 | (defun wrap-js-lambda (args body) 57 | (let ((other nil)) 58 | (labels ((add-default (args) 59 | (cond ((not args) (setf other t) '(&rest other-args)) 60 | ((eq (car args) '&rest) args) 61 | ((symbolp (car args)) 62 | (cons (list (car args) :undefined) (add-default (cdr args)))) 63 | (t (cons (car args) (add-default (cdr args))))))) 64 | (setf args (add-default args)) 65 | (unless (eq (car args) '&rest) (push '&optional args))) 66 | `(lambda (this ,@args) 67 | (declare (ignorable this ,@(and other '(other-args)))) 68 | ,@body))) 69 | (defmacro js-lambda (args &body body) 70 | (wrap-js-lambda args body)) 71 | 72 | (defun compile-eval (code) 73 | (funcall (compile nil `(lambda () (with-ignored-style-warnings ,code))))) 74 | 75 | ;; Conditions 76 | 77 | (define-condition js-condition (error) 78 | ((value :initarg :value :reader js-condition-value)) 79 | (:report (lambda (e stream) 80 | (format stream "[js] ~a" (to-string (js-condition-value e)))))) 81 | 82 | (defun parse (input) 83 | (parse-js input :ecma-version 5)) 84 | 85 | (defun parse/err (string) 86 | (handler-case (parse string) 87 | (js-parse-error (e) 88 | (js-error :syntax-error (princ-to-string e))))) 89 | -------------------------------------------------------------------------------- /inline-op.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-js) 2 | 3 | (defgeneric expand-op (op lht rht lhs rhs) 4 | (:method (op lht rht lhs rhs) 5 | (declare (ignore op lht rht lhs rhs)) 6 | nil)) 7 | 8 | (defmacro defexpand (op (lht rht) &body body) 9 | (flet ((spec (type) 10 | (if (eq type t) t `(eql ,type)))) 11 | `(defmethod expand-op ((,(gensym) (eql ,op)) (lht ,(spec lht)) 12 | (rht ,(spec rht)) lhs rhs) 13 | (declare (ignorable lhs rhs)) 14 | ,@body))) 15 | 16 | (defun expand (op lht rht lhs rhs) 17 | (let ((result (expand-op op lht rht lhs rhs))) 18 | (when (and (not result) (eq lht :integer)) 19 | (setf result (expand-op op :number rht lhs rhs))) 20 | (when (and (not result) (eq rht :integer)) 21 | (setf result (expand-op op (if (eq lht :integer) :number lht) :number lhs rhs))) 22 | result)) 23 | 24 | (defun to-boolean-typed (expr type) 25 | (case type 26 | (:boolean expr) 27 | ((:undefined :null) `(progn ,expr nil)) 28 | (:object `(progn ,expr t)) 29 | (:integer `(not (= ,expr 0))) 30 | (:number (let ((tmp (gensym))) `(let ((,tmp ,expr)) (not (or (= ,tmp 0) (is-nan ,tmp)))))) 31 | (t `(to-boolean ,expr)))) 32 | 33 | (defmacro defnumop (op expansion) 34 | `(progn (defexpand ,op (:integer :integer) ,expansion) 35 | (defexpand ,op (:number :number) (unless *float-traps* ,expansion)))) 36 | 37 | ;; (string + string is handled specially in the :binary translate rule) 38 | (defnumop :+ `(+ ,lhs ,rhs)) 39 | (defexpand :+ (nil :number) rhs) 40 | (defexpand :+ (t :number) 41 | (unless *float-traps* 42 | (let ((lh (gensym)) (rh (gensym))) 43 | `(let ((,lh ,lhs) (,rh ,rhs)) 44 | (typecase ,lh 45 | (fixnum (+ (the fixnum ,lh) ,rh)) 46 | (double-float (+ (the double-float ,lh) ,rh)) 47 | (t (js+ ,lh ,rh))))))) 48 | (defexpand :+ (:number t) 49 | (unless *float-traps* 50 | (let ((lh (gensym)) (rh (gensym))) 51 | `(let ((,lh ,lhs) (,rh ,rhs)) 52 | (typecase ,rh 53 | (fixnum (+ ,lh (the fixnum ,rh))) 54 | (double-float (+ ,lh (the double-float ,rh))) 55 | (t (js+ ,lh ,rh))))))) 56 | 57 | (defnumop :- `(- ,lhs ,rhs)) 58 | (defexpand :- (nil t) 59 | (let ((val (gensym))) 60 | `(let ((,val (to-number ,rhs))) 61 | (if (zerop ,val) (- 0d0) (js- 0 ,val))))) 62 | 63 | (defnumop :* `(* ,lhs ,rhs)) 64 | (defnumop :% `(rem ,lhs ,rhs)) 65 | 66 | (defnumop :< `(< ,lhs ,rhs)) 67 | (defnumop :> `(> ,lhs ,rhs)) 68 | (defnumop :<= `(<= ,lhs ,rhs)) 69 | (defnumop :>= `(>= ,lhs ,rhs)) 70 | (defexpand :== (:integer :integer) `(= ,lhs ,rhs)) 71 | (defnumop :!= `(/= ,lhs ,rhs)) 72 | (defnumop :=== `(= ,lhs ,rhs)) 73 | (defnumop :!== `(/= ,lhs ,rhs)) 74 | 75 | (defexpand :& (:integer :integer) `(logand (trunc32 ,lhs) (trunc32 ,rhs))) 76 | (defexpand :|\|| (:integer :integer) `(logior (trunc32 ,lhs) (trunc32 ,rhs))) 77 | (defexpand :^ (:integer :integer) `(logxor (trunc32 ,lhs) (trunc32 ,rhs))) 78 | (defexpand :~ (nil :integer) `(lognot (trunc32 ,rhs))) 79 | (defexpand :>> (:integer :integer) `(ash (trunc32 ,lhs) (- ,rhs))) 80 | (defexpand :<< (:integer :integer) `(ash (trunc32 ,lhs) ,rhs)) 81 | (defexpand :>>> (:integer :integer) `(bitshift32 (trunc32 ,lhs) (- ,rhs))) 82 | 83 | (defexpand :&& (t t) 84 | (let ((temp (gensym))) 85 | `(let ((,temp ,lhs)) 86 | (if ,(to-boolean-typed temp lht) ,rhs ,temp)))) 87 | (defexpand :|\|\|| (t t) 88 | (let ((temp (gensym))) 89 | `(let ((,temp ,lhs)) 90 | (if ,(to-boolean-typed temp lht) ,temp ,rhs)))) 91 | (defexpand :! (t t) `(not ,(to-boolean-typed rhs rht))) 92 | 93 | (defexpand :void (t t) 94 | `(progn ,rhs :undefined)) 95 | -------------------------------------------------------------------------------- /api.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-js) 2 | 3 | (defmacro void (&body body) 4 | `(progn ,@body :undefined)) 5 | 6 | (defun reset () 7 | (setf *env* (create-env *printlib*))) 8 | 9 | (defvar *enable-Function.caller* nil 10 | "If T, enables support for arguments.callee.caller/Function.caller property in newly compiled JavaScript code") 11 | 12 | (defun run-js (str &key (compile t) (wrap-parse-errors nil) (optimize nil) (wrap-as-module nil)) 13 | (unless (boundp '*env*) (reset)) 14 | (let* ((ast (handler-bind ((js-parse-error 15 | (lambda (e) (when wrap-parse-errors 16 | (js-error :syntax-error (princ-to-string e)))))) 17 | (parse str))) 18 | (ast (if wrap-as-module 19 | `(:function nil ("exports") (,@(second ast) (:return (:name "exports")))) 20 | ast)) 21 | (form `(wrap-js ,(translate-ast ast))) 22 | (form (if optimize `(locally (declare (optimize speed (safety 0))) ,form) form))) 23 | (if compile 24 | (compile-eval form) 25 | (eval form)))) 26 | 27 | (defun run-js-file (file &key (compile t) (wrap-parse-errors nil) (optimize nil) (wrap-as-module nil) 28 | (external-format :default)) 29 | (with-open-file (in file :external-format external-format) 30 | (run-js in :compile compile :wrap-parse-errors wrap-parse-errors :optimize optimize 31 | :wrap-as-module wrap-as-module))) 32 | 33 | (defun js-repl (&key (handle-errors t)) 34 | (unless (boundp '*env*) (reset)) 35 | (format t "~%JS repl (#q to quit)~%> ") 36 | (let ((accum "") continue) 37 | (flet ((handle-js-condition (e) 38 | (let ((str (to-string (js-condition-value e)))) 39 | (cond ((and (> (length str) 35) (equal (subseq str 0 35) "SyntaxError: Unexpected token 'EOF'")) 40 | (setf continue t) (throw 'err nil)) 41 | (handle-errors 42 | (format t "! ~a~%" (to-string (js-condition-value e))) (throw 'err nil))))) 43 | (handle-error (e) 44 | (when (eq handle-errors t) 45 | (format t "!! ~a~%" e) 46 | (throw 'err nil)))) 47 | (loop :for line := (read-line) :do 48 | (when (equal line "#q") (return)) 49 | (if continue 50 | (setf line (setf accum (concatenate 'string accum '(#\newline) line)) 51 | continue nil) 52 | (setf accum line)) 53 | (catch 'err 54 | (handler-bind ((js-condition #'handle-js-condition) 55 | (error #'handle-error)) 56 | (let ((result (compile-eval (translate-ast (parse/err line))))) 57 | (unless (eq result :undefined) 58 | (format t "~a~%" (to-string result)))))) 59 | (format t (if continue " " "> ")))))) 60 | 61 | (defun tests () 62 | (let ((*enable-function.caller* t)) 63 | (with-js-env (*printlib*) 64 | (run-js-file (asdf:system-relative-pathname :cl-js "test.js"))))) 65 | 66 | (defun js-obj (&optional proto struct-type) 67 | (let ((cls (etypecase proto 68 | (keyword (find-cls proto)) 69 | (js-obj (make-scls nil proto)) 70 | (null (find-cls :object))))) 71 | (if struct-type 72 | (funcall (default-constructor-name struct-type) cls) 73 | (make-obj cls)))) 74 | 75 | (defun js-array (vec) 76 | (assert (and (vectorp vec) (adjustable-array-p vec))) 77 | (build-array vec)) 78 | 79 | (deftype js-obj () 'obj) 80 | (deftype js-func () 'fobj) 81 | (deftype js-array () 'aobj) 82 | 83 | (defun js-array-length (x) (length (aobj-arr x))) 84 | (defun js-aref (x index) (aref (aobj-arr x) index)) 85 | (defun (setf js-aref) (val x index) 86 | (setf (aref (aobj-arr x) index) val)) 87 | (defun js-array-vec (x) (aobj-arr x)) 88 | 89 | (defun js-null (x) 90 | (or (eq x :null) (eq x :undefined))) 91 | 92 | (deftype js-null () '(or (eql :null) (eql :undefined))) 93 | 94 | (defmacro js-func ((&rest args) &body body) 95 | `(build-func (js-lambda ,args ,@body) ,(arg-count args))) 96 | 97 | (defun js-special-number (x) 98 | (or (is-nan x) (eq x (infinity)) (eq x (-infinity)))) 99 | -------------------------------------------------------------------------------- /url-encode.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :url-encode 2 | (:use :cl) 3 | (:export #:url-decode #:url-encode #:url-error)) 4 | 5 | (in-package :url-encode) 6 | 7 | (define-condition url-error (simple-error) ()) 8 | (defun url-error (format &rest args) 9 | (error 'url-error :format-control format :format-arguments args)) 10 | 11 | (defun char-utf-8-byte-length (char) 12 | (let ((code (char-code char))) 13 | (cond ((< code 128) 1) 14 | ((< code 2048) 2) 15 | ((< code 65536) 3) 16 | (t 4)))) 17 | 18 | (defmacro as-utf-8-bytes (char writer) 19 | "Given a character, calls the writer function for every byte in the 20 | encoded form of that character." 21 | (let ((char-code (gensym))) 22 | `(let ((,char-code (char-code ,char))) 23 | (declare (type fixnum ,char-code)) 24 | (cond ((< ,char-code 128) 25 | (,writer ,char-code)) 26 | ((< ,char-code 2048) 27 | (,writer (logior #b11000000 (ldb (byte 5 6) ,char-code))) 28 | (,writer (logior #b10000000 (ldb (byte 6 0) ,char-code)))) 29 | ((< ,char-code 65536) 30 | (,writer (logior #b11100000 (ldb (byte 4 12) ,char-code))) 31 | (,writer (logior #b10000000 (ldb (byte 6 6) ,char-code))) 32 | (,writer (logior #b10000000 (ldb (byte 6 0) ,char-code)))) 33 | (t 34 | (,writer (logior #b11110000 (ldb (byte 3 18) ,char-code))) 35 | (,writer (logior #b10000000 (ldb (byte 6 12) ,char-code))) 36 | (,writer (logior #b10000000 (ldb (byte 6 6) ,char-code))) 37 | (,writer (logior #b10000000 (ldb (byte 6 0) ,char-code)))))))) 38 | 39 | (defun url-encode (string &optional (to-escape "\"#$%&+,/:;<=>?@")) 40 | (declare (optimize speed (safety 0))) 41 | (let ((size (loop :for ch :across string :for code := (char-code ch) :sum 42 | (cond ((> code 127) (* (char-utf-8-byte-length ch) 3)) 43 | ((or (< code 33) (find ch to-escape)) 3) 44 | (t 1))))) 45 | (if (= size (length string)) 46 | string 47 | (let ((out (make-string size)) (pos 0)) 48 | (macrolet ((wr (ch) `(progn (setf (schar out pos) ,ch) (incf pos)))) 49 | (flet ((code-out (ch) 50 | (multiple-value-bind (hi lo) (floor ch 16) 51 | (wr #\%) (wr (digit-char hi 16)) (wr (digit-char lo 16))))) 52 | (loop :for ch :across string :for code := (char-code ch) :do 53 | (cond ((> code 127) (as-utf-8-bytes ch code-out)) 54 | ((or (< code 33) (find ch to-escape)) (code-out code)) 55 | (t (wr ch)))))) 56 | out)))) 57 | 58 | (defun utf-8-group-size (byte) 59 | "Determine the amount of bytes that are part of the character 60 | starting with a given byte." 61 | (declare (type fixnum byte)) 62 | (cond ((zerop (logand byte #b10000000)) 1) 63 | ((= (logand byte #b11100000) #b11000000) 2) 64 | ((= (logand byte #b11110000) #b11100000) 3) 65 | ((= (logand byte #b11111000) #b11110000) 4) 66 | (t (url-error "Invalid UTF-8 byte: 0x~X" byte)))) 67 | 68 | (defun get-utf-8-character (bytes group-size &aux (start 0)) 69 | "Given an array of bytes and the amount of bytes to use, 70 | extract the character they denote." 71 | (declare (type (simple-array (unsigned-byte 8) (*)) bytes) 72 | (type fixnum group-size)) 73 | (macrolet ((next-byte () 74 | '(prog1 (elt bytes start) 75 | (incf start))) 76 | (six-bits (byte) 77 | (let ((b (gensym))) 78 | `(let ((,b ,byte)) 79 | (unless (= (logand ,b #b11000000) #b10000000) 80 | (url-error "Invalid byte 0x~X inside a character." ,b)) 81 | (ldb (byte 6 0) ,b)))) 82 | (test-overlong (byte min-size) 83 | (let ((b (gensym))) 84 | `(let ((,b ,byte)) 85 | (unless (> ,b ,min-size) 86 | (url-error "Overlong UTF-8 byte sequence found.")) 87 | ,b)))) 88 | (ecase group-size 89 | (1 (next-byte)) 90 | (2 (test-overlong (logior (ash (ldb (byte 5 0) (next-byte)) 6) 91 | (six-bits (next-byte))) 128)) 92 | (3 (test-overlong (logior (ash (ldb (byte 4 0) (next-byte)) 12) 93 | (ash (six-bits (next-byte)) 6) 94 | (six-bits (next-byte))) 2048)) 95 | (4 (test-overlong (logior (ash (ldb (byte 3 0) (next-byte)) 18) 96 | (ash (six-bits (next-byte)) 12) 97 | (ash (six-bits (next-byte)) 6) 98 | (six-bits (next-byte))) 65536))))) 99 | 100 | (defun url-decode (string &optional (leave "")) 101 | (declare (optimize speed (safety 0))) 102 | (let ((buf (make-string (length string))) 103 | (pos 0) 104 | (utf-buf (make-array 4 :element-type '(unsigned-byte 8)))) 105 | (declare (fixnum pos) (simple-string buf)) 106 | (with-input-from-string (in string) 107 | (loop :for ch := (read-char in nil nil) :while ch :do 108 | (macrolet ((hex () 109 | '(let ((big (digit-char-p (read-char in nil #\x) 16)) 110 | (small (digit-char-p (read-char in nil #\x) 16))) 111 | (unless (and big small) (url-error "Junk in URL.")) 112 | (+ small (ash big 4)))) 113 | (out (x) `(progn (setf (schar buf pos) ,x) (incf pos)))) 114 | (case ch 115 | (#\+ (out #\space)) 116 | (#\% (let* ((code (hex)) 117 | (group (utf-8-group-size code))) 118 | (cond ((and (eql group 1) (find (code-char code) leave)) 119 | (multiple-value-bind (hi lo) (floor code 16) 120 | (out #\%) (out (digit-char hi 16)) (out (digit-char lo 16)))) 121 | (t (setf (aref utf-buf 0) code) 122 | (loop :for i :from 1 :below group :do 123 | (unless (eql (read-char in nil nil) #\%) 124 | (url-error "Nonsense UTF-8 code in URL.")) 125 | (setf (aref utf-buf i) (hex))) 126 | (out (code-char (get-utf-8-character utf-buf group))))))) 127 | (t (out ch)))) 128 | :finally (return (if (eql pos (length buf)) buf (subseq buf 0 pos))))))) 129 | -------------------------------------------------------------------------------- /operators.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-js) 2 | 3 | (defmacro complicated-numeric-op (ls rs op nan 4 | inf-inf inf-minf minf-inf minf-minf 5 | num-inf num-minf inf-num minf-num) 6 | `(let ((ls ,ls) (rs ,rs)) 7 | ,(if *float-traps* 8 | `(cond 9 | ((and (numberp ls) (numberp rs)) (,op ls rs)) 10 | ((or (is-nan ls) (is-nan rs)) ,nan) 11 | ((and (eq ls ,(infinity)) (eq rs ,(infinity))) ,inf-inf) 12 | ((and (eq ls ,(infinity)) (eq rs ,(-infinity))) ,inf-minf) 13 | ((and (eq ls ,(-infinity)) (eq rs ,(infinity))) ,minf-inf) 14 | ((and (eq ls ,(-infinity)) (eq rs ,(-infinity))) ,minf-minf) 15 | ((eq rs ,(infinity)) ,num-inf) 16 | ((eq rs ,(-infinity)) ,num-minf) 17 | ((eq ls ,(infinity)) ,inf-num) 18 | ((eq ls ,(-infinity)) ,minf-num)) 19 | `(,op ls rs)))) 20 | 21 | (defun js+ (ls rs) 22 | (cond ((and (numberp ls) (numberp rs)) (+ ls rs)) 23 | ((and (stringp ls) (stringp rs)) (concatenate 'string ls rs)) 24 | (t (let ((ls (default-value ls)) (rs (default-value rs))) 25 | (cond ((stringp ls) (concatenate 'string ls (to-string rs))) 26 | ((stringp rs) (concatenate 'string (to-string ls) rs)) 27 | ((and (numberp ls) (numberp rs)) (+ ls rs)) 28 | (t (complicated-numeric-op 29 | (to-number ls) (to-number rs) + (nan) 30 | (infinity) (nan) (nan) (-infinity) (infinity) 31 | (-infinity) (infinity) (-infinity)))))))) 32 | 33 | (defun js++ (arg) 34 | (js+ (to-number arg) 1)) 35 | 36 | (defmacro maybe-complicated-numeric-op (ls rs op &rest specs) 37 | `(let ((ls ,ls) (rs ,rs)) 38 | (if (and (numberp ls) (numberp rs)) 39 | (,op ls rs) 40 | (complicated-numeric-op (to-number ls) (to-number rs) ,op ,@specs)))) 41 | 42 | (defun js- (ls rs) 43 | (maybe-complicated-numeric-op 44 | ls rs - (nan) 45 | (nan) (infinity) (-infinity) (nan) (-infinity) 46 | (infinity) (infinity) (-infinity))) 47 | 48 | (defun js-- (arg) 49 | (js- (to-number arg) 1)) 50 | 51 | (defun js* (ls rs) 52 | (maybe-complicated-numeric-op 53 | ls rs * (nan) 54 | (infinity) (-infinity) (-infinity) (infinity) (infinity) 55 | (-infinity) (infinity) (-infinity))) 56 | 57 | (defun sign-of (val) 58 | (cond ((eq val (-infinity)) nil) 59 | ((eq val (infinity)) t) 60 | ((is-nan val) t) 61 | ((integerp val) (>= val 0)) 62 | (t (float-sign val)))) ;; Doesn't work for -0 on all implementations (SBCL works, ACL doesn't) 63 | 64 | (defun js/ (ls rs) 65 | (let ((ls (to-number ls)) (rs (to-number rs))) 66 | (if (zerop rs) 67 | (if (eq (sign-of ls) (sign-of rs)) (infinity) (-infinity)) 68 | (complicated-numeric-op 69 | ls rs / (nan) 70 | (nan) (nan) (nan) (nan) 0 0 (infinity) (-infinity))))) 71 | 72 | (defun js% (ls rs) 73 | (let ((ls (to-number ls)) (rs (to-number rs))) 74 | (if (zerop rs) 75 | (nan) 76 | (complicated-numeric-op 77 | ls rs rem (nan) 78 | (nan) (nan) (nan) (nan) ls ls (nan) (nan))))) 79 | 80 | (defun js^ (ls rs) 81 | (logxor (to-int32 ls) (to-int32 rs))) 82 | (defun js\| (ls rs) 83 | (logior (to-int32 ls) (to-int32 rs))) 84 | (defun js& (ls rs) 85 | (logand (to-int32 ls) (to-int32 rs))) 86 | (defun js~ (rs) 87 | (lognot (to-int32 rs))) 88 | 89 | (defun js>> (a b) 90 | (ash (to-int32 a) (- (to-int32 b)))) 91 | (defun js<< (a b) 92 | (ash (to-int32 a) (to-int32 b))) 93 | (defun js>>> (a b) 94 | (bitshift32 (to-int32 a) (to-int32 b))) 95 | 96 | (defun bitshift32 (a b) 97 | (if (< a 0) 98 | (ash (ldb (byte 32 0) a) (- b)) 99 | (ash a (- b)))) 100 | 101 | (defun js=== (ls rs) 102 | (cond ((is-nan ls) nil) 103 | ((eq ls rs) t) 104 | ((stringp ls) (and (stringp rs) (string= ls rs))) 105 | ((numberp ls) (and (numberp rs) (= ls rs))))) 106 | 107 | (defun js!== (ls rs) 108 | (not (js=== ls rs))) 109 | 110 | ;; 111 | (defun js== (ls rs) 112 | (cond ((is-nan ls) nil) 113 | ((eq ls rs) t) 114 | ((eq ls :null) (eq rs :undefined)) 115 | ((eq ls :undefined) (eq rs :null)) 116 | ((eq rs :null) (eq ls :undefined)) 117 | ((eq rs :undefined) (eq ls :null)) 118 | ((numberp ls) (let ((rsn (to-number rs))) 119 | (and (not (is-nan rsn)) (= ls rsn)))) 120 | ((stringp ls) (string= ls (to-string rs))) 121 | ((or (eq ls t) (eq ls nil)) (js== (if ls 1 0) rs)) 122 | ((or (eq rs t) (eq rs nil)) (js== ls (if rs 1 0))) 123 | ((obj-p ls) (cond ((stringp rs) (js== (default-value ls) rs)) 124 | ((typep rs 'js-number) (js== (default-value ls :number) rs)))))) 125 | 126 | (defun js!= (ls rs) 127 | (not (js== ls rs))) 128 | 129 | 130 | (defmacro complicated-comparision-op (ls rs op &rest specs) 131 | (let ((str-op (intern (format nil "~a~a" :string op)))) 132 | `(let ((ls (default-value ,ls)) (rs (default-value ,rs))) 133 | (if (and (stringp ls) (stringp rs)) 134 | (,str-op ls rs) 135 | (let ((ls (to-number ls)) (rs (to-number rs))) 136 | ,(let ((compl `(complicated-numeric-op (to-number ls) (to-number rs) ,op nil ,@specs))) 137 | (if *float-traps* 138 | compl 139 | `(unless (or (is-nan ls) (is-nan rs)) ,compl)))))))) 140 | 141 | (defun js< (ls rs) 142 | (complicated-comparision-op ls rs < nil nil t nil t nil nil t)) 143 | (defun js> (ls rs) 144 | (complicated-comparision-op ls rs > nil nil t nil t nil nil t)) 145 | (defun js<= (ls rs) 146 | (complicated-comparision-op ls rs <= t t nil t nil t t nil)) 147 | (defun js>= (ls rs) 148 | (complicated-comparision-op ls rs >= t t nil t nil t t nil)) 149 | 150 | (defun jsinstanceof (ls rs) 151 | (and (obj-p ls) (fobj-p rs) 152 | (let ((proto (js-prop rs "prototype"))) 153 | (loop :for cur := ls :then (cls-prototype (obj-cls cur)) :while cur :do 154 | (when (eq cur proto) (return t)))))) 155 | 156 | (defun jsin (prop obj) 157 | (if-not-found (nil (js-prop obj prop)) nil t)) 158 | 159 | (defgeneric js-type-of (expr) 160 | (:method ((expr string)) "string") 161 | (:method ((expr number)) "number") 162 | (:method ((expr symbol)) 163 | (ecase expr ((t nil) "boolean") (:undefined "undefined") (:null "object") 164 | ((:NaN :Inf :-Inf) "number"))) 165 | (:method ((expr fobj)) "function") 166 | (:method ((expr obj)) "object") 167 | (:method (expr) (error "No type-of defined for value ~a" expr))) 168 | -------------------------------------------------------------------------------- /json.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-js) 2 | 3 | (defvar *reading-slot-name* nil) 4 | 5 | (defun is-whitespace (char) 6 | (position char #.(concatenate '(vector character) 7 | (list #\space #\tab #.(code-char 11) #\page #\return #\newline 8 | (code-char #xa0) (code-char #x2028) (code-char #x2029))))) 9 | 10 | (defun ends-atom (char) 11 | (or (is-whitespace char) (member char '(#\) #\] #\} #\, #\:)))) 12 | 13 | (defun skip-whitespace (stream) 14 | (loop :while (is-whitespace (peek-char nil stream nil)) 15 | :do (read-char stream))) 16 | 17 | (defun at-eof (stream) 18 | (eql (peek-char nil stream nil :eof) :eof)) 19 | 20 | (defun json-error (message &rest args) 21 | (apply 'js-error :syntax-error message args)) 22 | 23 | (defun parse-json (string) 24 | (with-input-from-string (in string) 25 | (let ((value (read-json in))) 26 | (skip-whitespace in) 27 | (unless (at-eof in) 28 | (json-error "Unused characters at end of input.")) 29 | value))) 30 | 31 | (defun read-json (stream) 32 | (skip-whitespace stream) 33 | (case (peek-char nil stream nil :eof) 34 | (:eof (json-error "Unexpected end of input.")) 35 | ((#\" #\') (read-json-string stream)) 36 | (#\[ (read-json-array stream)) 37 | (#\{ (read-json-object stream)) 38 | (t (read-json-atom stream)))) 39 | 40 | (defun read-json-string (stream) 41 | (labels ((interpret (char) 42 | (if (eql char #\\) 43 | (let ((escaped (read-char stream))) 44 | (case escaped 45 | (#\u (read-unicode)) 46 | (#\b #\backspace) (#\n #\newline) (#\r #\return) 47 | (#\t #\tab) (#\f #\page) (t escaped))) 48 | char)) 49 | (read-unicode () 50 | (code-char (loop :for pos :from 0 :below 4 51 | :for weight :of-type fixnum := #.(expt 16 3) :then (ash weight -4) 52 | :for digit := (digit-char-p (read-char stream) 16) 53 | :do (unless digit (json-error "Invalid unicode constant in string.")) 54 | :sum (* digit weight))))) 55 | (with-output-to-string (out) 56 | (handler-case 57 | (loop :with quote :of-type character := (read-char stream) 58 | :for next :of-type character := (read-char stream) 59 | :until (eql next quote) 60 | :do (write-char (interpret next) out)) 61 | (end-of-file () (json-error "Encountered end of input inside string constant.")))))) 62 | 63 | (defun gather-comma-separated (stream end-char obj-name gather-func) 64 | (declare (type character end-char) 65 | (type function gather-func)) 66 | ;; Throw away opening char 67 | (read-char stream) 68 | (let ((finished nil)) 69 | (loop 70 | (skip-whitespace stream) 71 | (let ((next (peek-char nil stream nil #\null))) 72 | (declare (type character next)) 73 | (when (eql next #\null) 74 | (json-error "Encountered end of input inside ~A." obj-name)) 75 | (when (eql next end-char) 76 | (read-char stream) 77 | (return)) 78 | (when finished 79 | (json-error "Comma or end of ~A expected, found '~A'" obj-name next))) 80 | (funcall gather-func) 81 | (skip-whitespace stream) 82 | (if (eql (peek-char nil stream nil) #\,) 83 | (read-char stream) 84 | (setf finished t))))) 85 | 86 | (defun read-json-array (stream) 87 | (let ((accum (empty-fvector 20 0))) 88 | (gather-comma-separated 89 | stream #\] "list" 90 | (lambda () 91 | (vector-push-extend (read-json stream) accum))) 92 | (build-array accum))) 93 | 94 | (defun read-json-object (stream) 95 | (let ((obj (js-obj))) 96 | (gather-comma-separated 97 | stream #\} "object literal" 98 | (lambda () 99 | (let ((slot-name (let ((*reading-slot-name* t)) (read-json stream)))) 100 | (unless (or (typep slot-name 'string) (typep slot-name 'number)) 101 | (json-error "Invalid slot name in object literal: ~A" slot-name)) 102 | (skip-whitespace stream) 103 | (when (not (eql (read-char stream nil) #\:)) 104 | (json-error "Colon expected after '~a'." slot-name)) 105 | (setf (js-prop obj slot-name) (read-json stream))))) 106 | obj)) 107 | 108 | (defun looks-like-a-number (string) 109 | (let ((string (coerce string 'simple-string))) 110 | (every (lambda (char) 111 | (or (digit-char-p char) 112 | (member char '(#\e #\E #\. #\- #\+)))) 113 | string))) 114 | 115 | (defun read-json-atom (stream) 116 | (let ((accum (make-array 0 :element-type 'character :fill-pointer 0 :adjustable t))) 117 | (loop 118 | (let ((next (peek-char nil stream nil :eof))) 119 | (when (or (ends-atom next) (eql next :eof)) 120 | (return)) 121 | (vector-push-extend next accum) 122 | (read-char stream))) 123 | (let ((number-val (and (looks-like-a-number accum) 124 | (ignore-errors (read-from-string accum))))) 125 | (cond ((numberp number-val) number-val) 126 | ((string= accum "false") nil) 127 | ((string= accum "true") t) 128 | ((string= accum "null") :null) 129 | ((string= accum "undefined") :null) 130 | ((and *reading-slot-name* 131 | (every (lambda (c) 132 | (declare (type character c)) 133 | (or (alphanumericp c) (eql c #\_) (eql c #\$))) 134 | accum)) 135 | accum) 136 | (t (json-error "Unrecognized value in JSON data: ~A" accum)))))) 137 | 138 | (defvar *replacer*) 139 | 140 | (defun process-replacer (repl) 141 | (typecase repl 142 | (js-func (lambda (key val) 143 | (let ((result (js-call repl *env* key val))) 144 | (values result (not (eq result :undefined)))))) 145 | (js-array (let ((vec (js-array-vec repl))) 146 | (lambda (key val) 147 | (values val 148 | (loop :for elt :across vec :do (when (js== elt key) (return t))))))) 149 | (js-null (lambda (key val) (declare (ignore key)) (values val t))) 150 | (t (js-error :range-error "The second argument to JSON.stringify should be either a function or an array.")))) 151 | 152 | (defun stringify-json (value replacer) 153 | (let ((*replacer* (process-replacer replacer))) 154 | (with-output-to-string (out) 155 | (write-json value out)))) 156 | 157 | (defun write-json (element stream) 158 | (typecase element 159 | (aobj (write-json-array element stream)) 160 | (obj (write-json-obj element stream)) 161 | (string (write-json-string element stream)) 162 | (js-number (write-json-number element stream)) 163 | (boolean (write-string (if element "true" "false") stream)) 164 | (js-null (write-string "null" stream)) 165 | (t (write-json-string (to-string element) stream)))) 166 | 167 | (defun write-json-string (string stream) 168 | (declare (stream stream)) 169 | (let ((string (coerce string 'simple-string))) 170 | (write-char #\" stream) 171 | (loop :for ch :of-type character :across string :do 172 | (let ((code (char-code ch))) 173 | (declare (fixnum code)) 174 | (cond ((< code 14) (princ (case ch (#\backspace "\\b") (#\newline "\\n") (#\return "\\r") 175 | (#\page "\\f") (#\tab "\\t") (t ch)) stream)) 176 | ((eq code 92) (write-string "\\\\" stream)) 177 | ((eq code 34) (write-string "\\\"" stream)) 178 | (t (write-char ch stream)))))) 179 | (write-char #\" stream)) 180 | 181 | (defun write-json-number (number stream) 182 | (typecase number 183 | (integer (write number :stream stream)) 184 | (double-float (format stream "~,,,,,,'eE" number)) 185 | (t (write-string (ecase number (:NaN "NaN") (:Inf "Infinity") (:-Inf "-Infinity")) stream)))) 186 | 187 | (defun write-json-obj (obj stream) 188 | (write-char #\{ stream) 189 | (let ((first t)) 190 | (flet ((write-prop (key) 191 | (multiple-value-bind (val include) (funcall *replacer* key (js-prop obj key)) 192 | (when include 193 | (if first (setf first nil) (write-char #\, stream)) 194 | (write-json (to-string key) stream) 195 | (write-char #\: stream) 196 | (write-json val stream))))) 197 | (js-for-in obj #'write-prop t))) 198 | (write-char #\} stream)) 199 | 200 | (defun write-json-array (arr stream) 201 | (write-char #\[ stream) 202 | (loop :for i :from 0 :for val :across (js-array-vec arr) :for first := t :then nil :do 203 | (unless first (write-char #\, stream)) 204 | (write-json (funcall *replacer* i val) stream)) 205 | (write-char #\] stream)) 206 | -------------------------------------------------------------------------------- /deflib.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-js) 2 | 3 | (defstruct lib 4 | name 5 | prototypes 6 | toplevel) 7 | 8 | (defmethod print-object ((obj lib) stream) 9 | (print-unreadable-object (obj stream :type t) 10 | (princ (or (lib-name obj) "unnamed") stream))) 11 | 12 | (defstruct objspec 13 | (prototype :object) 14 | props) 15 | 16 | (defstruct (funcspec (:include objspec)) 17 | call 18 | proto-spec 19 | make-new) 20 | 21 | (defvar *lib*) 22 | (defvar *objspec*) 23 | (defparameter *default-slot-flags* +slot-dflt+) 24 | 25 | (defun slot-flags (&rest flags) 26 | (let ((val *default-slot-flags*)) 27 | (macrolet ((add (flag) `(setf val (logior val ,flag))) 28 | (rm (flag) `(setf val (logand val (lognot ,flag))))) 29 | (dolist (flag flags) 30 | (case flag 31 | (:enum (rm +slot-noenum+)) (:noenum (add +slot-noenum+)) 32 | (:ro (add +slot-ro+)) (:rw (rm +slot-ro+)) 33 | (:del (rm +slot-nodel+)) (:nodel (add +slot-nodel+)) 34 | (active (add +slot-active+))))) 35 | val)) 36 | 37 | (defun check-spec (spec &rest allowed) 38 | (loop :for elt :in spec :do 39 | (if (and (consp elt) (keywordp (car elt))) 40 | (unless (member (car elt) allowed) 41 | (error "No ~a specs allowed in this form." (car elt))) 42 | (unless (member t allowed) 43 | (error "No body (non-keyword-list element) allowed in this form."))))) 44 | 45 | (defmacro with-default-slot-flags ((&rest flags) &body body) 46 | `(let ((*default-slot-flags* (slot-flags ,@flags))) ,@body)) 47 | 48 | (defun spec-val (spec type &optional default) 49 | (let ((found (find type spec :test #'eq :key (lambda (sp) (and (consp sp) (car sp)))))) 50 | (if found (second found) default))) 51 | (defun spec-list (spec type &optional default) 52 | (let ((any nil)) 53 | (loop :for part :in spec 54 | :when (and (consp part) (eq (car part) type)) 55 | :do (setf any t) :and :append (cdr part) 56 | :finally (unless any (return default))))) 57 | (defun spec-body (spec) 58 | (loop :for part :in spec 59 | :unless (and (consp part) (keywordp (car part))) :collect part)) 60 | 61 | (defun add-prop (name val &optional (flags +slot-dflt+)) 62 | (let* ((props (objspec-props *objspec*)) 63 | (found (assoc name props :test #'string=))) 64 | (cond (found (setf (cdr found) (cons val flags))) 65 | (props (setf (cdr (last props)) (list (list* name val flags)))) 66 | (t (setf (objspec-props *objspec*) (list (list* name val flags))))))) 67 | 68 | (defun add-prototype (tag spec) 69 | (let* ((protos (lib-prototypes *lib*)) 70 | (found (assoc tag protos :test #'eq))) 71 | (cond (found (setf (cdr found) spec)) 72 | (protos (setf (cdr (last protos)) (list (cons tag spec)))) 73 | (t (setf (lib-prototypes *lib*) (list (cons tag spec))))))) 74 | 75 | (defun empty-lib (&optional name) 76 | (make-lib :name name :toplevel (make-objspec :prototype :object))) 77 | 78 | (defmacro add-to-lib (lib &body body) 79 | `(let* ((*lib* ,lib) 80 | (*objspec* (lib-toplevel *lib*))) 81 | ,@body 82 | *lib*)) 83 | 84 | (defun default-constructor-name (structname) 85 | (intern (format nil "%make-new-~a-~a" (symbol-name structname) (package-name (symbol-package structname))) :cl-js)) 86 | 87 | (defmacro define-js-obj (name &body slots) 88 | (multiple-value-bind (name opts) 89 | (if (consp name) (values (car name) (cdr name)) (values name ())) 90 | `(defstruct (,name (:include obj) (:constructor ,(default-constructor-name name) (cls)) ,@opts) ,@slots))) 91 | 92 | (defparameter *stdlib* (empty-lib "standard-library")) 93 | 94 | (defmacro .prototype (tag &body spec) 95 | (check-spec spec :parent :slot-default t) 96 | `(let ((*objspec* (make-objspec :prototype ,(spec-val spec :parent :object))) 97 | (*default-slot-flags* (slot-flags ,@(let ((list (spec-list spec :slot-default))) 98 | (if (member :enum list) list (cons :noenum list)))))) 99 | ,@(spec-body spec) 100 | (add-prototype ,tag *objspec*))) 101 | 102 | (defun arg-count (list) 103 | (or (position '&rest list) (length list))) 104 | 105 | (defmacro .constructor (name (&rest args) &body spec) 106 | (check-spec spec :prototype :slot-default t :properties :slot :make-new :type) 107 | (let* ((proto (spec-list spec :prototype)) 108 | (proto (if (keywordp (car proto)) 109 | (car proto) 110 | (progn 111 | (check-spec proto :slot-default t) 112 | `(let ((*objspec* (make-objspec)) 113 | (*default-slot-flags* (slot-flags ,@(let ((list (spec-list proto :slot-default))) 114 | (if (member :enum list) list (cons :noenum list)))))) 115 | ,@(spec-body proto) 116 | *objspec*))))) 117 | `(add-prop 118 | ,name 119 | (let ((*objspec* (make-funcspec :call ,(wrap-js-lambda args (spec-body spec)) 120 | :prototype :function 121 | :proto-spec ,proto 122 | :make-new ,(let ((type (spec-val spec :type))) 123 | (if type 124 | `',(default-constructor-name type) 125 | (spec-val spec :make-new))))) 126 | (*default-slot-flags* (slot-flags ,@(spec-list spec :slot-default '(:enum))))) 127 | (.value "length" (:slot :ro :noenum) ,(arg-count args)) 128 | ,@(spec-list spec :properties) 129 | *objspec*) 130 | (slot-flags ,@(spec-list spec :slot))))) 131 | 132 | (defmacro .object (name &body spec) 133 | (check-spec spec :parent :slot-default t :slot) 134 | `(add-prop 135 | ,name 136 | (let ((*objspec* (make-objspec :prototype ,(spec-val spec :parent :object))) 137 | (*default-slot-flags* (slot-flags ,@(spec-list spec :slot-default '(:enum))))) 138 | ,@(spec-body spec) 139 | *objspec*) 140 | (slot-flags ,@(spec-list spec :slot)))) 141 | 142 | (defmacro .value (name &body spec) 143 | (check-spec spec :slot t) 144 | `(add-prop ,name (lambda () ,@(spec-body spec)) (slot-flags ,@(spec-list spec :slot)))) 145 | 146 | (defmacro .func (name (&rest args) &body spec) 147 | (check-spec spec :slot :slot-default :properties t) 148 | `(add-prop 149 | ,name 150 | (let ((*objspec* (make-funcspec :call ,(wrap-js-lambda args (spec-body spec)) 151 | :prototype :function)) 152 | (*default-slot-flags* (slot-flags ,@(spec-list spec :slot-default '(:enum))))) 153 | ,@(spec-list spec :properties) 154 | (.value "length" (:slot :ro :noenum) ,(arg-count args)) 155 | *objspec*) 156 | (slot-flags ,@(spec-list spec :slot)))) 157 | 158 | (defmacro .active (name &body spec) 159 | (check-spec spec :read :write :slot) 160 | `(add-prop 161 | ,name 162 | (cons ,(let ((read (spec-list spec :read))) 163 | (and read (wrap-js-lambda (car read) (cdr read)))) 164 | ,(let ((write (spec-list spec :write))) 165 | (and write (wrap-js-lambda (car write) (cdr write))))) 166 | (slot-flags 'active ,@(spec-list spec :slot)))) 167 | 168 | (defmacro .active-r (name &body spec) 169 | (check-spec spec :slot t) 170 | `(add-prop 171 | ,name 172 | (cons ,(wrap-js-lambda () (spec-body spec)) nil) 173 | (slot-flags 'active ,@(spec-list spec :slot)))) 174 | 175 | ;; Building environments. 176 | 177 | (defun init-val (value) 178 | (typecase value 179 | (function (funcall value)) 180 | (objspec (init-obj value)) 181 | (t value))) 182 | 183 | (defun init-obj (spec &optional fill) 184 | (when (keywordp spec) 185 | (return-from init-obj (find-proto spec))) 186 | (let* ((props (objspec-props spec)) 187 | (is-func (funcspec-p spec)) 188 | (new-proto (when (and is-func (funcspec-proto-spec spec)) 189 | (let ((proto-obj (init-obj (funcspec-proto-spec spec)))) 190 | (push (list* "prototype" proto-obj +slot-noenum+) props) 191 | proto-obj))) 192 | (new-cls (make-scls () new-proto)) 193 | (vals (make-array (max 2 (length props)))) 194 | (cls (make-scls (loop :for off :from 0 :for (name value . flags) :in props 195 | :do (setf (svref vals off) (init-val value)) 196 | :collect (list* (intern-prop name) off flags)) 197 | (and (objspec-prototype spec) (init-obj (objspec-prototype spec)))))) 198 | (cond (fill (setf (obj-vals fill) vals (obj-cls fill) cls)) 199 | ((funcspec-p spec) 200 | (let ((built (if (funcspec-make-new spec) 201 | (make-cfobj cls (funcspec-call spec) new-cls (funcspec-make-new spec) vals) 202 | (make-fobj cls (funcspec-call spec) new-cls vals)))) 203 | (when new-proto 204 | (ensure-slot new-proto "constructor" built +slot-noenum+)) 205 | built)) 206 | (t (make-obj cls vals))))) 207 | 208 | (defun create-env (&rest libs) 209 | (let* ((bootstrap (make-array (length *std-types*) :initial-contents 210 | (loop :repeat (length *std-types*) :collect (make-obj nil nil)))) 211 | (objproto (svref bootstrap (type-offset :object))) 212 | (clss (make-array (length *std-types*) :initial-contents 213 | (loop :for id :across *std-types* :for i :from 0 :collect 214 | (make-scls () (svref bootstrap i))))) 215 | (*env* (make-gobj (make-hcls objproto) (make-hash-table :test 'eq) bootstrap clss))) 216 | (loop :for (id . obj) :in (lib-prototypes *stdlib*) :do 217 | (let ((pos (position id *std-types*))) 218 | (when pos 219 | (init-obj obj (aref bootstrap pos))))) 220 | (loop :for shell :across bootstrap :for i :from 0 :do 221 | (unless (obj-cls shell) (error "Missing definition for standard class ~a" (aref *std-types* i)))) 222 | (apply 'add-to-env *env* *stdlib* libs) 223 | *env*)) 224 | 225 | (defun add-to-env (*env* &rest libs) 226 | (dolist (lib libs) 227 | (loop :for (id . obj) :in (lib-prototypes lib) :do 228 | (unless (find id *std-types*) 229 | (let ((proto (init-obj obj))) 230 | (push (list* id proto (make-scls () proto)) (gobj-proto-list *env*))))) 231 | (loop :for (name val . flags) :in (objspec-props (lib-toplevel lib)) :do 232 | (ensure-slot *env* name (init-val val) flags))) 233 | *env*) 234 | 235 | (defmacro with-js-env ((&rest libs) &body body) 236 | `(let ((*env* (create-env ,@libs))) ,@body)) 237 | 238 | (defmacro integrate-type (specializer &body spec) 239 | (check-spec spec :string :boolean :number :typeof :proto-id) 240 | (flet ((arg/body (list) 241 | (if (and (consp (car list)) (cdr list)) 242 | (values (caar list) (cdr list)) 243 | (values (gensym) list)))) 244 | `(progn 245 | ,@(let ((proto-id (spec-list spec :proto-id))) 246 | (when proto-id 247 | (multiple-value-bind (arg body) (arg/body proto-id) 248 | `((defmethod static-js-prop ((,arg ,specializer) cache) 249 | (funcall (the function (cache-op cache)) ,arg (find-proto (progn ,@body)) cache)) 250 | (defmethod js-prop ((,arg ,specializer) prop) 251 | (do-lookup ,arg (find-proto (progn ,@body)) prop)) 252 | (defmethod (setf static-js-prop) (val (obj ,specializer) wcache) 253 | (declare (ignore wcache)) val) 254 | (defmethod (setf js-prop) (val (obj ,specializer) prop) 255 | (declare (ignore prop)) val) 256 | (defmethod js-for-in ((,arg ,specializer) func &optional shallow) 257 | (js-for-in (find-proto (progn ,@body)) func shallow)))))) 258 | ,@(loop :for (tag method default) :in '((:string js-to-string "[object Object]") (:number js-to-number (nan)) 259 | (:boolean js-to-boolean t) (:typeof js-type-of "foreign")) :collect 260 | (let ((found (spec-list spec tag))) 261 | (multiple-value-bind (arg body) (if found (arg/body found) (values (gensym) (list default))) 262 | `(defmethod ,method ((,arg ,specializer)) ,@body))))))) 263 | -------------------------------------------------------------------------------- /test.js: -------------------------------------------------------------------------------- 1 | function $eq(a, b) { 2 | if (a != b) 3 | throw "$eq(" + a + ", " + b + ") failed"; 4 | } 5 | function $arrEq(a, b) { 6 | var mismatch = a.length != b.length; 7 | if (!mismatch) { 8 | for (var i = 0; i < a.length; i++) 9 | if (a[i] != b[i]) mismatch = true; 10 | } 11 | if (mismatch) 12 | throw "$arrEq(" + a + ", " + b + ") failed"; 13 | } 14 | 15 | function test_1() { 16 | this.a = new Object; 17 | a.a = 1; 18 | function f(o) {return o.a;} 19 | $eq(f(this), a); 20 | $eq(f(a), 1); 21 | 22 | function f2() {return this.a;} 23 | $eq(f2(), a); 24 | 25 | a.f3 = f2; 26 | $eq(a.f3(), 1); 27 | 28 | function f4() {return f(this);} 29 | $eq(f4(), a); 30 | topf4 = f4; 31 | $eq(this.topf4(), a); 32 | a.f5 = f4; 33 | $eq(a.f5(), 1); 34 | 35 | var fifi = 3; 36 | a.fifi = 4; 37 | a.f = function () {return fifi;}; 38 | $eq(a.f(), 3); 39 | } 40 | 41 | function test_2() { 42 | function f33() { 43 | var v = {v1: {v2: 4}}; 44 | this.y = v.v1.v2; 45 | } 46 | f33.prototype = {x: 3}; 47 | 48 | b = new f33(); 49 | $eq(b.x, 3); 50 | $eq(b.y, 4); 51 | } 52 | 53 | function test_3() { 54 | function fib(n) { 55 | if (n < 2) return 1; 56 | return fib(n - 1) + fib(n - 2); 57 | } 58 | function ffib(n) { 59 | var s1 = 1, s2 = 1, res = 1; 60 | while(n > 1) { 61 | res = s1 + s2; 62 | s1 = s2; 63 | s2 = res; 64 | n--; 65 | } 66 | return res; 67 | } 68 | 69 | $eq(ffib(14), 610); 70 | for (var i = 0; i < 10; i++) 71 | $eq(fib(i), ffib(i)); 72 | } 73 | 74 | function test_4() { 75 | function afun(a) { 76 | from_inside = 1; 77 | arguments[0] = a + 1; 78 | $eq(a + 1, 102); 79 | $eq(a, 101); 80 | $eq(arguments[0], 101); 81 | $eq(arguments[1], 200); 82 | } 83 | afun(100, 200); 84 | $eq(from_inside, 1); 85 | } 86 | 87 | function test_5() { 88 | function adder(n){ 89 | return function(m) {return n+m;}; 90 | } 91 | $eq(adder(1)(2), 3); 92 | } 93 | 94 | function test_6() { 95 | function fbla(x) { 96 | var a = function f1(n) {return b(n);}; 97 | var b = function f2(n, m) { 98 | if (m) return n+n; 99 | return f2(n + 1, 5); 100 | }; 101 | return a(x); 102 | } 103 | $eq(fbla(2), 6); 104 | } 105 | 106 | function test_7() { 107 | var s = 0; 108 | for (var i = 0; i < 10; i = i + 1) 109 | s = s + 1; 110 | $eq(s, 10); 111 | 112 | s = 0; 113 | for (var i = 0;; i = i + 1) { 114 | s = s + i; 115 | if(s > 100) break; 116 | } 117 | $eq(i, 14); 118 | 119 | s = 0; 120 | for (i = 0; i < 10; i = i +1 ) { 121 | if(i%2) continue; 122 | s = s + i; 123 | } 124 | $eq(s, 20); 125 | 126 | var a = 100; 127 | while (a) {a = a - 1;} 128 | $eq(a, 0); 129 | 130 | a = 100; 131 | do {a = a - 1;} while (a > 0); 132 | $eq(a, 0); 133 | 134 | do a = a - 1; 135 | while (a > 0); 136 | $eq(a, -1); 137 | } 138 | 139 | function test_8() { 140 | function O(){} 141 | O.prototype.f = function (){return this.n + 1;} 142 | var obj = new O; 143 | obj.n = 20; 144 | $eq(obj.f(), 21); 145 | } 146 | 147 | function test_9() { 148 | a: for (;;) {for (;;) break a;} 149 | b: for (var i = 0; i < 10 ; i = i + 1) {for (;;) continue b;} 150 | } 151 | 152 | function test_10() { 153 | var x10 = null; 154 | function f1() { 155 | return function(val) {x10=val;} 156 | } 157 | 158 | var o10 = new Object; 159 | o10.x10=2; 160 | var f=f1(); 161 | with(o10) f(3); 162 | $eq(o10.x10, 2); 163 | $eq(x10, 3); 164 | } 165 | 166 | function test_11() { 167 | var o = function () {} 168 | o.x11="asd"; 169 | function f11x(o) { 170 | with(o) {return function(val) {x11=val;};} 171 | } 172 | var o11 = new Object; 173 | var f11 = f11x(o11); 174 | f11(5); 175 | $eq(x11, 5); 176 | $eq(o11.x11, undefined); 177 | 178 | o11.x11 = 3; 179 | f11(4); 180 | $eq(x11, 5); 181 | $eq(o11.x11, 4); 182 | } 183 | 184 | function test_12() { 185 | function f12x(x, o) { 186 | function r() {return x;} 187 | with(o) return {'a': function (y) {x = y;}, 'b': r}; 188 | } 189 | 190 | var o12 = new Object; 191 | var f12 = f12x(10, o12); 192 | f12['a'](100); 193 | $eq(o12.x, undefined); 194 | $eq(f12['b'](), 100); 195 | o12.x = 1; 196 | f12['a'](200); 197 | $eq(o12.x, 200); 198 | $eq(f12['b'](), 100); 199 | } 200 | 201 | function test_13() { 202 | var o13x = {g: function(){return 2;}}; 203 | function f13(o) { 204 | with(o) { 205 | function g() {return 1;} 206 | return g(); 207 | } 208 | } 209 | $eq(f13(o13x), 2); 210 | } 211 | 212 | function test_14() { 213 | var r1; 214 | try {r1 = bflj();} 215 | catch(e) {r1 = 100;} 216 | finally {r1 = 2 * r1;} 217 | $eq(r1, 200); 218 | } 219 | 220 | function test_15() { 221 | function f15(x,s1) { 222 | return function(y, s2) {return eval(s1+s2);} 223 | } 224 | $eq(f15(5, "y+")(6, "x;"), 11); 225 | } 226 | 227 | 228 | function test_16() { 229 | function f16(x,s) { 230 | return eval(s); 231 | } 232 | $eq(f16(55, "x+x;"), 110); 233 | } 234 | 235 | function test_17() { 236 | function f17(o) { 237 | var x = 3; 238 | with(o) {x = 4;} 239 | return x 240 | } 241 | var oo = new Object 242 | $eq(f17(oo), 4); 243 | oo.x = 7; 244 | $eq(f17(oo), 3); 245 | $eq(oo.x, 4); 246 | } 247 | 248 | function test_18() { 249 | var x = null; 250 | function f18(o) { 251 | with(o) return function(y) {x = y;} 252 | } 253 | var oo = new Object; 254 | f18_1 = f18(oo); 255 | f18_1(5); 256 | $eq(x, 5); 257 | 258 | oo.x = 7; 259 | f18_1(6); 260 | $eq(x, 5); 261 | $eq(oo.x, 6); 262 | } 263 | 264 | function test_19() { 265 | function f19(o, str) { 266 | with(o) return function(y) {eval(str);} 267 | } 268 | var oo = new Object 269 | f19_1 = f19(oo, "x=y;"); 270 | f19_1(5); 271 | $eq(x, 5); 272 | oo.x = 7; 273 | f19_1(6); 274 | $eq(x, 5); 275 | $eq(oo.x, 6); 276 | } 277 | 278 | function test_20() { 279 | var s1 = String(123); 280 | var s2 = new String(456); 281 | String.prototype.y = 12; 282 | $eq(s2.y, 12); 283 | $eq(s2.charAt(1), "5"); 284 | $eq(String.prototype.length, 0); 285 | $eq(s2.length, 3); 286 | $eq(s2.length = 555, 555); 287 | $eq(s2.length, 3); 288 | $eq(s2.substr("1", 8), "56"); 289 | $eq(s2.substring (0, 100), "456"); 290 | } 291 | 292 | function test_21() { 293 | var a = [1, 2, 3]; 294 | $arrEq(a.splice(0, 0), []); 295 | $arrEq(a, [1, 2, 3]); 296 | a.splice(0, 0, 100, 200); 297 | $arrEq(a, [100, 200, 1, 2, 3]); 298 | a.splice(1, 1000); 299 | $arrEq(a, [100]); 300 | a = [1, 2, 3]; a.splice(0, 1); 301 | $arrEq(a, [2, 3]); 302 | a = [1, 2, 3]; a.splice(0, 2, 10, 11, 12); 303 | $arrEq(a, [10, 11, 12, 3]); 304 | a.splice(0, 4, 8, 9, 10); 305 | $arrEq(a, [8, 9, 10]); 306 | a = [1, 2, 3]; a.splice(2, 2); 307 | $arrEq(a, [1, 2]); 308 | a = [1, 2, 3]; a.splice(2, 2, 10, 12); 309 | $arrEq(a, [1, 2, 10, 12]); 310 | // Commenting this for now. Having these as methods of the 311 | // constructor seems widespread, but isn't in the standard. I want 312 | // to focus on the standard first. 313 | // $arrEq(Array.splice(a, 0, 1), [1]); 314 | // $arrEq(a, [2, 10, 12]); 315 | } 316 | 317 | function test_22() { 318 | function t22(x, y, str) { 319 | f(0); 320 | $eq(x, 1); 321 | function f(x) { 322 | eval(str); 323 | $eq(x, 2); 324 | } 325 | } 326 | t22(1, 2, "x=y;"); 327 | } 328 | 329 | function test_23() { 330 | function f23(str) { 331 | var f23_1 = function() {return 100;}; 332 | eval(str); 333 | return f23_1(); 334 | } 335 | 336 | $eq(f23("f23_1 = function() {return 5;};"), 5); 337 | var p = 0; 338 | try {f23_1();} 339 | catch(e) {p = 2;} 340 | $eq(p, 2); 341 | $eq(f23("f23_2 = function() {return 5;};"), 100); 342 | $eq(f23_2(), 5); 343 | } 344 | 345 | function test_24() { 346 | $eq(new Function("a", "b", "return a+b;")(2,3), 5); 347 | $eq(new Function.prototype.constructor("a", "b", "return a+b;")(3,4), 7); 348 | $eq(new (function(){}).constructor("a", "b", "return a+b;")(4,5), 9); 349 | 350 | $eq(Function, Function.prototype.constructor); 351 | $eq(Function, (function(){}).constructor); 352 | } 353 | 354 | function test_25() { 355 | $eq(Function.call(1, 'a', 'b' , 'return a*b;')(2,3), 6); 356 | $eq("abc".charAt.call("def", 1), "e"); 357 | $eq((function(x,y) {return x-y;}).call(new Object,10,5), 5); 358 | } 359 | 360 | function test_26() { 361 | function f26(x,y,z) { 362 | return x+y*z; 363 | } 364 | $eq(f26.apply(new Object, [1,2,3,4]), 7); 365 | $eq(f26.apply(new Object, new Array(1,2,3,4)), 7); 366 | 367 | function f26_1() { 368 | return f26.apply(new Object, arguments) 369 | } 370 | $eq(f26_1(1,2,3,4), 7); 371 | 372 | var v26 = [7,8,9]; 373 | [1,2,3].splice.apply(v26, [0, 2, 100, 101]); 374 | $arrEq(v26, [100, 101, 9]); 375 | } 376 | 377 | function test_27() { 378 | o27 = new Object 379 | $eq(this['o2' + '7'], o27) 380 | this['o2' + '7'].x=5 381 | with(o27) { 382 | $eq(x, 5) 383 | x = 6 384 | } 385 | $eq(o27.x, 6) 386 | } 387 | 388 | function test_28() { 389 | $eq(4 && 5, 5); 390 | $eq({} && 7, 7); 391 | $eq(0 && 7, 0); 392 | $eq(4 || 5, 4); 393 | $eq(false || 7, 7); 394 | $eq(null || 7, 7); 395 | $eq(!0, true); 396 | $eq(!1, false); 397 | 398 | var x = 0; 399 | true || (x = 1); 400 | false && (x = 1); 401 | $eq(x, 0); 402 | } 403 | 404 | function test_29() { 405 | var a = {a: 10}; 406 | $eq(a.hasOwnProperty("a"), true); 407 | $eq(a.hasOwnProperty("b"), false); 408 | $eq(a.hasOwnProperty("toString"), false); 409 | $eq(a.propertyIsEnumerable("a"), true); 410 | $eq(a.propertyIsEnumerable("b"), false); 411 | $eq(a.propertyIsEnumerable("toString"), false); 412 | $eq(Object.prototype.hasOwnProperty("toString"), true); 413 | $eq(Object.prototype.propertyIsEnumerable("toString"), false); 414 | } 415 | 416 | function test_30() { 417 | $eq(new Error("foo").message, "foo"); 418 | $eq(new Error("foo").toString, Error.prototype.toString); 419 | try {throw 1;} 420 | catch(e) {var err = e;} 421 | $eq(err, 1); 422 | try {undefined.prop;} 423 | catch(e) {$eq(e.toString, TypeError.prototype.toString);} 424 | try {eval("a b c");} 425 | catch(e) {$eq(e.toString, SyntaxError.prototype.toString);} 426 | } 427 | 428 | function test_31() { 429 | $eq('xaba'.replace('a', 'c'), 'xcba'); 430 | $eq('xaba'.replace(/a/, 'c'), 'xcba'); 431 | $eq('xaba'.replace(/a/g, 'c'), 'xcbc'); 432 | $eq('xaba'.replace(/a/g, function(){return 33;}), 'x33b33'); 433 | $eq('xdabda'.replace(/d(a)/g, function(full) {return full + 1;}), 'xda1bda1'); 434 | $eq('xdabda'.replace(/d(a)/g, function(full, g1) {return g1;}), 'xaba'); 435 | $eq('xdabda'.replace(/d(a)/g, '\\1'), 'xaba'); 436 | $eq('xdabda'.replace(/d(a)/g, function(full, g1, pos) {return pos;}), 'x1b4'); 437 | $eq('xdabda'.replace(/d(a)/g, function(full, g1, pos, all) {return all;}), 'xxdabdabxdabda'); 438 | $eq('foo'.replace(/f(x)?/, '\\1'), 'oo'); 439 | } 440 | 441 | function test_32() { 442 | var re1 = /foo(bar)?/i; 443 | var re2 = /foobar/gm; 444 | $eq(re1.ignoreCase, true); 445 | $eq(re1.multiline, false); 446 | $eq(re1.global, false); 447 | $eq(re2.ignoreCase, false); 448 | $eq(re2.multiline, true); 449 | $eq(re2.global, true); 450 | var m = re1.exec("foobar"); 451 | $eq(m.length, 2); 452 | $eq(m[0], "foobar"); 453 | $eq(m[1], "bar"); 454 | m = re1.exec("foo"); 455 | $eq(m.length, 2); 456 | $eq(m[0], "foo"); 457 | $eq(m[1], undefined); 458 | $eq(re2.test("foobar"), true); 459 | $eq(re2.test("quux"), false); 460 | $eq(re2("quux"), null); 461 | } 462 | 463 | function test_33() { 464 | var a, b; 465 | function testcase(x) { 466 | switch (x) { 467 | default: 468 | case 1: a = 1; break; 469 | case 2: a = 2; 470 | case 3: b = 3; 471 | break; 472 | case 4: a = 100; 473 | } 474 | } 475 | testcase(1); 476 | $eq(a, 1); 477 | testcase(2); 478 | $eq(a, 2); 479 | $eq(b, 3); 480 | testcase(4); 481 | $eq(a, 100); 482 | $eq(b, 3); 483 | testcase(5); 484 | $eq(a, 1); 485 | } 486 | 487 | function test_34() { 488 | function a() {return "wrong"} 489 | var obj = {u: "right", a: function() {return this.u;}}; 490 | with (obj) {$eq(a(), "right");} 491 | } 492 | 493 | function test_35() { 494 | $eq('3' ^ 4, 7); 495 | $eq(3 ^ 4, 7); 496 | $eq('12321312312312' ^ '1512312423423423', 1807226439); 497 | } 498 | 499 | function test_36() { 500 | var base = {a: 10, b: 20}, clone = Object.create(base); 501 | $eq(clone.a, 10); 502 | $arrEq(Object.keys(base), Object.keys(clone)); 503 | $eq(Object.keys(base).length, 2); 504 | $eq(clone.c, undefined); 505 | base.c = 30; 506 | $eq(clone.c, 30); 507 | var clone2 = Object.create(base, {d: 6}); 508 | $eq(clone2.d, 6); 509 | base.d = 5; 510 | $eq(clone2.d, 6); 511 | } 512 | 513 | function test_37() { 514 | var data = [1, 2, 3, 4]; 515 | function add(a, b) {return a + b;} 516 | function conc(a, b) {return a + "" + b;} 517 | $eq(data.reduce(add), 10); 518 | $eq(data.reduceRight(add), 10); 519 | $eq(data.reduce(conc, 0), "01234"); 520 | $eq(data.reduceRight(conc, 5), "54321"); 521 | $eq([].reduce(add, 1), 1); 522 | $eq([].reduceRight(add, 1), 1); 523 | try {[].reduce(add); $eq(1, 2);} 524 | catch(e){$eq(e instanceof TypeError, true);} 525 | try {[].reduceRight(add); $eq(1, 2);} 526 | catch(e){$eq(e instanceof TypeError, true);} 527 | } 528 | 529 | // This used to confuse the type inferrer 530 | function test_38() { 531 | function a(){return b();} 532 | function b(){if (false) return a(); throw 1;} 533 | try{return a();}catch(e){} 534 | } 535 | 536 | function test_39() { 537 | var x = 10; 538 | $eq((x === 10) && 539 | (function () { var x = 10; return x === 10; })() && 540 | (function () { return 10 === 10; })(), 541 | true); 542 | } 543 | 544 | function test_40() { 545 | var foo = function foo() { return arguments.callee.caller; }; 546 | var bar = function bar() { return foo(); }; 547 | if (typeof bar() != "function") { 548 | throw "arguments.callee.caller doesn't work"; 549 | } 550 | } 551 | 552 | function test_41() { 553 | $eq(-12 % 7, -5); 554 | } 555 | 556 | function test_42() { 557 | var a = [3]; 558 | $eq(a.unshift(2), 2); 559 | $arrEq(a, [2, 3]); 560 | $eq(a.unshift(0, 1), 4); 561 | $arrEq(a, [0, 1, 2, 3]); 562 | 563 | a = [3, 4]; 564 | $eq(a.shift(), 3); 565 | $arrEq(a, [4]); 566 | $eq(a.shift(), 4); 567 | $arrEq(a, []); 568 | $eq(a.shift(), undefined); 569 | $arrEq(a, []); 570 | 571 | $eq(a.unshift(0), 1); 572 | $arrEq(a, [0]); 573 | $eq(a.unshift(), 1); 574 | $arrEq(a, [0]); 575 | } 576 | 577 | function runTests() { 578 | var failures = []; 579 | var run = 0; 580 | for (var name in this) { 581 | if (name.length > 5 && name.substr(0, 5) == "test_") { 582 | run++; 583 | try {this[name]();} 584 | catch (e) { 585 | failures.push(name + ": " + String(e)); 586 | } 587 | } 588 | } 589 | print(run + " test run..."); 590 | if (failures.length) 591 | print(failures.length + " failures:\n " + failures.join("\n ")); 592 | else 593 | print("All passed!"); 594 | } 595 | 596 | runTests(); 597 | -------------------------------------------------------------------------------- /infer.lisp: -------------------------------------------------------------------------------- 1 | ;; JavaScript type-inferrer. Takes an AST as parse-js produces them 2 | ;; and tags the elements in that AST with types. Code isn't very 3 | ;; pretty, and is too messy to prove correct in even the slightest 4 | ;; way, so testing will have to show whether it works for all cases. 5 | ;; 6 | ;; Interface: 7 | ;; infer-types (ast) 8 | ;; Tags the given AST. 9 | ;; ast-type (ast) 10 | ;; Returns the type (if any) of the given AST node. 11 | 12 | (in-package :cl-js) 13 | 14 | ;; A type-cell, an updatable structure that is used to track the 15 | ;; widest type of something. 16 | (defstruct tc 17 | tp ;; Current type of the cell. Any of T, nil, :null, :undefined, 18 | ;; :object, :number, :integer, :boolean, :string. T means this 19 | ;; could be any type, nil means no information is available yet. 20 | rels ;; Relations this tc has to other tcs. Resolved by resolve-tc 21 | deps) ;; Used internally by resolve-tc when solving cyclic relations 22 | (defun tc (tp &rest rels) 23 | (make-tc :tp tp :rels rels)) 24 | 25 | ;; Function type, used to deduce return types and argument types in a 26 | ;; few simple situations (direct call to function literal, local 27 | ;; functions that don't escape). args is a list of tcs, returns a 28 | ;; single tc. 29 | (defstruct ft args returns) 30 | 31 | ;; Takes two types (as in the tp slot of a type cell), and combines 32 | ;; them into a single type. 33 | (defun combine-types (tp1 tp2) 34 | (cond ((not tp1) tp2) ((not tp2) tp1) 35 | ((eq tp1 tp2) tp1) 36 | ((and (member tp1 '(:number :integer)) (member tp2 '(:number :integer))) :number) 37 | (t t))) 38 | ;; Add a possible type to a type-cell. 39 | (defun add-type (tc tp) 40 | (setf (tc-tp tc) (combine-types tp (tc-tp tc)))) 41 | ;; Make a type-cell depend on another cell. We don't just do (add-type 42 | ;; tc1 (tc-tp tc2)), since tc2 might be updated down the line, so the 43 | ;; adding happens at resolution time. 44 | (defun link-tc (tc1 tc2) 45 | (push (list :and tc2) (tc-rels tc1))) 46 | 47 | ;; Environments are a list of scopes. Scopes are either :with (for a 48 | ;; with(x){} scope), or lists of variables. Each variable is a (init 49 | ;; delayed-functions "name" tc) list. Any change requires a new 50 | ;; environment to be consed up, since they are shared. 51 | 52 | ;; They are used mostly to track variable initialization. In JS, a 53 | ;; variable always starts out undefined, but is usually used only 54 | ;; after assignment. Environments are threaded through the infer 55 | ;; methods in such a way that each method receives an environment that 56 | ;; passed through all code paths that could possibly be executed 57 | ;; before it. 58 | 59 | ;; Delayed functions are function definitions that should be inferred 60 | ;; once the variable is actually being used. This is done to prevent 61 | ;; the function from being inferred in an environment where all 62 | ;; variables are uninitialized. This may cause function bodies to be 63 | ;; inferred multiple times, but this is harmless. 64 | 65 | ;; Called when exiting a scope. 66 | (defun pop-scope (env) (cdr env)) 67 | 68 | ;; Update the mutable fields of a var in an environment, consing as 69 | ;; little as possible. 70 | (defun update-env (env var init delayed-function) 71 | (labels ((iter-scope (scope) 72 | (let ((found (and (not (eq (car scope) :with)) (find var (car scope))))) 73 | (if found 74 | (cons (iter-var (car scope)) (cdr scope)) 75 | (cons (car scope) (iter-scope (cdr scope)))))) 76 | (iter-var (list) 77 | (if (eq (car list) var) 78 | (cons (list* init delayed-function (cddr var)) (cdr list)) 79 | (cons (car list) (iter-var (cdr list)))))) 80 | (iter-scope env))) 81 | ;; Mark all visible locals as potentially containing any type. 82 | (defun ruin-env-for-eval (env) 83 | (let ((vars-seen ())) 84 | (dolist (scope env) 85 | (unless (eq scope :with) 86 | (dolist (var scope) 87 | (unless (member (third var) vars-seen :test #'string=) 88 | (push (third var) vars-seen) 89 | (add-type (var-tc var) t))))))) 90 | 91 | ;; Lookup a variable definition in the current env. Returns a second 92 | ;; value of T if a with scope was passed before finding the variable. 93 | (defun find-in-env (env name) 94 | (let ((passed-with nil)) 95 | (dolist (scope env) 96 | (if (eq scope :with) 97 | (setf passed-with t) 98 | (dolist (var scope) 99 | (when (string= (third var) name) 100 | (return-from find-in-env (values var passed-with)))))))) 101 | 102 | ;; Accessors for environment var lists. 103 | (defun var-tc (var) (fourth var)) 104 | (defun var-init (var) (first var)) 105 | (defun var-delayed-function (var) (second var)) 106 | 107 | ;; Merge two environments (for example, after an if/else branch). The 108 | ;; arguments should have the same shape, with only different values 109 | ;; for init and delayed-functions slots 110 | (defun merge-env (env1 env2) 111 | (when (eq env1 env2) (return-from merge-env env1)) 112 | (loop :for scope1 :in env1 :for scope2 :in env2 113 | :if (eq scope1 :with) :collect ':with :else :collect 114 | (loop :for var1 :in scope1 :for var2 :in scope2 :collect 115 | (if (and (eq (var-init var1) (var-init var2)) 116 | (equal (var-delayed-function var1) (var-delayed-function var2))) 117 | var1 118 | (list* (and (var-init var1) (var-init var2)) 119 | (or (var-delayed-function var1) (var-delayed-function var2)) 120 | (cddr var1)))))) 121 | 122 | ;; Assign a type to a local variable. type can be a type cell or a 123 | ;; type symbol. Returns a new environment in which the variable will 124 | ;; be marked as initialized. 125 | (defun assign (name type env) 126 | (multiple-value-bind (found passed-with) (find-in-env env name) 127 | (when found 128 | (etypecase type 129 | (tc (link-tc (var-tc found) type)) 130 | (symbol (add-type (var-tc found) type))) 131 | (let ((initialized (or (and (var-init found) t) (not passed-with)))) 132 | (when (or (not (eq (var-init found) initialized)) 133 | (var-delayed-function found)) 134 | (setf env (update-env env found initialized ()))))) 135 | env)) 136 | 137 | ;; Compute the various type-cell relations. 138 | (defun compute-rel (type a b) 139 | (ecase type 140 | (:and a) ;; used by link-tc 141 | (:+ ;; the interesting effects of the + operator 142 | (cond ((or (eq a :string) (eq b :string)) :string) 143 | ((or (member a '(t :object)) (member b '(t :object))) t) 144 | ((and (eq a :integer) (eq b :integer)) :integer) 145 | ((or (not a) (not b)) nil) ;; Will be recomputed later 146 | (t :number))) 147 | (:either (combine-types a b)) 148 | (:maybe-int ;; result of other numeric operations 149 | (cond ((eq b :none) (case a (:integer :integer) ((nil) nil) (t :number))) 150 | ((and (eq a :integer) (eq b :integer)) :integer) 151 | ((or (not a) (not b)) nil) 152 | (t :number))))) 153 | 154 | ;; 'Resolve' a type-cell, computing its final type from its current 155 | ;; type and its relations. Done in a second pass after inference has 156 | ;; completed. 157 | (defun resolve-tc (tc) 158 | ;; Solves a system of dependencies by iterating until no more 159 | ;; changes are produced. Since types always become looser, never 160 | ;; stricter, this terminates. 161 | (labels ((apply-rel (tc rel) 162 | (let* ((result (compute-rel (car rel) (resolve-tc (second rel)) 163 | (if (third rel) (resolve-tc (third rel)) :none))) 164 | (combined (combine-types result (tc-tp tc)))) 165 | (unless (eq combined (tc-tp tc)) 166 | (setf (tc-tp tc) combined) 167 | (loop :for (tc . rel) :in (tc-deps tc) :do 168 | (apply-rel tc rel)))))) 169 | (when (eq (tc-tp tc) t) (return-from resolve-tc t)) 170 | (let ((rels (or (tc-rels tc) (return-from resolve-tc (tc-tp tc))))) 171 | (setf (tc-rels tc) nil) 172 | (loop :for rel :in rels :while (not (eq (tc-tp tc) t)) :do 173 | (push (cons tc rel) (tc-deps (second rel))) 174 | (unless (or (not (third rel)) (eq (third rel) (second rel))) 175 | (push (cons tc rel) (tc-deps (third rel)))) 176 | (apply-rel tc rel)) 177 | (tc-tp tc)))) 178 | 179 | (defstruct typing val) ;; Used in returned ast 180 | (defun resolve-tcs (ast) 181 | (labels ((resolve (val) 182 | (typecase val 183 | (cons (map-into val #'resolve val)) 184 | (tc (make-typing :val (or (resolve-tc val) t))) 185 | (t val)))) 186 | (resolve ast))) 187 | 188 | ;; API to the inferrer. Tags the given ast. 189 | (defun infer-types (ast) 190 | (infer ast ()) 191 | (resolve-tcs ast)) 192 | 193 | ;; Access the type of a tagged AST element. 194 | (defun ast-type (ast) 195 | (let ((maybe (car (last ast)))) 196 | (and (typing-p maybe) (typing-val maybe)))) 197 | (defun num-type (type) 198 | (or (eq type :number) (eq type :integer))) 199 | 200 | ;; This is later defined for all possible elements in the AST. Returns 201 | ;; (values env [tc] [ft]), where only expressions should return a tc, 202 | ;; and only things that return a function that we are trying to 203 | ;; statically analyse should return an ft. 204 | (defgeneric apply-infer-rule (ast-tag ast-args env)) 205 | (defmacro definfer ((type &rest args) &body body) 206 | (let ((form-arg (gensym))) 207 | `(defmethod apply-infer-rule ((,(gensym) (eql ,type)) ,form-arg env) 208 | (destructuring-bind (,@args &rest ,form-arg) ,form-arg 209 | (declare (ignore ,form-arg)) 210 | ,@body)))) 211 | 212 | ;; Call the apply-infer-rule method for the ast element, and then tags 213 | ;; the ast with the tc for that expression, if a tc was returned. 214 | (defun infer (form env &optional context) 215 | (multiple-value-bind (env tc ftype) (apply-infer-rule (car form) (cdr form) env) 216 | ;; If an ftype is used in a non-call context, we can no longer 217 | ;; guarantee how it will be called, so the argtypes have to be 218 | ;; cleared. This is a bit of a hack---the whole function analysis 219 | ;; is, in fact, a hack. 220 | (when (and ftype (not (eq context :call))) 221 | (dolist (arg (ft-args ftype)) (add-type arg t)) 222 | (setf ftype nil)) 223 | ;; Tag the AST list by adding an extra element (if it doesn't 224 | ;; exist yet, since sometimes inner functions are inferred 225 | ;; multiple times). 226 | (when tc 227 | (let ((last (last form))) 228 | (unless (tc-p (car last)) 229 | (setf (cdr last) (list tc))))) 230 | (values env tc ftype))) 231 | 232 | ;; Used to hold the (arg-tcs . return-tc) for the current function, 233 | ;; since some of the methods need direct access to those. 234 | (defparameter *function-tcs* nil) 235 | 236 | ;; See if a function may fall off its end without returning, since 237 | ;; that is relevant for the return type we assign to it. This isn't 238 | ;; always correct (there are many complicated ways in which a function 239 | ;; can guarantee returning), but works for basic cases. 240 | (defun may-fall-off (fbody) 241 | (labels ((see-body (stats) 242 | (see (car (last stats)))) 243 | (see (stat) 244 | (case (car stat) 245 | ((nil :for :for-in :do :while :stat :break 246 | :continue :defun :var :switch) t) 247 | ((:return :throw) nil) 248 | (:if (or (not (fourth stat)) (see (third stat)) (see (fourth stat)))) 249 | (:with (see (third stat))) 250 | (:block (see-body (second stat))) 251 | (:try (and (or (not (fourth stat)) (see (fourth stat))) 252 | (or (not (third stat)) (see (second stat)) (see (third stat)))))))) 253 | (see-body fbody))) 254 | 255 | ;; Sets up the scope for a function, and infers it in this scope. 256 | (defun infer-func (fname args body env) 257 | (let ((locals (find-locals body `("this" "arguments" ,@args 258 | ,@(and fname (list fname))))) 259 | (ret-tc (tc ())) 260 | (arg-tcs (loop :repeat (length args) :collect (tc ())))) 261 | (multiple-value-bind (defuns body) (split-out-defuns body) 262 | (when (may-fall-off body) (add-type ret-tc :undefined)) 263 | (let* ((*function-tcs* (cons arg-tcs ret-tc)) 264 | tmp 265 | (ft (make-ft :args arg-tcs :returns ret-tc)) 266 | ;; The new scope list 267 | (sc (loop :for name :in locals :collect 268 | (cond ((string= name "this") (list t nil name (tc :object))) 269 | ;; defuns get some magic to store them as delayed functions, 270 | ;; and to be able to keep their ftype 271 | ((setf tmp (find name defuns :key #'second :test #'string=)) 272 | (list (list nil) (cons :function (cdr tmp)) name (tc :object))) 273 | ((equal name fname) 274 | (list (list ft) nil name (tc :object))) 275 | ;; arguments 276 | ((setf tmp (position name args :test #'string=)) 277 | (list t nil name (nth tmp arg-tcs))) 278 | ((string= name "arguments") (list t nil name (tc :object))) 279 | (t (list nil nil name (tc ())))))) 280 | (env (cons sc env))) 281 | (dolist (stat body) (setf env (infer stat env))) 282 | (values (pop-scope env) ft))))) 283 | 284 | ;; Note that definfer automatically adds an env parameter to each of 285 | ;; these methods. 286 | (definfer (:function name args body) 287 | (multiple-value-bind (env ftype) (infer-func name args body env) 288 | (values env (tc :object) ftype))) 289 | ;; This is only invoked for defuns that are not at the top-level of a 290 | ;; function. Those are hoisted to the top of the function, and handled 291 | ;; more cleverly. 292 | (definfer (:defun name args body) 293 | (setf env (assign name :object env)) 294 | (multiple-value-bind (env ftype) (infer-func nil args body env) 295 | (dolist (tc (ft-args ftype)) (add-type tc t)) 296 | env)) 297 | (definfer (:atom atom) 298 | (values env (case atom 299 | ((:true :false) (tc :boolean)) 300 | (:null (tc :null)) 301 | (t (tc t))))) 302 | (definfer (:object props) 303 | (loop :for (nil . val) :in props :do 304 | (setf env (infer (if (member (car val) '(:get :set)) (cdr val) val) env))) 305 | (values env (tc :object))) 306 | (definfer (:regexp) 307 | (values env (tc :object))) 308 | (definfer (:label name form) 309 | (declare (ignore name)) 310 | (values (infer form env))) 311 | (definfer (:var bindings) 312 | (loop :for (name . val) :in bindings :do 313 | (when val 314 | (multiple-value-bind (env1 tc) (infer val env) 315 | (setf env (assign name tc env1))))) 316 | env) 317 | (definfer (:name name) 318 | ;; Stuff like arguments[1] = null can mess with argument types, so 319 | ;; we clear those at the first sign of trouble. 320 | (when (string= name "arguments") 321 | (dolist (tc (car *function-tcs*)) (add-type tc t))) 322 | (multiple-value-bind (var passed-with) (find-in-env env name) 323 | (if var 324 | ;; For local variables, stuff gets complicated... 325 | (let* ((update nil) 326 | (init (var-init var)) 327 | ;; For locals that hold a function, the init value is a 328 | ;; cons, and its car is the ft structure for this 329 | ;; function. Ergh. 330 | (ftype (and (consp init) (car init)))) 331 | ;; If this is not initialized yet, it is used before 332 | ;; initialization, and :undefined is added to the type. 333 | (unless init 334 | (add-type (var-tc var) :undefined) 335 | (setf update t)) 336 | ;; When a delayed function is present, infer it in this 337 | ;; environment. Also, if we don't have an ftype yet, use the 338 | ;; one returned by this infer call. 339 | (when (var-delayed-function var) 340 | (multiple-value-bind (env1 tc ftype1) 341 | (infer (var-delayed-function var) env :call) 342 | (declare (ignore tc)) 343 | (setf env env1) 344 | (unless ftype (setf ftype (setf (car init) ftype1)))) 345 | (setf update t)) 346 | ;; Update the env if anything was changed. 347 | (values (if update (update-env env var init nil) env) 348 | ;; If the lookup passed a with environment, we can't 349 | ;; say anything about the type. 350 | (if passed-with (tc t) (var-tc var)) 351 | ftype)) 352 | ;; Global variables are unknowable. 353 | (values env (tc t))))) 354 | (definfer (:num num) 355 | (values env (tc (if (typep num 'fixnum) :integer :number)))) 356 | (definfer (:toplevel body) 357 | (dolist (stat body) (setf env (infer stat env))) 358 | env) 359 | (definfer (:assign op place val) 360 | (unless (eq (car place) :name) (setf env (infer place env))) 361 | (multiple-value-bind (env tc) 362 | (infer (if (eq op t) val `(:binary ,op ,place ,val)) env) 363 | (when (eq (car place) :name) 364 | (setf env (assign (second place) tc env))) 365 | (values env tc))) 366 | (definfer (:stat form) 367 | (values (infer form env))) 368 | (definfer (:string) 369 | (values env (tc :string))) 370 | (definfer (:return value) 371 | (multiple-value-bind (env tc) (if value (infer value env) env) 372 | (when *function-tcs* 373 | (if tc 374 | (link-tc (cdr *function-tcs*) tc) 375 | (add-type (cdr *function-tcs*) :undefined))) 376 | env)) 377 | (definfer (:for init cond step body) 378 | (when init (setf env (infer init env))) 379 | (let ((env2 env)) 380 | (when cond (setf env (infer cond env))) 381 | (when step (setf env (infer step env))) 382 | (merge-env env2 (infer body env)))) 383 | (definfer (:while cond body) 384 | (merge-env env (infer body (infer cond env)))) 385 | (definfer (:do cond body) 386 | (merge-env env (infer cond (infer body env)))) 387 | (definfer (:for-in init lhs obj body) 388 | (when init (setf env (infer init env))) 389 | (setf env (infer obj env)) 390 | (when (eq (car lhs) :name) 391 | (setf env (assign (second lhs) :string env))) 392 | (merge-env env (infer body env))) 393 | (definfer (:switch expr cases) 394 | (setf env (infer expr env)) 395 | (loop :for (val . body) :in cases :do 396 | (when val (setf env (infer val env))) 397 | (dolist (stat body) 398 | (setf env (infer stat env)))) 399 | env) 400 | (definfer (:if test then else) 401 | (setf env (infer test env)) 402 | (merge-env (infer then env) (if else (infer else env) env))) 403 | (definfer (:conditional test then else) 404 | (setf env (infer test env)) 405 | (multiple-value-bind (env1 tc1) (infer then env) 406 | (multiple-value-bind (env2 tc2) (infer else env) 407 | (let ((tc (tc ()))) 408 | (link-tc tc tc1) (link-tc tc tc2) 409 | (values (merge-env env1 env2) tc))))) 410 | (definfer (:try body catch finally) 411 | (let ((catch-env (if catch 412 | (let ((env (cons `((t nil ,(car catch) ,(tc t))) env))) 413 | (pop-scope (infer (cdr catch) env))) 414 | env))) 415 | (setf env (merge-env (infer body env) catch-env)) 416 | (if finally (infer finally env) env))) 417 | (definfer (:throw expr) 418 | (values (infer expr env))) 419 | (definfer (:with obj body) 420 | (pop-scope (infer body (infer obj (cons :with env))))) 421 | (definfer (:new func args) 422 | (setf env (infer func env)) 423 | (dolist (arg args) 424 | (setf env (infer arg env))) 425 | (values env (tc :object))) 426 | (definfer (:call func args) 427 | (if (ast-is-eval-var func) 428 | ;; Eval might screw up every visible local variable. 429 | (progn (ruin-env-for-eval env) (values env (tc t))) 430 | (multiple-value-bind (env ftc ftype) (infer func env :call) 431 | (declare (ignore ftc)) 432 | ;; Infer the arguments, linking the arg type-cells for this 433 | ;; function (if any) to the results. 434 | (loop :for arg-tc := (and ftype (ft-args ftype)) :then (cdr arg-tc) 435 | :for arg :in args :do 436 | (multiple-value-bind (env1 tc) (infer arg env) 437 | (setf env env1) 438 | (when arg-tc (link-tc (car arg-tc) tc))) 439 | :finally (dolist (tc arg-tc) (add-type tc :undefined))) 440 | (values env (if ftype (ft-returns ftype) (tc t)))))) 441 | (definfer (:binary op lhs rhs) 442 | (multiple-value-bind (env lhst) (infer lhs env) 443 | (multiple-value-bind (env rhst) (infer rhs env) 444 | (values env 445 | (case op 446 | (:+ (tc nil `(:+ ,lhst ,rhst))) 447 | ((:== :=== :!= :!== :instanceof :in :< :> :<= :>=) (tc :boolean)) 448 | ((:^ :& :|\|| :>> :<< :>>>) (tc :integer)) 449 | ((:&& :|\|\||) (tc nil `(:either ,lhst ,rhst))) 450 | ((:- :* :%) (tc nil `(:maybe-int ,lhst ,rhst))) 451 | (:/ (tc :number))))))) 452 | (definfer (:unary-prefix op place) 453 | (multiple-value-bind (env argt) (infer place env) 454 | (ecase op 455 | (:typeof (values env (tc :string))) 456 | (:void (values env (tc :undefined))) 457 | ((:delete :!) (values env (tc :boolean))) 458 | ((:-- :++) (let ((tc (tc nil `(:maybe-int ,argt)))) 459 | (when (eq (car place) :name) 460 | (setf env (assign (second place) tc env))) 461 | (values env tc))) 462 | (:+ (values env (tc nil `(:maybe-int ,argt)))) 463 | (:- (values env (tc :number))) 464 | (:~ (values env (tc :integer)))))) 465 | (definfer (:unary-postfix op place) 466 | (declare (ignore op)) ;; always :++ or :-- 467 | (multiple-value-bind (env argt) (infer place env) 468 | (when (eq (car place) :name) 469 | (setf env (assign (second place) (tc nil `(:maybe-int ,argt)) env))) 470 | (values env argt))) 471 | (definfer (:array elems) 472 | (dolist (elem elems) (when elem (setf env (infer elem env)))) 473 | (values env (tc :object))) 474 | (definfer (:block forms) 475 | (dolist (stat forms) (setf env (infer stat env))) 476 | env) 477 | (definfer (:seq form1 result) 478 | (infer result (infer form1 env))) 479 | (definfer (:dot obj) 480 | (values (infer obj env) (tc t))) 481 | (definfer (:sub obj attr) 482 | (values (infer attr (infer obj env)) (tc t))) 483 | (definfer (:break) 484 | env) 485 | (definfer (:continue) 486 | env) 487 | -------------------------------------------------------------------------------- /index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | CL-JavaScript 5 | 18 | 19 | 20 | 21 |
22 |

CL-JavaScript

23 | 24 |

JavaScript is the new BASIC—a universal scripting language. 25 | CL-JavaScript allows you to add user scripting to your Common Lisp 26 | application without requiring your poor users to learn Common Lisp. 27 | It is a JavaScript to Common Lisp translator, runtime, and standard 28 | library. We are ECMAScript 29 | 3 compatible, with some of the ECMAScript 5 extensions.

30 | 31 |

By using the Lisp compiler to compile JavaScript (and by using 32 | some clever tricks for the things that Lisp normally isn't good at), 33 | this implementation manages to be faster than most of the 2009 34 | generation of JavaScript engines. The new generation (V8, 35 | Jägermonkey) beats it by, depending on the benchmark, a factor 4 or 36 | so.

37 | 38 |

Contents

39 | 40 | 58 | 59 |

News

60 | 61 |

14-03-2012: Version 62 | 0.12.03: Fix CLISP incompatibility.

63 | 64 |

09-01-2012: Version 65 | 0.12.01: Follow changes 66 | in parse-js, 67 | add Function.prototype.bind, getter/setter support, 68 | small fixes.

69 | 70 |

08-12-2010: Version 72 | 0.10.12: Implements ECMA5-style 74 | array, string, and Object constructor methods, as well 75 | as a JSON object. Rough support for CommonJS 78 | modules. Adds correct length (arity) properties to 79 | function objects.

80 | 81 |

15-11-2010: Version 83 | 0.10.11: The first release on the new project page. Our 84 | API can be considered more or less stable now, and there are no 85 | serious gaps left in our ECMAScript 3 support.

86 | 87 |

15-11-2010: It seems I have finally 88 | documented this library.

89 | 90 |

Code

91 | 92 |

CL-JavaScript was created by Alan Pavičić, Iva Jurišić, and 93 | Marijn Haverbeke. It is released under a MIT-style 94 | licence.

95 | 96 |

Development takes place on github. Any releases we make 98 | are listed under News. The latest release is 99 | always linked from cl-javascript.tgz.

101 | 102 |

Dependencies

103 | 104 |

CL-JavaScript depends on parse-js, CL-PPCRE, and optionally local-time 108 | (you won't have a Date object if your ASDF can not find 109 | local-time).

110 | 111 |

Because emulating IEEE 754 floating point special values 112 | (NaN, Infinity) in software is painfully inefficient, CL-JavaScript 113 | includes some non-portable code to directly use machine floats in 114 | SBCL and Allegro Common Lisp. There is fallback code present for 115 | other implementations, but since the developers don't develop on 116 | those, that might not be very well tested. It is recommended, if you 117 | really want to use the system on another implementation, to try and 118 | add native float support for that implementation.

119 | 120 |

Support

121 | 122 |

When you have a problem, please either open an issue on github, or send the maintainer an e-mail.

125 | 126 |

Quickstart

127 | 128 |

First, load the system:

129 | 130 | 
cl-user> (asdf:oos 'asdf:load-op :cl-js)
131 | cl-user> (use-package :cl-js)
132 | 133 |

We can start a JavaScript REPL to convince ourselves that yes, we 134 | really do have JavaScript in our Common Lisp.

135 | 136 | 
cl-user> (js-repl)
137 | JS repl (#q to quit)
138 | > 1 + 1
139 | 2
140 | > function fac(x) { return x <= 1 ? x : x * fac(x - 1); }
141 | [object Object]
142 | > fac(10)
143 | 3628800
144 | > #q
145 | cl-user>
146 | 147 |

Well, that seems to work. Next up: defining our own library.

148 | 149 | 
cl-user> (defparameter *mylib* (empty-lib))
150 | cl-user> (add-to-lib *mylib*
151 |            (.func "plusOne" (x) (1+ (to-number x)))
152 |            (.object "numbers"
153 |              (.value "one" 1)
154 |              (.value "two" "2")))
155 | cl-user> (with-js-env (*mylib*)
156 |            (run-js "plusOne(numbers.two)"))
157 | 3
158 | 159 |

Note the to-number call. This will invoke 160 | JavaScripts number-conversion. For a library like this, you are, of 161 | course, better off just doing something like this:

162 | 163 | 
cl-user> (run-js "
164 |   function plusOne(x){return x + 1;}
165 |   var numbers = {one: 1, two: '2'};")
166 | 167 |

But, in general, what you want to do is write glue code, 168 | providing a JavaScript API for your application. For this, the 169 | library does its best to provide a practical interface for defining 170 | JavaScript environments.

171 | 172 |

Reference

173 | 174 |

Running Code

175 | 176 |

function run-js (code &key (compile t) wrap-parse-errors optimize)

177 | 178 |

Runs the given code. code can be a 179 | string or a stream. compile and optimize 180 | determine whether the code should be compiled, and if, whether it 181 | should be optimized, before it is run. When 182 | wrap-parse-errors is given, parse errors are wrapped in 183 | js-condition objects, and 184 | can be caught by JavaScript catch forms.

185 | 186 |

function run-js-file (file &key (compile t) wrap-parse-errors optimize external-format)

187 | 188 |

Runs the code from the given file. The keyword 189 | arguments are passed through to run-js, except for 191 | external-format, which is passed to 192 | open.

193 | 194 |

function js-repl (&key (handle-errors t))

195 | 196 |

Starts an interactive JavaScript REPL. If 197 | handle-errors is t, all errors will be 198 | caught and printed. If it is nil, all errors are let 199 | through. If it has any other value, only errors of type js-condition are handled and 201 | printed.

202 | 203 |

JavaScript Values

204 | 205 |

Values in a JavaScript environment are represented as 206 | follows:

207 | 208 |

null and undefined are the Lisp 209 | keywords :null and :undefined. The type 210 | js-null is provided, which includes both these values. 211 | js-null is also a predicate function (shortcut for 212 | (typep x 'js-null)).

213 | 214 |

Booleans are Lisp booleans (nil and t).

215 | 216 |

Numbers are represented as Lisp numbers (integers and 217 | double-floats). On implementations where no support for representing 218 | NaN and Infinity as floats has been added, these are represented by 219 | the values :NaN, :Inf, and 220 | :-Inf. The js-number type helps abstract 221 | this—matching only numbers on those implementations where no 222 | keywords are needed, and both numbers and these three keywords on 223 | others.

224 | 225 |

The macros nan, infinity, and 226 | -infinity are provided to create special number values. 227 | The predicate is-nan can be used to check whether a 228 | value is NaN.

229 | 230 |

Strings are plain Lisp strings.

231 | 232 |

Objects are a custom struct type—js-obj. The 233 | js-func and js-array types are subtypes of 234 | this.

235 | 236 |

function js-obj (&optional prototype type)

237 | 238 |

Creates a JavaScript object. Optionally, a prototype 239 | id (more about that later) or prototype 240 | object, and a type (as 241 | in define-js-obj) can be 242 | given.

243 | 244 |

function js-prop (obj propname)

245 | 246 |

Retrieves a property from an object. A 247 | setf variant is provided for setting properties.

248 | 249 |

function js-array (vector)

250 | 251 |

Creates a new JavaScript array. vector 252 | must be an adjustable vector with a fill pointer.

253 | 254 |

function js-array-length (array)

255 | 256 |

Retrieve the length of a JavaScript array.

257 | 258 |

function js-aref (array index)

259 | 260 |

Access an element in an array. There is a 261 | setf variant as well.

262 | 263 |

macro js-call (func this &rest args)

264 | 265 |

Call a JavaScript function value.

266 | 267 |

macro js-method (object name &rest args)

268 | 269 |

Call a method in a JavaScript object.

270 | 271 |

macro js-func (args &body body)

272 | 273 |

Creates a JavaScript function object from a 274 | lambda-like specification. Inside the body 275 | this will be bound, in addition to the specified 276 | arguments. The argument list is mangled to conform to JavaScript 277 | calling conventions—each paramter will become optional, with an 278 | implicit default of :undefined, unless you specify your 279 | own default. A &rest clause is allowed, but 280 | &key and &optional can't be 281 | used.

282 | 283 |

Exceptions

284 | 285 |

JavaScript exceptions are raised as Lisp conditions of the 286 | js-condition type. A JavaScript catch 287 | block will catch these (and only these).

288 | 289 |

method js-condition-value (condition)

290 | 291 |

Returns the JavaScript value associated with the 292 | given condition.

293 | 294 |

function js-error (type message &rest args)

295 | 296 |

Raises a JavaScript error (value of type 297 | Error) . type must be prototype id 298 | (:error, :type-error, 299 | :syntax-error, :range-error, 300 | :uri-error, and :eval-error are provided 301 | by the standard lib). message can be a format string 302 | into which args will be interpolated.

303 | 304 |

The Environment

305 | 306 |

variable *env*

307 | 308 |

The variable that holds the current environment. 309 | Starts out unbound (though run-js 310 | and js-repl will give it a 311 | default value automatically when they find it unbound).

312 | 313 |

macro with-js-env ((&rest libraries) &body body)

314 | 315 |

Runs body with *env* bound to a fresh environment, 317 | which was created by loading the standard library plus the given 318 | libraries.

319 | 320 |

function create-env (&rest libraries)

321 | 322 |

Creates a new environment, loading the given libraries.

323 | 324 |

function add-to-env (env &rest libraries)

325 | 326 |

Extends env with the given libraries, 327 | then returns it.

328 | 329 |

Utilities

330 | 331 |

macro void (&body body)

332 | 333 |

Executes the body, returns 334 | :undefined.

335 | 336 |

337 | function to-string (value)
338 | function to-number (value)
339 | function to-integer (value)
340 | function to-boolean (value)

341 | 342 |

Invokes the standard JavaScript type conversion 343 | algorithm on the given value.

344 | 345 |

Library Definition

346 | 347 |

CL-JavaScript works with first-class libraries. These are 348 | specifications of a set of variables, prototypes, and constructors 349 | that can be instantiated into an environment to make their 350 | definitions available there.

351 | 352 |

function empty-lib (&optional name)

353 | 354 |

Returns a fresh, empty library specification object. 355 | The name is only used for the printed representation of the object.

356 | 357 |

macro add-to-lib (lib &body body)

358 | 359 |

Add the definitions found in body to 360 | the given library.

361 | 362 |

Defining the content of a library is done with a family of macros 363 | starting with a period. These all take a &body in 364 | which lists starting with a keyword can be used to set options. For 365 | example:

366 | 367 | 
(.object "Math"
368 |   (:slot-default :noenum)
369 |   (.value "E" (exp 1)))
370 | 371 |

Here, the :slot-default option is given, causing all 372 | slots defined in the Math object to not be enumerable.

373 | 374 |

All defining forms that allow slots to be defined inside of them 375 | accept the :slot-default option. All forms that define 376 | slots accept the :slot option. Both of these expect a 377 | list of keywords (:enum, :noenum, 378 | :ro, :rw, :del, 379 | :nodel) which specify slot properties (enumerabe, 380 | read-only, and deletable). Properties that are not specified are 381 | inherited from the context (as an under-the-covers special 382 | variable). By default, properties are enumerable, read-write, and 383 | deletable, except in prototypes, where they are not enumerable.

384 | 385 |

macro .prototype (id &body body)

386 | 387 |

Creates a new prototype and associates it with the 388 | given ID. All non-option forms appearing in the body are evaluated, 389 | and can add properties to the prototpe. A :parent 390 | option (which should hold a prototype-id) can be used to make this 391 | prototype inherit from another prototype.

392 | 393 |

macro .constructor (name args &body body)

394 | 395 |

Declares a constructor with the given argument list 396 | (interpreted as in js-func) and 397 | body. A :prototype option may appear in the body, and 398 | is used to determine what prototype objects created with this 399 | constructor should get. If it holds a keyword, that is the ID of the 400 | prototype to use, if it holds a list of slot definitions, a new prototype 401 | object is created and given those slots.

402 | 403 |

If this constructor should not create regular 404 | objects, you can give it a :type option containing the 405 | name of a type defined with define-js-obj. When the 407 | constructor is invoked with new, you will then get an 408 | object of that type as this variable, rather than a 409 | plain object.

410 | 411 |

Finally, a :properties option can be 412 | passed, within which properties for the constructor itself can be 413 | defined (as in String.fromCharCode).

414 | 415 |

macro .value (name &body value)

416 | 417 |

Defines a simple value property. When this appears 418 | at the top level, it defines a global variable. When it appears 419 | inside another form, it adds a property to that definition.

420 | 421 |

macro .object (name &body body)

422 | 423 |

This defines an object property. The 424 | body contains property definitons for this object, and 425 | optionally a :parent option, as in .prototype, to give the object a 427 | specific prototype.

428 | 429 |

macro .func (name args &body body)

430 | 431 |

Adds a function (top-level) or method. 432 | args is an argument list as in js-func. The given body becomes the 434 | body of the function. A :properties option can be used 435 | to give the function object itself properties.

436 | 437 |

macro .active (name &body body)

438 | 439 |

This macro is used to add 'active' properties to 440 | objects. Active properties are things that can be approached like 441 | regular properties, but execute some function when read or written. 442 | The :read and :write options can be used 443 | to specify the bodies of the functions, like this:

444 | 445 | 
(.active "preciousProperty"
446 |   (:read () "my precious!")
447 |   (:write (value) (js-error :error "How dare you touch my precious!")))
448 | 449 |

(The argument lists are compulsory, even though they are always 450 | the same.)

451 | 452 |

macro .active-r (name &body body)

453 | 454 |

This is a shortcut for an .active property with only a 456 | :read entry (meaning writes to the slot will be 457 | ignored).

458 | 459 |

The following two macros should not be used inside library 460 | definitions, but at the top level (they are global in their 461 | effect).

462 | 463 |

macro define-js-obj (name &body slots)

464 | 465 |

Defines a struct type fit for holding JavaScript 466 | object values. The way to use this is to specify the type name you 467 | use here as the :type option of a .constructor form, and then 469 | fill in your custom slots in this constructor.

470 | 471 |

macro integrate-type (specializer &body options)

472 | 473 |

A type defined by define-js-obj is a 'real' 475 | JavaScript object, to which clients can add properties. Sometimes, 476 | it is preferable to use Lisp objects 'as they are', because wrapping 477 | is too expensive. This macro allows you to do that.

478 | 479 |

To be able to use a value as a JavaScript value, a 480 | bunch of methods have to specialized on it, so that JavaScript 481 | operations (typeof, String(x)) will know 482 | what to do with it.

483 | 484 |

specializer should be a valid method 485 | specializer that can be used to recognize the type you want to 486 | integrate.

487 | 488 |

All options appearing under this macro can take 489 | either the form of a single value, or an argument list (of a single 490 | symbol) and then a body. The :string option determines 491 | how the type is converted to string (default is "[object 492 | Object]"). The :number option converts to 493 | numbers (default NaN). The :boolean option 494 | to booleans (default true). typeof is used 495 | to determine the string returned by the typeof operator 496 | (default "foreign"). When a :proto-id form 497 | is given, it is used to locate a prototype in which properties for 498 | these values are looked up.

499 | 500 |

An example:

501 | 502 | 
(integrate-type complex
503 |   (:number (val) (realpart val))
504 |   (:string (val) (format nil "~a+~ai" (realpart val) (imagpart val)))
505 |   (:typeof "complex")
506 |   (:proto-id :number)) ;; or add a custom prototype
507 | 
508 | /* ... and in your library ... */
509 | (.func "complex" (real imag)
510 |   (complex (to-number real) (to-number imag)))
511 | 512 |

Provided Libraries

513 | 514 |

variable *printlib*

515 | 516 |

A tiny library value containing only a 517 | print function, which will write its arguments to 518 | *standard-output*.

519 | 520 |

function requirelib (hook)

521 | 522 |

When called, returns a library object that 523 | implements the CommonJS-style require operator. 524 | hook should be a funcallable object which, given a 525 | string, verifies that string as a module specifier, and returns a 526 | pathname under which the module text can be found. Or, if you need 527 | modules that aren't simply files, it can return two values—a 528 | canonical module identifier (must be comparable with 529 | equal) and a function that, given this identifier, 530 | returns either a stream or a string containing the module's 531 | text.

532 | 533 |

A trivial hook (without error-checking or safety) 534 | could simply do (merge-pathnames spec 535 | "/my/script/dir/x.js"). If you do want to do error-checking, 536 | use js-error to complain when a 537 | specifier is not acceptable.

538 | 539 |

Note that CL-JavaScript's implementation of CommonJS 540 | modules does not sandbox the modules in any serious way—it simply 541 | wraps them in a function. This means that direct, 542 | var-less assignments will create top-level 543 | variables, and the module can mangle existing values (say, 544 | Object.prototype) all it wants. For well-behaved 545 | modules, this shouldn't be an issue.

546 | 547 |
548 | 549 | -------------------------------------------------------------------------------- /translate.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-js) 2 | 3 | (defvar *scope* ()) 4 | (defparameter *label-name* nil) 5 | (defvar *break* ()) 6 | (defvar *continue* ()) 7 | (defvar *symbol-table*) 8 | 9 | (defun as-sym (name) 10 | (or (gethash name *symbol-table*) 11 | (setf (gethash name *symbol-table*) (make-symbol name)))) 12 | 13 | (defgeneric lookup-variable (name scope rest)) 14 | (defgeneric set-variable (name valname scope rest)) 15 | 16 | (defmethod lookup-variable (name (scope null) rest) 17 | (declare (ignore rest)) 18 | (expand-global-lookup name)) 19 | (defmethod set-variable (name valname (scope null) rest) 20 | (declare (ignore rest)) 21 | (expand-global-set name valname)) 22 | 23 | (defstruct with-scope var) 24 | (defmethod lookup-variable (name (scope with-scope) rest) 25 | (let ((found (gensym))) 26 | `(if-not-found (,found ,(expand-cached-lookup (with-scope-var scope) name)) 27 | ,(lookup-variable name (car rest) (cdr rest)) 28 | (values ,found ,(with-scope-var scope))))) 29 | (defmethod set-variable (name valname (scope with-scope) rest) ;; TODO hasOwnProperty? 30 | `(if-not-found (nil ,(expand-cached-lookup (with-scope-var scope) name)) 31 | ,(set-variable name valname (car rest) (cdr rest)) 32 | ,(expand-cached-set (with-scope-var scope) name valname))) 33 | 34 | (defstruct simple-scope vars) 35 | (defmethod lookup-variable (name (scope simple-scope) rest) 36 | (let ((sym (as-sym name))) 37 | (if (member sym (simple-scope-vars scope)) 38 | sym 39 | (lookup-variable name (car rest) (cdr rest))))) 40 | (defmethod set-variable (name valname (scope simple-scope) rest) 41 | (let ((sym (as-sym name))) 42 | (if (member sym (simple-scope-vars scope)) 43 | `(setf ,sym ,valname) 44 | (set-variable name valname (car rest) (cdr rest))))) 45 | 46 | (defstruct (arguments-scope (:include simple-scope)) args) 47 | (defmethod lookup-variable (name (scope arguments-scope) rest) 48 | (declare (ignore rest)) 49 | (if (member (as-sym name) (arguments-scope-args scope)) 50 | `(car ,(as-sym name)) 51 | (call-next-method))) 52 | (defmethod set-variable (name valname (scope arguments-scope) rest) 53 | (declare (ignore rest)) 54 | (if (member (as-sym name) (arguments-scope-args scope)) 55 | `(setf (car ,(as-sym name)) ,valname) 56 | (call-next-method))) 57 | 58 | (defstruct captured-scope vars local-vars objs next) 59 | (defun capture-scope () 60 | (let ((varnames ()) 61 | (val-arg (gensym)) 62 | (locals :null) 63 | (objs ()) 64 | (next nil)) 65 | (dolist (level *scope*) 66 | (typecase level 67 | (simple-scope 68 | (setf varnames (union varnames (simple-scope-vars level))) 69 | (when (eq locals :null) (setf locals (mapcar 'symbol-name (simple-scope-vars level))))) 70 | (with-scope (push (with-scope-var level) objs)) 71 | (captured-scope (setf next level)))) 72 | `(make-captured-scope 73 | :vars (list ,@(loop :for var :in varnames :for name := (symbol-name var) :collect 74 | `(list ',name (lambda () ,(lookup-var name)) 75 | (lambda (,val-arg) ,(set-in-scope name val-arg))))) 76 | :local-vars ',locals :objs (list ,@(nreverse objs)) :next ,next))) 77 | (defun lookup-in-captured-scope (name scope) 78 | (let ((var (assoc name (captured-scope-vars scope) :test #'string=))) 79 | (if var 80 | (funcall (second var)) 81 | (loop :for obj :in (captured-scope-objs scope) :do 82 | (if-not-found (val (js-prop obj name)) 83 | nil 84 | (return val)) 85 | :finally (return (if (captured-scope-next scope) 86 | (lookup-in-captured-scope name (captured-scope-next scope)) 87 | (global-lookup name))))))) 88 | (defmethod lookup-variable (name (scope captured-scope) rest) 89 | (declare (ignore rest)) 90 | `(lookup-in-captured-scope ,name ,scope)) 91 | (defun set-in-captured-scope (name value scope) 92 | (let ((var (assoc name (captured-scope-vars scope) :test #'string=))) 93 | (if var 94 | (funcall (third var) value) 95 | (loop :for obj :in (captured-scope-objs scope) :do 96 | (if-not-found (nil (js-prop obj name)) 97 | nil 98 | (return (setf (js-prop obj name) value))) 99 | :finally (if (captured-scope-next scope) 100 | (set-in-captured-scope name value (captured-scope-next scope)) 101 | (setf (js-prop *env* name) value)))))) 102 | (defmethod set-variable (name valname (scope captured-scope) rest) 103 | (declare (ignore rest)) 104 | `(set-in-captured-scope ,name ,valname ,scope)) 105 | 106 | (defun lookup-var (name) 107 | (lookup-variable name (car *scope*) (cdr *scope*))) 108 | (defun set-in-scope (name value &optional is-defun) 109 | (let ((valname (gensym)) 110 | (scopes (if is-defun (remove-if (lambda (s) (typep s 'with-scope)) *scope*) *scope*))) 111 | `(let ((,valname ,value)) 112 | ,(set-variable name valname (car scopes) (cdr scopes))))) 113 | 114 | (defmacro with-scope (local &body body) 115 | `(let ((*scope* (cons ,local *scope*))) ,@body)) 116 | 117 | (defun in-function-scope-p () ;; TODO do not count catch scopes 118 | (some (lambda (s) (typep s 'simple-scope)) *scope*)) 119 | 120 | (let ((integers-are-fixnums 121 | (and (>= most-positive-fixnum (1- (expt 2 53))) 122 | (<= most-negative-fixnum (- (expt 2 53)))))) 123 | (defun inferred-type-to-lisp-type (type) 124 | (case type 125 | (:integer (if integers-are-fixnums 'fixnum 'integer)) 126 | (:number 'number)))) 127 | 128 | (defun translate (form) 129 | (let ((result (apply-translate-rule (car form) (cdr form))) 130 | (typing (ast-type form))) 131 | (if (and typing (setf typing (inferred-type-to-lisp-type typing))) 132 | `(the ,typing ,result) 133 | result))) 134 | (defun translate-ast (ast) 135 | (let ((*symbol-table* (make-hash-table :test 'equal))) 136 | (translate (infer-types ast)))) 137 | 138 | (defmacro deftranslate ((type &rest arguments) &body body) 139 | (let ((form-arg (gensym))) 140 | `(defmethod apply-translate-rule ((,(gensym) (eql ,type)) ,form-arg) 141 | (destructuring-bind (,@arguments &rest rest) ,form-arg 142 | (declare (ignore rest)) ,@body)))) 143 | 144 | (defgeneric apply-translate-rule (keyword form) 145 | (:method (keyword form) 146 | (declare (ignore keyword)) 147 | (mapcar #'translate form))) 148 | 149 | (deftranslate (nil) nil) 150 | 151 | (deftranslate (:atom atom) 152 | (case atom 153 | (:true t) 154 | (:false nil) 155 | (t atom))) 156 | 157 | (deftranslate (:dot obj attr) 158 | (expand-cached-lookup (translate obj) attr)) 159 | 160 | (deftranslate (:sub obj attr) 161 | `(js-prop ,(translate obj) ,(translate attr))) 162 | 163 | (deftranslate (:var bindings) 164 | `(progn ,@(loop :for (name . val) :in bindings :collect 165 | (cond (val (set-in-scope name (translate val))) 166 | ((not *scope*) `(if-not-found (nil (js-prop *env* ,name)) 167 | (setf (js-prop *env* ,name) :undefined) 168 | :undefined)) 169 | (t :undefined))))) 170 | 171 | (deftranslate (:object properties) 172 | (let ((props ())) 173 | (loop :for (name . val) :in properties :do 174 | (let* ((name (to-string name)) 175 | (found (assoc name props :test #'string=))) 176 | (if (member (car val) '(:get :set)) 177 | (let ((func (translate-internal-function (fourth val) (fifth val)))) 178 | (if (and found (consp (cdr found)) (eq (second found) :active)) 179 | (case (car val) (:get (setf (third found) func)) (:set (setf (fourth found) func))) 180 | (let ((val (case (car val) 181 | (:get (list :active func nil)) 182 | (:set (list :active '(lambda (this) (declare (ignore this)) :undefined) func))))) 183 | (if found (setf (cdr found) val) (push (cons name val) props))))) 184 | (if found 185 | (setf (cdr found) (translate val)) 186 | (push (cons name (translate val)) props))))) 187 | (expand-static-obj '(find-proto :object) props))) 188 | 189 | (deftranslate (:regexp expr flags) 190 | `(load-time-value (new-regexp ,expr ,flags))) 191 | 192 | (defmacro extend-label (var (name &rest expr) &body body) 193 | `(let ((,var (cons (cons ,name (lambda () ,@expr)) ,var))) ,@body)) 194 | 195 | (deftranslate (:label name form) 196 | (if (member (car form) '(:for :for-in :switch :do :while)) 197 | ;; These handle their own label 198 | (let ((*label-name* name)) (translate form)) 199 | (let ((block (gensym))) 200 | (extend-label *break* (name `(return-from ,block :undefined)) 201 | `(block ,block ,(translate form)))))) 202 | 203 | ;; Used in ,@ 204 | (defun translate@ (form) 205 | (and form (list (translate form)))) 206 | 207 | (defmacro with-label (var &body body) 208 | `(let ((,var *label-name*) 209 | (*label-name* nil)) 210 | ,@body)) 211 | 212 | (defun translate-for (init cond step body) 213 | (with-label label 214 | (let ((continued nil) 215 | (break-block (gensym)) 216 | (retval (gensym)) 217 | translated-body) 218 | (extend-label *break* (label `(return-from ,break-block)) 219 | (extend-label *continue* (label `(go ,(setf continued (or continued (gensym))))) 220 | (setf translated-body (translate body)))) 221 | `(let ((,retval :undefined)) 222 | (block ,break-block 223 | (tagbody 224 | (progn ,@(translate@ init)) 225 | loop-start 226 | (unless ,(if cond (to-boolean-typed (translate cond) (ast-type cond)) t) 227 | (go loop-end)) 228 | ,@(and translated-body `((setf ,retval ,translated-body))) 229 | ,@(and continued (list continued)) 230 | (progn ,@(translate@ step)) 231 | (go loop-start) 232 | loop-end)) 233 | ,retval)))) 234 | 235 | (deftranslate (:for init cond step body) 236 | (translate-for init cond step body)) 237 | 238 | (deftranslate (:while cond body) 239 | (translate-for nil cond nil body)) 240 | 241 | (deftranslate (:do cond body) 242 | (with-label label 243 | (let ((continued nil) 244 | (break-block (gensym)) 245 | (retval (gensym)) 246 | translated-body) 247 | (extend-label *break* (label `(return-from ,break-block)) 248 | (extend-label *continue* (label `(go ,(setf continued (or continued (gensym))))) 249 | (setf translated-body (translate body)))) 250 | `(let ((,retval :undefined)) 251 | (block ,break-block 252 | (tagbody 253 | loop-start 254 | ,@(and translated-body `((setf ,retval ,translated-body))) 255 | ,@(and continued (list continued)) 256 | (when ,(to-boolean-typed (translate cond) (ast-type cond)) 257 | (go loop-start)))) 258 | ,retval)))) 259 | 260 | (deftranslate (:break label) 261 | (loop :for (lbl . thunk) :in *break* :do 262 | (when (or (not label) (equal label lbl)) 263 | (return (funcall thunk))) 264 | ;; These should be caught by parser. This is just a sanity check. 265 | :finally (js-error :syntax-error "Break without matching context."))) 266 | 267 | (deftranslate (:continue label) 268 | (loop :for (lbl . thunk) :in *continue* :do 269 | (when (or (not label) (equal label lbl)) 270 | (return (funcall thunk))) 271 | :finally (js-error :syntax-error "Continue without matching context."))) 272 | 273 | (deftranslate (:for-in init lhs obj body) 274 | (with-label label 275 | (let ((continued nil) 276 | (break-block (gensym)) 277 | (retval (gensym)) 278 | translated-body 279 | (prop (gensym))) 280 | (extend-label *break* (label `(return-from ,break-block)) 281 | (extend-label *continue* (label `(go ,(setf continued (or continued (gensym))))) 282 | (setf translated-body (translate body)))) 283 | `(let ((,retval :undefined)) 284 | (block ,break-block 285 | ,@(translate@ init) 286 | (js-for-in ,(translate obj) 287 | (lambda (,prop) 288 | ,(translate-assign lhs prop) 289 | ,(if continued 290 | `(tagbody (setf ,retval ,translated-body) ,continued) 291 | `(setf ,retval ,translated-body))))) 292 | ,retval)))) 293 | 294 | (deftranslate (:switch val cases) 295 | (with-label label 296 | (let ((break-block (gensym)) 297 | (val-sym (gensym)) 298 | (retval (gensym)) 299 | (default-case nil) 300 | blocks) 301 | (extend-label *break* (label `(return-from ,break-block)) 302 | (setf blocks 303 | (loop :for ((val . body) . rest) :on cases 304 | :for data := (list val (gensym) (mapcar 'translate body)) :collect data 305 | :do (unless val (setf default-case data)) 306 | :when (and (not rest) (not default-case)) 307 | :collect (setf default-case (list nil (gensym) nil))))) 308 | `(let ((,val-sym ,(translate val)) 309 | (,retval :undefined)) 310 | (block ,break-block 311 | (tagbody 312 | (cond ,@(loop :for (case label) :in blocks :when case :collect 313 | `((js=== ,val-sym ,(translate case)) (go ,label))) 314 | (t (go ,(second default-case)))) 315 | ,@(loop :for (nil label statements) :in blocks 316 | :collect label 317 | :append (loop :for stat :in statements :collect 318 | `(setf ,retval ,stat))))) 319 | ,retval)))) 320 | 321 | (deftranslate (:case) 322 | (js-error :syntax-error "Misplaced case label.")) 323 | (deftranslate (:default) 324 | (js-error :syntax-error "Misplaced default label.")) 325 | 326 | (flet ((expand-if (test then else) 327 | `(if ,(to-boolean-typed (translate test) (ast-type test)) 328 | ,(translate then) ,(translate else)))) 329 | (deftranslate (:if test then else) 330 | (expand-if test then else)) 331 | (deftranslate (:conditional test then else) 332 | (expand-if test then else))) 333 | 334 | (deftranslate (:try body catch finally) 335 | (let ((body (translate body))) 336 | `(,(if finally 'unwind-protect 'prog1) 337 | ,(if catch 338 | (with-scope (make-simple-scope :vars (list (as-sym (car catch)))) 339 | (let ((var (as-sym (car catch)))) 340 | `(handler-case ,body 341 | (js-condition (,var) 342 | (setf ,var (js-condition-value ,var)) 343 | ,(translate (cdr catch)))))) 344 | body) 345 | ,@(and finally (list (translate finally)))))) 346 | 347 | (deftranslate (:throw expr) 348 | `(error 'js-condition :value ,(translate expr))) 349 | 350 | (deftranslate (:name name) 351 | (lookup-var name)) 352 | 353 | (deftranslate (:with obj body) 354 | (let ((obj-var (gensym "with"))) 355 | `(let ((,obj-var ,(translate obj))) 356 | (declare (ignorable ,obj-var)) 357 | ,(with-scope (make-with-scope :var obj-var) (translate body))))) 358 | 359 | (defun find-locals (body &optional others) 360 | (let ((found (make-hash-table :test 'equal))) 361 | (labels ((add (name) 362 | (setf (gethash name found) t)) 363 | (scan (ast) 364 | (case (car ast) 365 | (:block (mapc #'scan (second ast))) 366 | ((:do :while :switch :with :label) (scan (third ast))) 367 | (:for-in (scan (second ast)) (scan (fifth ast))) 368 | (:for (scan (second ast)) (scan (fifth ast))) 369 | (:defun (add (second ast))) 370 | (:var (dolist (def (second ast)) (add (car def)))) 371 | (:if (scan (third ast)) (scan (fourth ast))) 372 | (:try (scan (second ast)) (scan (cdr (third ast))) (scan (fourth ast)))))) 373 | (mapc #'add others) 374 | (mapc #'scan body) 375 | (loop :for name :being :the :hash-keys :of found 376 | :collect name :into all 377 | :unless (member name others :test #'string=) :collect name :into internal 378 | :finally (return (values all internal)))))) 379 | 380 | (defun references-arguments (body) 381 | (labels ((scan (expr) 382 | ;; Don't enter inner functions 383 | (when (and (consp expr) (not (member (car expr) '(:function :defun)))) 384 | (when (and (eq (car expr) :name) (string= (second expr) "arguments")) 385 | (return-from references-arguments t)) 386 | (mapc #'scan expr)))) 387 | (scan body) 388 | nil)) 389 | (defun ast-is-eval-var (ast) 390 | (and (eq (car ast) :name) (equal (second ast) "eval"))) 391 | (defun uses-lexical-eval (body) 392 | (labels ((scan (expr) 393 | (when (and (consp expr) (not (member (car expr) '(:function :defun)))) ;; Don't enter inner functions 394 | (when (and (eq (car expr) :call) (ast-is-eval-var (second expr))) 395 | (return-from uses-lexical-eval t)) 396 | (mapc #'scan expr)))) 397 | (scan body) 398 | nil)) 399 | 400 | (defun split-out-defuns (forms) 401 | (loop :for form :in forms 402 | :when (eq (car form) :defun) :collect form :into defuns 403 | :else :collect form :into other 404 | :finally (return (values defuns other)))) 405 | (defun lift-defuns (forms) 406 | (multiple-value-call #'append (split-out-defuns forms))) 407 | 408 | (defun translate-raw-function (name args body) 409 | (let* ((uses-eval (uses-lexical-eval body)) 410 | (uses-args (or uses-eval (references-arguments body))) 411 | (eval-scope (gensym "eval-scope")) 412 | (base-locals (cons "this" args)) 413 | (fname (and (or uses-args *enable-Function.caller*) 414 | (or name (symbol-name (gensym)))))) 415 | (when name (push name base-locals)) 416 | (when uses-args (push "arguments" base-locals)) 417 | (multiple-value-bind (locals internal) (find-locals body base-locals) 418 | (setf locals (mapcar 'as-sym locals) internal (mapcar 'as-sym internal)) 419 | (with-scope (if uses-args 420 | (make-arguments-scope :vars locals :args (mapcar 'as-sym args)) 421 | (make-simple-scope :vars locals)) 422 | (when uses-eval 423 | (push (make-with-scope :var eval-scope) *scope*)) 424 | (let ((body1 `((let* (,@(when *enable-Function.caller* 425 | `((*current-caller* *current-callee*) 426 | (*current-callee* ,(as-sym fname)))) 427 | ,@(loop :for var :in internal :collect `(,var :undefined)) 428 | ;; TODO sane object init 429 | ,@(and uses-eval `((,eval-scope (make-obj (find-cls :object))) 430 | (eval-env ,(capture-scope))))) 431 | (declare (ignorable ,@internal ,@(and uses-eval (list eval-scope)))) 432 | ,@(mapcar 'translate (lift-defuns body)) 433 | :undefined)))) 434 | (values (if uses-args 435 | (wrap-function/arguments args body1 (as-sym fname)) 436 | (wrap-function args body1)) 437 | fname)))))) 438 | 439 | (defun translate-function (name args body) 440 | (multiple-value-bind (lmb fname) (translate-raw-function name args body) 441 | (let ((funcval `(build-func ,lmb ,(length args)))) 442 | (if (or name fname) 443 | (let ((n (as-sym (or name fname)))) 444 | `(let (,n) 445 | (declare (ignorable ,n)) 446 | (setf ,n ,funcval))) 447 | funcval)))) 448 | 449 | (defun translate-internal-function (args body) 450 | (multiple-value-bind (lmb fname) (translate-raw-function nil args body) 451 | (if fname 452 | (let ((n (as-sym fname)) (val (gensym))) 453 | `(let* (,n (,val ,lmb)) 454 | (declare (ignorable ,n)) 455 | (setf ,n (build-func ,val ,(length args))) 456 | ,val)) 457 | lmb))) 458 | 459 | (defun wrap-function (args body) 460 | `(lambda (,(as-sym "this") 461 | ,@(when args '(&optional)) 462 | ,@(loop :for arg :in args :collect 463 | `(,(as-sym arg) :undefined)) 464 | &rest extra-args) 465 | (declare (ignore extra-args) 466 | (ignorable ,(as-sym "this") ,@(mapcar 'as-sym args))) 467 | (block function ,@body))) 468 | 469 | (defun wrap-function/arguments (args body fname) 470 | (let ((argument-list (gensym "arguments")) 471 | (arg-names (mapcar #'as-sym args))) 472 | `(lambda (,(as-sym "this") &rest ,argument-list) 473 | (declare (ignorable ,(as-sym "this"))) 474 | ;; Make sure the argument list covers at least the named args 475 | (let ((,(as-sym "arguments") 476 | (make-argobj (find-cls :arguments) ,argument-list (length ,argument-list) ,fname))) 477 | (declare (ignorable ,(as-sym "arguments"))) 478 | ,@(when args 479 | `((if ,argument-list 480 | (loop :for cons :on ,argument-list :repeat ,(length args) :do 481 | (unless (cdr cons) (setf (cdr cons) (list :undefined)))) 482 | (setf ,argument-list (make-list ,(length args) :initial-element :undefined))))) 483 | (let ,(loop :for arg :in arg-names :collect `(,arg (prog1 ,argument-list (pop ,argument-list)))) 484 | (declare (ignorable ,@arg-names)) 485 | (block function ,@body)))))) 486 | 487 | (deftranslate (:return value) 488 | (unless (in-function-scope-p) 489 | (js-error :syntax-error "Return outside of function.")) 490 | `(return-from function (values ,(if value (translate value) :undefined)))) 491 | 492 | (deftranslate (:defun name args body) 493 | (set-in-scope name (translate-function name args body) t)) 494 | 495 | (deftranslate (:function name args body) 496 | (translate-function name args body)) 497 | 498 | (deftranslate (:toplevel body) 499 | `(progn ,@(mapcar 'translate (lift-defuns body)))) 500 | 501 | (deftranslate (:new func args) 502 | `(js-new ,(translate func) ,@(mapcar 'translate args))) 503 | 504 | (deftranslate (:call func args) 505 | (cond ((ast-is-eval-var func) 506 | `(lexical-eval ,(translate (or (car args) :undefined)) 507 | ,(if (in-function-scope-p) 'eval-env (capture-scope)))) 508 | ((member (car func) '(:sub :dot)) 509 | (let ((obj (gensym)) (mth (gensym))) 510 | `(let* ((,obj ,(translate (second func))) 511 | (,mth ,(case (car func) 512 | (:dot (expand-cached-lookup obj (third func))) 513 | (:sub `(js-prop ,obj ,(translate (third func))))))) 514 | (if (fobj-p ,mth) 515 | (funcall (the function (fobj-proc ,mth)) ,obj ,@(mapcar 'translate args)) 516 | ,(case (car func) 517 | (:dot `(js-error :type-error "Can not call method ~a in ~a." ,(third func) (to-string ,obj))) 518 | (:sub `(js-error :type-error "Invalid method call on ~a." (to-string ,obj)))))))) 519 | ((and (eq (car func) :name) (some (lambda (e) (typep e 'with-scope)) *scope*)) 520 | (let ((fval (gensym)) (objval (gensym))) 521 | `(multiple-value-bind (,fval ,objval) ,(translate func) 522 | (funcall (the function (proc ,fval)) (or ,objval *env*) ,@(mapcar 'translate args))))) 523 | (t `(funcall (the function (proc ,(translate func))) *env* ,@(mapcar 'translate args))))) 524 | 525 | (defun translate-assign (place val) 526 | (case (car place) 527 | ((:name) (set-in-scope (second place) val)) 528 | ((:dot) (expand-cached-set (translate (second place)) (third place) val)) 529 | (t `(setf ,(translate place) ,val)))) 530 | 531 | ;; TODO cache path-to-place 532 | (deftranslate (:assign op place val) 533 | (unless (case (car place) ((:dot :sub) t) (:name (not (equal (second place) "this")))) 534 | (js-error :syntax-error "Bad assign.")) 535 | (translate-assign place (translate (if (eq op t) val (list :binary op place val))))) 536 | 537 | (deftranslate (:num num) 538 | (etypecase num 539 | (keyword (ecase num (:infinity (infinity)) (:-infinity (-infinity)))) 540 | (number num))) 541 | 542 | (deftranslate (:string str) str) 543 | 544 | (deftranslate (:array elems) 545 | (let ((arr (gensym))) 546 | `(let ((,arr (make-array ,(length elems) :fill-pointer ,(length elems) :adjustable t))) 547 | ,@(loop :for elt :in elems :for pos :from 0 :collect 548 | `(setf (aref ,arr ,pos) ,(if elt (translate elt) :undefined))) 549 | (build-array ,arr)))) 550 | 551 | (deftranslate (:stat form) 552 | (translate form)) 553 | 554 | (deftranslate (:block forms) 555 | `(progn ,@(mapcar 'translate forms))) 556 | 557 | (deftranslate (:seq form1 result) 558 | `(prog2 ,(translate form1) ,(translate result))) 559 | 560 | (deftranslate (:binary op lhs rhs) 561 | (let ((lhs1 (translate lhs)) (rhs1 (translate rhs)) 562 | (lht (ast-type lhs)) (rht (ast-type rhs))) 563 | ;; Hack to join 'a' + 'b' + 'c' into a single concatenate call (if string type is known) 564 | (flet ((unwrap-conc (expr) 565 | (if (and (consp expr) (eq (car expr) 'concatenate)) (cddr expr) (list expr)))) 566 | (if (and (eq op :+) (eq lht :string) (eq rht :string)) 567 | `(concatenate 'string ,@(unwrap-conc lhs1) ,@(unwrap-conc rhs1)) 568 | (or (expand op lht rht lhs1 rhs1) 569 | `(,(js-intern op) ,lhs1 ,rhs1)))))) 570 | 571 | (deftranslate (:unary-prefix op rhs) 572 | (let ((type (ast-type rhs))) 573 | (case op 574 | ((:++ :--) (translate-assign 575 | rhs `(,(cond ((not (num-type type)) (js-intern op)) 576 | ((eq op :--) '1-) ((eq op :++) '1+)) ,(translate rhs)))) 577 | ((:+ :-) (or (expand op nil type nil (translate rhs)) 578 | `(,(js-intern op) 0 ,(translate rhs)))) 579 | (:delete (if (member (car rhs) '(:sub :dot)) 580 | `(delete-prop ,(translate (second rhs)) 581 | ,(ecase (car rhs) (:dot (third rhs)) (:sub (translate (third rhs))))) 582 | `(progn ,(translate rhs) t))) 583 | (:typeof (if (eq (car rhs) :name) 584 | `(handler-case (js-type-of ,(translate rhs)) 585 | (undefined-variable () "undefined")) 586 | `(js-type-of ,(translate rhs)))) 587 | (t (or (expand op nil type nil (translate rhs)) 588 | `(,(js-intern op) ,(translate rhs))))))) 589 | 590 | (deftranslate (:unary-postfix op place) 591 | (let ((ret (gensym)) (type (ast-type place))) 592 | `(let ((,ret ,(translate place))) 593 | ,(translate-assign place `(,(cond ((not (num-type type)) (js-intern op)) 594 | ((eq op :--) '1-) ((eq op :++) '1+)) ,ret)) 595 | ,ret))) 596 | 597 | (defun see (js) (translate-ast (parse js))) 598 | -------------------------------------------------------------------------------- /bench/ray.js: -------------------------------------------------------------------------------- 1 | // The ray tracer code in this file is written by Adam Burmister. It 2 | // is available in its original form from: 3 | // 4 | // http://labs.flog.nz.co/raytracer/ 5 | // 6 | // It has been modified slightly by Google to work as a standalone 7 | // benchmark, but the all the computational code remains 8 | // untouched. This file also contains a copy of parts of the Prototype 9 | // JavaScript framework which is used by the ray tracer. 10 | 11 | // Variable used to hold a number that can be used to verify that 12 | // the scene was ray traced correctly. 13 | var checkNumber; 14 | 15 | 16 | // ------------------------------------------------------------------------ 17 | // ------------------------------------------------------------------------ 18 | 19 | // The following is a copy of parts of the Prototype JavaScript library: 20 | 21 | // Prototype JavaScript framework, version 1.5.0 22 | // (c) 2005-2007 Sam Stephenson 23 | // 24 | // Prototype is freely distributable under the terms of an MIT-style license. 25 | // For details, see the Prototype web site: http://prototype.conio.net/ 26 | 27 | 28 | var Class = { 29 | create: function() { 30 | return function() { 31 | this.initialize.apply(this, arguments); 32 | } 33 | } 34 | }; 35 | 36 | 37 | Object.extend = function(destination, source) { 38 | for (var property in source) { 39 | destination[property] = source[property]; 40 | } 41 | return destination; 42 | }; 43 | 44 | 45 | // ------------------------------------------------------------------------ 46 | // ------------------------------------------------------------------------ 47 | 48 | // The rest of this file is the actual ray tracer written by Adam 49 | // Burmister. It's a concatenation of the following files: 50 | // 51 | // flog/color.js 52 | // flog/light.js 53 | // flog/vector.js 54 | // flog/ray.js 55 | // flog/scene.js 56 | // flog/material/basematerial.js 57 | // flog/material/solid.js 58 | // flog/material/chessboard.js 59 | // flog/shape/baseshape.js 60 | // flog/shape/sphere.js 61 | // flog/shape/plane.js 62 | // flog/intersectioninfo.js 63 | // flog/camera.js 64 | // flog/background.js 65 | // flog/engine.js 66 | 67 | 68 | /* Fake a Flog.* namespace */ 69 | var Flog = {RayTracer: {}}; 70 | 71 | Flog.RayTracer.Color = Class.create(); 72 | 73 | Flog.RayTracer.Color.prototype = { 74 | red : 0.0, 75 | green : 0.0, 76 | blue : 0.0, 77 | 78 | initialize : function(r, g, b) { 79 | if(!r) r = 0.0; 80 | if(!g) g = 0.0; 81 | if(!b) b = 0.0; 82 | 83 | this.red = r; 84 | this.green = g; 85 | this.blue = b; 86 | }, 87 | 88 | add : function(c1, c2){ 89 | var result = new Flog.RayTracer.Color(0,0,0); 90 | 91 | result.red = c1.red + c2.red; 92 | result.green = c1.green + c2.green; 93 | result.blue = c1.blue + c2.blue; 94 | 95 | return result; 96 | }, 97 | 98 | addScalar: function(c1, s){ 99 | var result = new Flog.RayTracer.Color(0,0,0); 100 | 101 | result.red = c1.red + s; 102 | result.green = c1.green + s; 103 | result.blue = c1.blue + s; 104 | 105 | result.limit(); 106 | 107 | return result; 108 | }, 109 | 110 | subtract: function(c1, c2){ 111 | var result = new Flog.RayTracer.Color(0,0,0); 112 | 113 | result.red = c1.red - c2.red; 114 | result.green = c1.green - c2.green; 115 | result.blue = c1.blue - c2.blue; 116 | 117 | return result; 118 | }, 119 | 120 | multiply : function(c1, c2) { 121 | var result = new Flog.RayTracer.Color(0,0,0); 122 | 123 | result.red = c1.red * c2.red; 124 | result.green = c1.green * c2.green; 125 | result.blue = c1.blue * c2.blue; 126 | 127 | return result; 128 | }, 129 | 130 | multiplyScalar : function(c1, f) { 131 | var result = new Flog.RayTracer.Color(0,0,0); 132 | 133 | result.red = c1.red * f; 134 | result.green = c1.green * f; 135 | result.blue = c1.blue * f; 136 | 137 | return result; 138 | }, 139 | 140 | divideFactor : function(c1, f) { 141 | var result = new Flog.RayTracer.Color(0,0,0); 142 | 143 | result.red = c1.red / f; 144 | result.green = c1.green / f; 145 | result.blue = c1.blue / f; 146 | 147 | return result; 148 | }, 149 | 150 | limit: function(){ 151 | this.red = (this.red > 0.0) ? ( (this.red > 1.0) ? 1.0 : this.red ) : 0.0; 152 | this.green = (this.green > 0.0) ? ( (this.green > 1.0) ? 1.0 : this.green ) : 0.0; 153 | this.blue = (this.blue > 0.0) ? ( (this.blue > 1.0) ? 1.0 : this.blue ) : 0.0; 154 | }, 155 | 156 | distance : function(color) { 157 | var d = Math.abs(this.red - color.red) + Math.abs(this.green - color.green) + Math.abs(this.blue - color.blue); 158 | return d; 159 | }, 160 | 161 | blend: function(c1, c2, w){ 162 | var result = new Flog.RayTracer.Color(0,0,0); 163 | result = Flog.RayTracer.Color.prototype.add( 164 | Flog.RayTracer.Color.prototype.multiplyScalar(c1, 1 - w), 165 | Flog.RayTracer.Color.prototype.multiplyScalar(c2, w) 166 | ); 167 | return result; 168 | }, 169 | 170 | brightness : function() { 171 | var r = Math.floor(this.red*255); 172 | var g = Math.floor(this.green*255); 173 | var b = Math.floor(this.blue*255); 174 | return (r * 77 + g * 150 + b * 29) >> 8; 175 | }, 176 | 177 | toString : function () { 178 | var r = Math.floor(this.red*255); 179 | var g = Math.floor(this.green*255); 180 | var b = Math.floor(this.blue*255); 181 | 182 | return "rgb("+ r +","+ g +","+ b +")"; 183 | } 184 | } 185 | /* Fake a Flog.* namespace */ 186 | if(typeof(Flog) == 'undefined') var Flog = {}; 187 | if(typeof(Flog.RayTracer) == 'undefined') Flog.RayTracer = {}; 188 | 189 | Flog.RayTracer.Light = Class.create(); 190 | 191 | Flog.RayTracer.Light.prototype = { 192 | position: null, 193 | color: null, 194 | intensity: 10.0, 195 | 196 | initialize : function(pos, color, intensity) { 197 | this.position = pos; 198 | this.color = color; 199 | this.intensity = (intensity ? intensity : 10.0); 200 | }, 201 | 202 | getIntensity: function(distance){ 203 | if(distance >= intensity) return 0; 204 | 205 | return Math.pow((intensity - distance) / strength, 0.2); 206 | }, 207 | 208 | toString : function () { 209 | return 'Light [' + this.position.x + ',' + this.position.y + ',' + this.position.z + ']'; 210 | } 211 | } 212 | /* Fake a Flog.* namespace */ 213 | if(typeof(Flog) == 'undefined') var Flog = {}; 214 | if(typeof(Flog.RayTracer) == 'undefined') Flog.RayTracer = {}; 215 | 216 | Flog.RayTracer.Vector = Class.create(); 217 | 218 | Flog.RayTracer.Vector.prototype = { 219 | x : 0.0, 220 | y : 0.0, 221 | z : 0.0, 222 | 223 | initialize : function(x, y, z) { 224 | this.x = (x ? x : 0); 225 | this.y = (y ? y : 0); 226 | this.z = (z ? z : 0); 227 | }, 228 | 229 | copy: function(vector){ 230 | this.x = vector.x; 231 | this.y = vector.y; 232 | this.z = vector.z; 233 | }, 234 | 235 | normalize : function() { 236 | var m = this.magnitude(); 237 | return new Flog.RayTracer.Vector(this.x / m, this.y / m, this.z / m); 238 | }, 239 | 240 | magnitude : function() { 241 | return Math.sqrt((this.x * this.x) + (this.y * this.y) + (this.z * this.z)); 242 | }, 243 | 244 | cross : function(w) { 245 | return new Flog.RayTracer.Vector( 246 | -this.z * w.y + this.y * w.z, 247 | this.z * w.x - this.x * w.z, 248 | -this.y * w.x + this.x * w.y); 249 | }, 250 | 251 | dot : function(w) { 252 | return this.x * w.x + this.y * w.y + this.z * w.z; 253 | }, 254 | 255 | add : function(v, w) { 256 | return new Flog.RayTracer.Vector(w.x + v.x, w.y + v.y, w.z + v.z); 257 | }, 258 | 259 | subtract : function(v, w) { 260 | if(!w || !v) throw 'Vectors must be defined [' + v + ',' + w + ']'; 261 | return new Flog.RayTracer.Vector(v.x - w.x, v.y - w.y, v.z - w.z); 262 | }, 263 | 264 | multiplyVector : function(v, w) { 265 | return new Flog.RayTracer.Vector(v.x * w.x, v.y * w.y, v.z * w.z); 266 | }, 267 | 268 | multiplyScalar : function(v, w) { 269 | return new Flog.RayTracer.Vector(v.x * w, v.y * w, v.z * w); 270 | }, 271 | 272 | toString : function () { 273 | return 'Vector [' + this.x + ',' + this.y + ',' + this.z + ']'; 274 | } 275 | } 276 | /* Fake a Flog.* namespace */ 277 | if(typeof(Flog) == 'undefined') var Flog = {}; 278 | if(typeof(Flog.RayTracer) == 'undefined') Flog.RayTracer = {}; 279 | 280 | Flog.RayTracer.Ray = Class.create(); 281 | 282 | Flog.RayTracer.Ray.prototype = { 283 | position : null, 284 | direction : null, 285 | initialize : function(pos, dir) { 286 | this.position = pos; 287 | this.direction = dir; 288 | }, 289 | 290 | toString : function () { 291 | return 'Ray [' + this.position + ',' + this.direction + ']'; 292 | } 293 | } 294 | /* Fake a Flog.* namespace */ 295 | if(typeof(Flog) == 'undefined') var Flog = {}; 296 | if(typeof(Flog.RayTracer) == 'undefined') Flog.RayTracer = {}; 297 | 298 | Flog.RayTracer.Scene = Class.create(); 299 | 300 | Flog.RayTracer.Scene.prototype = { 301 | camera : null, 302 | shapes : [], 303 | lights : [], 304 | background : null, 305 | 306 | initialize : function() { 307 | this.camera = new Flog.RayTracer.Camera( 308 | new Flog.RayTracer.Vector(0,0,-5), 309 | new Flog.RayTracer.Vector(0,0,1), 310 | new Flog.RayTracer.Vector(0,1,0) 311 | ); 312 | this.shapes = new Array(); 313 | this.lights = new Array(); 314 | this.background = new Flog.RayTracer.Background(new Flog.RayTracer.Color(0,0,0.5), 0.2); 315 | } 316 | } 317 | /* Fake a Flog.* namespace */ 318 | if(typeof(Flog) == 'undefined') var Flog = {}; 319 | if(typeof(Flog.RayTracer) == 'undefined') Flog.RayTracer = {}; 320 | if(typeof(Flog.RayTracer.Material) == 'undefined') Flog.RayTracer.Material = {}; 321 | 322 | Flog.RayTracer.Material.BaseMaterial = Class.create(); 323 | 324 | Flog.RayTracer.Material.BaseMaterial.prototype = { 325 | 326 | gloss: 2.0, // [0...infinity] 0 = matt 327 | transparency: 0.0, // 0=opaque 328 | reflection: 0.0, // [0...infinity] 0 = no reflection 329 | refraction: 0.50, 330 | hasTexture: false, 331 | 332 | initialize : function() { 333 | 334 | }, 335 | 336 | getColor: function(u, v){ 337 | 338 | }, 339 | 340 | wrapUp: function(t){ 341 | t = t % 2.0; 342 | if(t < -1) t += 2.0; 343 | if(t >= 1) t -= 2.0; 344 | return t; 345 | }, 346 | 347 | toString : function () { 348 | return 'Material [gloss=' + this.gloss + ', transparency=' + this.transparency + ', hasTexture=' + this.hasTexture +']'; 349 | } 350 | } 351 | /* Fake a Flog.* namespace */ 352 | if(typeof(Flog) == 'undefined') var Flog = {}; 353 | if(typeof(Flog.RayTracer) == 'undefined') Flog.RayTracer = {}; 354 | 355 | Flog.RayTracer.Material.Solid = Class.create(); 356 | 357 | Flog.RayTracer.Material.Solid.prototype = Object.extend( 358 | new Flog.RayTracer.Material.BaseMaterial(), { 359 | initialize : function(color, reflection, refraction, transparency, gloss) { 360 | this.color = color; 361 | this.reflection = reflection; 362 | this.transparency = transparency; 363 | this.gloss = gloss; 364 | this.hasTexture = false; 365 | }, 366 | 367 | getColor: function(u, v){ 368 | return this.color; 369 | }, 370 | 371 | toString : function () { 372 | return 'SolidMaterial [gloss=' + this.gloss + ', transparency=' + this.transparency + ', hasTexture=' + this.hasTexture +']'; 373 | } 374 | } 375 | ); 376 | /* Fake a Flog.* namespace */ 377 | if(typeof(Flog) == 'undefined') var Flog = {}; 378 | if(typeof(Flog.RayTracer) == 'undefined') Flog.RayTracer = {}; 379 | 380 | Flog.RayTracer.Material.Chessboard = Class.create(); 381 | 382 | Flog.RayTracer.Material.Chessboard.prototype = Object.extend( 383 | new Flog.RayTracer.Material.BaseMaterial(), { 384 | colorEven: null, 385 | colorOdd: null, 386 | density: 0.5, 387 | 388 | initialize : function(colorEven, colorOdd, reflection, transparency, gloss, density) { 389 | this.colorEven = colorEven; 390 | this.colorOdd = colorOdd; 391 | this.reflection = reflection; 392 | this.transparency = transparency; 393 | this.gloss = gloss; 394 | this.density = density; 395 | this.hasTexture = true; 396 | }, 397 | 398 | getColor: function(u, v){ 399 | var t = this.wrapUp(u * this.density) * this.wrapUp(v * this.density); 400 | 401 | if(t < 0.0) 402 | return this.colorEven; 403 | else 404 | return this.colorOdd; 405 | }, 406 | 407 | toString : function () { 408 | return 'ChessMaterial [gloss=' + this.gloss + ', transparency=' + this.transparency + ', hasTexture=' + this.hasTexture +']'; 409 | } 410 | } 411 | ); 412 | /* Fake a Flog.* namespace */ 413 | if(typeof(Flog) == 'undefined') var Flog = {}; 414 | if(typeof(Flog.RayTracer) == 'undefined') Flog.RayTracer = {}; 415 | if(typeof(Flog.RayTracer.Shape) == 'undefined') Flog.RayTracer.Shape = {}; 416 | 417 | Flog.RayTracer.Shape.BaseShape = Class.create(); 418 | 419 | Flog.RayTracer.Shape.BaseShape.prototype = { 420 | position: null, 421 | material: null, 422 | 423 | initialize : function() { 424 | this.position = new Vector(0,0,0); 425 | this.material = new Flog.RayTracer.Material.SolidMaterial( 426 | new Flog.RayTracer.Color(1,0,1), 427 | 0, 428 | 0, 429 | 0 430 | ); 431 | }, 432 | 433 | toString : function () { 434 | return 'Material [gloss=' + this.gloss + ', transparency=' + this.transparency + ', hasTexture=' + this.hasTexture +']'; 435 | } 436 | } 437 | /* Fake a Flog.* namespace */ 438 | if(typeof(Flog) == 'undefined') var Flog = {}; 439 | if(typeof(Flog.RayTracer) == 'undefined') Flog.RayTracer = {}; 440 | if(typeof(Flog.RayTracer.Shape) == 'undefined') Flog.RayTracer.Shape = {}; 441 | 442 | Flog.RayTracer.Shape.Sphere = Class.create(); 443 | 444 | Flog.RayTracer.Shape.Sphere.prototype = { 445 | initialize : function(pos, radius, material) { 446 | this.radius = radius; 447 | this.position = pos; 448 | this.material = material; 449 | }, 450 | 451 | intersect: function(ray){ 452 | var info = new Flog.RayTracer.IntersectionInfo(); 453 | info.shape = this; 454 | 455 | var dst = Flog.RayTracer.Vector.prototype.subtract(ray.position, this.position); 456 | 457 | var B = dst.dot(ray.direction); 458 | var C = dst.dot(dst) - (this.radius * this.radius); 459 | var D = (B * B) - C; 460 | 461 | if(D > 0){ // intersection! 462 | info.isHit = true; 463 | info.distance = (-B) - Math.sqrt(D); 464 | info.position = Flog.RayTracer.Vector.prototype.add( 465 | ray.position, 466 | Flog.RayTracer.Vector.prototype.multiplyScalar( 467 | ray.direction, 468 | info.distance 469 | ) 470 | ); 471 | info.normal = Flog.RayTracer.Vector.prototype.subtract( 472 | info.position, 473 | this.position 474 | ).normalize(); 475 | 476 | info.color = this.material.getColor(0,0); 477 | } else { 478 | info.isHit = false; 479 | } 480 | return info; 481 | }, 482 | 483 | toString : function () { 484 | return 'Sphere [position=' + this.position + ', radius=' + this.radius + ']'; 485 | } 486 | } 487 | /* Fake a Flog.* namespace */ 488 | if(typeof(Flog) == 'undefined') var Flog = {}; 489 | if(typeof(Flog.RayTracer) == 'undefined') Flog.RayTracer = {}; 490 | if(typeof(Flog.RayTracer.Shape) == 'undefined') Flog.RayTracer.Shape = {}; 491 | 492 | Flog.RayTracer.Shape.Plane = Class.create(); 493 | 494 | Flog.RayTracer.Shape.Plane.prototype = { 495 | d: 0.0, 496 | 497 | initialize : function(pos, d, material) { 498 | this.position = pos; 499 | this.d = d; 500 | this.material = material; 501 | }, 502 | 503 | intersect: function(ray){ 504 | var info = new Flog.RayTracer.IntersectionInfo(); 505 | 506 | var Vd = this.position.dot(ray.direction); 507 | if(Vd == 0) return info; // no intersection 508 | 509 | var t = -(this.position.dot(ray.position) + this.d) / Vd; 510 | if(t <= 0) return info; 511 | 512 | info.shape = this; 513 | info.isHit = true; 514 | info.position = Flog.RayTracer.Vector.prototype.add( 515 | ray.position, 516 | Flog.RayTracer.Vector.prototype.multiplyScalar( 517 | ray.direction, 518 | t 519 | ) 520 | ); 521 | info.normal = this.position; 522 | info.distance = t; 523 | 524 | if(this.material.hasTexture){ 525 | var vU = new Flog.RayTracer.Vector(this.position.y, this.position.z, -this.position.x); 526 | var vV = vU.cross(this.position); 527 | var u = info.position.dot(vU); 528 | var v = info.position.dot(vV); 529 | info.color = this.material.getColor(u,v); 530 | } else { 531 | info.color = this.material.getColor(0,0); 532 | } 533 | 534 | return info; 535 | }, 536 | 537 | toString : function () { 538 | return 'Plane [' + this.position + ', d=' + this.d + ']'; 539 | } 540 | } 541 | /* Fake a Flog.* namespace */ 542 | if(typeof(Flog) == 'undefined') var Flog = {}; 543 | if(typeof(Flog.RayTracer) == 'undefined') Flog.RayTracer = {}; 544 | 545 | Flog.RayTracer.IntersectionInfo = Class.create(); 546 | 547 | Flog.RayTracer.IntersectionInfo.prototype = { 548 | isHit: false, 549 | hitCount: 0, 550 | shape: null, 551 | position: null, 552 | normal: null, 553 | color: null, 554 | distance: null, 555 | 556 | initialize : function() { 557 | this.color = new Flog.RayTracer.Color(0,0,0); 558 | }, 559 | 560 | toString : function () { 561 | return 'Intersection [' + this.position + ']'; 562 | } 563 | } 564 | /* Fake a Flog.* namespace */ 565 | if(typeof(Flog) == 'undefined') var Flog = {}; 566 | if(typeof(Flog.RayTracer) == 'undefined') Flog.RayTracer = {}; 567 | 568 | Flog.RayTracer.Camera = Class.create(); 569 | 570 | Flog.RayTracer.Camera.prototype = { 571 | position: null, 572 | lookAt: null, 573 | equator: null, 574 | up: null, 575 | screen: null, 576 | 577 | initialize : function(pos, lookAt, up) { 578 | this.position = pos; 579 | this.lookAt = lookAt; 580 | this.up = up; 581 | this.equator = lookAt.normalize().cross(this.up); 582 | this.screen = Flog.RayTracer.Vector.prototype.add(this.position, this.lookAt); 583 | }, 584 | 585 | getRay: function(vx, vy){ 586 | var pos = Flog.RayTracer.Vector.prototype.subtract( 587 | this.screen, 588 | Flog.RayTracer.Vector.prototype.subtract( 589 | Flog.RayTracer.Vector.prototype.multiplyScalar(this.equator, vx), 590 | Flog.RayTracer.Vector.prototype.multiplyScalar(this.up, vy) 591 | ) 592 | ); 593 | pos.y = pos.y * -1; 594 | var dir = Flog.RayTracer.Vector.prototype.subtract( 595 | pos, 596 | this.position 597 | ); 598 | 599 | var ray = new Flog.RayTracer.Ray(pos, dir.normalize()); 600 | 601 | return ray; 602 | }, 603 | 604 | toString : function () { 605 | return 'Ray []'; 606 | } 607 | } 608 | /* Fake a Flog.* namespace */ 609 | if(typeof(Flog) == 'undefined') var Flog = {}; 610 | if(typeof(Flog.RayTracer) == 'undefined') Flog.RayTracer = {}; 611 | 612 | Flog.RayTracer.Background = Class.create(); 613 | 614 | Flog.RayTracer.Background.prototype = { 615 | color : null, 616 | ambience : 0.0, 617 | 618 | initialize : function(color, ambience) { 619 | this.color = color; 620 | this.ambience = ambience; 621 | } 622 | } 623 | /* Fake a Flog.* namespace */ 624 | if(typeof(Flog) == 'undefined') var Flog = {}; 625 | if(typeof(Flog.RayTracer) == 'undefined') Flog.RayTracer = {}; 626 | 627 | Flog.RayTracer.Engine = Class.create(); 628 | 629 | Flog.RayTracer.Engine.prototype = { 630 | canvas: null, /* 2d context we can render to */ 631 | 632 | initialize: function(options){ 633 | this.options = Object.extend({ 634 | canvasHeight: 100, 635 | canvasWidth: 100, 636 | pixelWidth: 2, 637 | pixelHeight: 2, 638 | renderDiffuse: false, 639 | renderShadows: false, 640 | renderHighlights: false, 641 | renderReflections: false, 642 | rayDepth: 2 643 | }, options || {}); 644 | 645 | this.options.canvasHeight /= this.options.pixelHeight; 646 | this.options.canvasWidth /= this.options.pixelWidth; 647 | 648 | /* TODO: dynamically include other scripts */ 649 | }, 650 | 651 | setPixel: function(x, y, color){ 652 | var pxW, pxH; 653 | pxW = this.options.pixelWidth; 654 | pxH = this.options.pixelHeight; 655 | 656 | if (this.canvas) { 657 | this.canvas.fillStyle = color.toString(); 658 | this.canvas.fillRect (x * pxW, y * pxH, pxW, pxH); 659 | } else { 660 | if (x === y) { 661 | checkNumber += color.brightness(); 662 | } 663 | } 664 | }, 665 | 666 | renderScene: function(scene, canvas){ 667 | checkNumber = 0; 668 | /* Get canvas */ 669 | if (canvas) { 670 | this.canvas = canvas.getContext("2d"); 671 | } else { 672 | this.canvas = null; 673 | } 674 | 675 | var canvasHeight = this.options.canvasHeight; 676 | var canvasWidth = this.options.canvasWidth; 677 | 678 | for(var y=0; y < canvasHeight; y++){ 679 | for(var x=0; x < canvasWidth; x++){ 680 | var yp = y * 1.0 / canvasHeight * 2 - 1; 681 | var xp = x * 1.0 / canvasWidth * 2 - 1; 682 | 683 | var ray = scene.camera.getRay(xp, yp); 684 | 685 | var color = this.getPixelColor(ray, scene); 686 | 687 | this.setPixel(x, y, color); 688 | } 689 | } 690 | if (checkNumber !== 2321) { 691 | print("Scene rendered incorrectly: " + checkNumber + " instead of 2321."); 692 | } 693 | }, 694 | 695 | getPixelColor: function(ray, scene){ 696 | var info = this.testIntersection(ray, scene, null); 697 | if(info.isHit){ 698 | var color = this.rayTrace(info, ray, scene, 0); 699 | return color; 700 | } 701 | return scene.background.color; 702 | }, 703 | 704 | testIntersection: function(ray, scene, exclude){ 705 | var hits = 0; 706 | var best = new Flog.RayTracer.IntersectionInfo(); 707 | best.distance = 2000; 708 | 709 | for(var i=0; i= 0 && info.distance < best.distance){ 715 | best = info; 716 | hits++; 717 | } 718 | } 719 | } 720 | best.hitCount = hits; 721 | return best; 722 | }, 723 | 724 | getReflectionRay: function(P,N,V){ 725 | var c1 = -N.dot(V); 726 | var R1 = Flog.RayTracer.Vector.prototype.add( 727 | Flog.RayTracer.Vector.prototype.multiplyScalar(N, 2*c1), 728 | V 729 | ); 730 | return new Flog.RayTracer.Ray(P, R1); 731 | }, 732 | 733 | rayTrace: function(info, ray, scene, depth){ 734 | // Calc ambient 735 | var color = Flog.RayTracer.Color.prototype.multiplyScalar(info.color, scene.background.ambience); 736 | var oldColor = color; 737 | var shininess = Math.pow(10, info.shape.material.gloss + 1); 738 | 739 | for(var i=0; i 0.0){ 751 | color = Flog.RayTracer.Color.prototype.add( 752 | color, 753 | Flog.RayTracer.Color.prototype.multiply( 754 | info.color, 755 | Flog.RayTracer.Color.prototype.multiplyScalar( 756 | light.color, 757 | L 758 | ) 759 | ) 760 | ); 761 | } 762 | } 763 | 764 | // The greater the depth the more accurate the colours, but 765 | // this is exponentially (!) expensive 766 | if(depth <= this.options.rayDepth){ 767 | // calculate reflection ray 768 | if(this.options.renderReflections && info.shape.material.reflection > 0) 769 | { 770 | var reflectionRay = this.getReflectionRay(info.position, info.normal, ray.direction); 771 | var refl = this.testIntersection(reflectionRay, scene, info.shape); 772 | 773 | if (refl.isHit && refl.distance > 0){ 774 | refl.color = this.rayTrace(refl, reflectionRay, scene, depth + 1); 775 | } else { 776 | refl.color = scene.background.color; 777 | } 778 | 779 | color = Flog.RayTracer.Color.prototype.blend( 780 | color, 781 | refl.color, 782 | info.shape.material.reflection 783 | ); 784 | } 785 | 786 | // Refraction 787 | /* TODO */ 788 | } 789 | 790 | /* Render shadows and highlights */ 791 | 792 | var shadowInfo = new Flog.RayTracer.IntersectionInfo(); 793 | 794 | if(this.options.renderShadows){ 795 | var shadowRay = new Flog.RayTracer.Ray(info.position, v); 796 | 797 | shadowInfo = this.testIntersection(shadowRay, scene, info.shape); 798 | if(shadowInfo.isHit && shadowInfo.shape != info.shape /*&& shadowInfo.shape.type != 'PLANE'*/){ 799 | var vA = Flog.RayTracer.Color.prototype.multiplyScalar(color, 0.5); 800 | var dB = (0.5 * Math.pow(shadowInfo.shape.material.transparency, 0.5)); 801 | color = Flog.RayTracer.Color.prototype.addScalar(vA,dB); 802 | } 803 | } 804 | 805 | // Phong specular highlights 806 | if(this.options.renderHighlights && !shadowInfo.isHit && info.shape.material.gloss > 0){ 807 | var Lv = Flog.RayTracer.Vector.prototype.subtract( 808 | info.shape.position, 809 | light.position 810 | ).normalize(); 811 | 812 | var E = Flog.RayTracer.Vector.prototype.subtract( 813 | scene.camera.position, 814 | info.shape.position 815 | ).normalize(); 816 | 817 | var H = Flog.RayTracer.Vector.prototype.subtract( 818 | E, 819 | Lv 820 | ).normalize(); 821 | 822 | var glossWeight = Math.pow(Math.max(info.normal.dot(H), 0), shininess); 823 | color = Flog.RayTracer.Color.prototype.add( 824 | Flog.RayTracer.Color.prototype.multiplyScalar(light.color, glossWeight), 825 | color 826 | ); 827 | } 828 | } 829 | color.limit(); 830 | return color; 831 | } 832 | }; 833 | 834 | 835 | function renderScene(){ 836 | var scene = new Flog.RayTracer.Scene(); 837 | 838 | scene.camera = new Flog.RayTracer.Camera( 839 | new Flog.RayTracer.Vector(0, 0, -15), 840 | new Flog.RayTracer.Vector(-0.2, 0, 5), 841 | new Flog.RayTracer.Vector(0, 1, 0) 842 | ); 843 | 844 | scene.background = new Flog.RayTracer.Background( 845 | new Flog.RayTracer.Color(0.5, 0.5, 0.5), 846 | 0.4 847 | ); 848 | 849 | var sphere = new Flog.RayTracer.Shape.Sphere( 850 | new Flog.RayTracer.Vector(-1.5, 1.5, 2), 851 | 1.5, 852 | new Flog.RayTracer.Material.Solid( 853 | new Flog.RayTracer.Color(0,0.5,0.5), 854 | 0.3, 855 | 0.0, 856 | 0.0, 857 | 2.0 858 | ) 859 | ); 860 | 861 | var sphere1 = new Flog.RayTracer.Shape.Sphere( 862 | new Flog.RayTracer.Vector(1, 0.25, 1), 863 | 0.5, 864 | new Flog.RayTracer.Material.Solid( 865 | new Flog.RayTracer.Color(0.9,0.9,0.9), 866 | 0.1, 867 | 0.0, 868 | 0.0, 869 | 1.5 870 | ) 871 | ); 872 | 873 | var plane = new Flog.RayTracer.Shape.Plane( 874 | new Flog.RayTracer.Vector(0.1, 0.9, -0.5).normalize(), 875 | 1.2, 876 | new Flog.RayTracer.Material.Chessboard( 877 | new Flog.RayTracer.Color(1,1,1), 878 | new Flog.RayTracer.Color(0,0,0), 879 | 0.2, 880 | 0.0, 881 | 1.0, 882 | 0.7 883 | ) 884 | ); 885 | 886 | scene.shapes.push(plane); 887 | scene.shapes.push(sphere); 888 | scene.shapes.push(sphere1); 889 | 890 | var light = new Flog.RayTracer.Light( 891 | new Flog.RayTracer.Vector(5, 10, -1), 892 | new Flog.RayTracer.Color(0.8, 0.8, 0.8) 893 | ); 894 | 895 | var light1 = new Flog.RayTracer.Light( 896 | new Flog.RayTracer.Vector(-3, 5, -15), 897 | new Flog.RayTracer.Color(0.8, 0.8, 0.8), 898 | 100 899 | ); 900 | 901 | scene.lights.push(light); 902 | scene.lights.push(light1); 903 | 904 | var imageWidth = 100; // $F('imageWidth'); 905 | var imageHeight = 100; // $F('imageHeight'); 906 | var pixelSize = "5,5".split(','); // $F('pixelSize').split(','); 907 | var renderDiffuse = true; // $F('renderDiffuse'); 908 | var renderShadows = true; // $F('renderShadows'); 909 | var renderHighlights = true; // $F('renderHighlights'); 910 | var renderReflections = true; // $F('renderReflections'); 911 | var rayDepth = 2;//$F('rayDepth'); 912 | var raytracer = new Flog.RayTracer.Engine( 913 | { 914 | canvasWidth: imageWidth, 915 | canvasHeight: imageHeight, 916 | pixelWidth: pixelSize[0], 917 | pixelHeight: pixelSize[1], 918 | "renderDiffuse": renderDiffuse, 919 | "renderHighlights": renderHighlights, 920 | "renderShadows": renderShadows, 921 | "renderReflections": renderReflections, 922 | "rayDepth": rayDepth 923 | } 924 | ); 925 | 926 | raytracer.renderScene(scene, null, 0); 927 | } 928 | -------------------------------------------------------------------------------- /jsos.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-js) 2 | 3 | (defvar *env*) 4 | 5 | (eval-when (:compile-toplevel :load-toplevel :execute) 6 | (defparameter *std-types* 7 | #(:object :function :array :string :arguments :regexp #+js-dates :date :error :type-error 8 | :reference-error :syntax-error :uri-error :range-error :eval-error :boolean :number)) 9 | (defun type-offset (id) 10 | (declare (optimize speed (safety 0))) 11 | (loop :for off :of-type fixnum :below (length (the simple-vector *std-types*)) :do 12 | (when (eq id (svref *std-types* off)) (return off))))) 13 | 14 | (defmacro find-proto (id) 15 | (let ((std (and (keywordp id) (position id *std-types* :test #'eq)))) 16 | (if std 17 | `(svref (gobj-proto-vec *env*) ,std) 18 | `(lookup-prototype ,id)))) 19 | (defmacro find-cls (id) 20 | (let ((std (and (keywordp id) (position id *std-types* :test #'eq)))) 21 | (if std 22 | `(svref (gobj-class-vec *env*) ,std) 23 | `(lookup-class ,id)))) 24 | (defun lookup-prototype (id) 25 | (let ((std (position id *std-types* :test #'eq))) 26 | (or (and std (svref (gobj-proto-vec *env*) std)) 27 | (second (assoc id (gobj-proto-list *env*) :test #'eq)) 28 | (error "No prototype ~a defined." id)))) 29 | (defun lookup-class (id) 30 | (let ((std (position id *std-types* :test #'eq))) 31 | (or (and std (svref (gobj-class-vec *env*) std)) 32 | (cddr (assoc id (gobj-proto-list *env*) :test #'eq)) 33 | (error "No prototype ~a defined." id)))) 34 | 35 | 36 | ;; (Some of this code is *really* unorthogonal, repeating itself a 37 | ;; lot. This is mostly due to the fact that we are using different 38 | ;; code paths, some of which can assume previously-checked conditions, 39 | ;; to optimize.) 40 | 41 | (eval-when (:compile-toplevel) 42 | (declaim (optimize speed (safety 0)))) 43 | 44 | (defstruct cls prototype) 45 | (defstruct (scls (:constructor make-scls (props prototype)) (:include cls)) 46 | props children) 47 | (defstruct (hcls (:constructor make-hcls (prototype)) (:include cls))) 48 | 49 | (defstruct (obj (:constructor make-obj (cls &optional vals))) 50 | cls (vals (make-array 4))) 51 | (defstruct (vobj (:constructor make-vobj (cls &optional value)) (:include obj)) 52 | value) 53 | (defstruct (fobj (:constructor make-fobj (cls proc new-cls &optional vals)) (:include obj)) 54 | proc new-cls) 55 | (defstruct (cfobj (:constructor make-cfobj (cls proc new-cls make-new &optional vals)) (:include fobj)) 56 | make-new) 57 | (defstruct (gobj (:constructor make-gobj (cls vals proto-vec class-vec)) (:include obj)) 58 | proto-vec class-vec proto-list required) 59 | (defstruct (aobj (:constructor make-aobj (cls &optional arr)) (:include obj)) 60 | (arr (empty-fvector 0))) 61 | (defstruct (reobj (:constructor make-reobj (cls &optional proc scanner global)) (:include fobj)) 62 | scanner global) 63 | #+js-dates 64 | (defstruct (dobj (:constructor make-dobj (cls &optional time zone)) (:include obj)) 65 | time zone) 66 | (defstruct (argobj (:constructor make-argobj (cls list length callee)) (:include obj)) 67 | list length callee) 68 | 69 | (defun make-sequence-printer (stream) 70 | (let ((count 0)) 71 | (lambda (x) 72 | (cond 73 | ((not count)) 74 | ((and *print-length* (<= *print-length* count)) 75 | (format stream " ...") 76 | (setf count nil)) 77 | (t 78 | (unless (= count 0) 79 | (format stream ", ")) 80 | (princ x stream) 81 | (incf count)))))) 82 | 83 | (defmethod print-object ((obj obj) stream) 84 | (let ((*print-circle* t)) 85 | (format stream "#"))) 92 | 93 | (defmethod print-object ((aobj aobj) stream) 94 | (format stream "#")) 98 | 99 | (defmethod print-object ((func fobj) stream) 100 | (format stream "#" (fobj-proc func))) 101 | 102 | (defmethod obj-class-name ((obj obj)) "Object") 103 | (defmethod obj-class-name ((obj fobj)) "Function") 104 | (defmethod obj-class-name ((obj cfobj)) "Object") 105 | (defmethod obj-class-name ((obj dobj)) "Date") 106 | (defmethod obj-class-name ((obj argobj)) "Arguments") 107 | (defmethod obj-class-name ((obj aobj)) "Array") 108 | (defmethod obj-class-name ((obj reobj)) "RegExp") 109 | (defmethod obj-class-name ((obj (eql :undefined))) "Undefined") 110 | (defmethod obj-class-name ((obj (eql :null))) "Undefined") 111 | (defmethod obj-class-name ((obj (eql t))) "Boolean") 112 | (defmethod obj-class-name ((obj (eql nil))) "Boolean") 113 | (defmethod obj-class-name ((obj number)) "Number") 114 | (defmethod obj-class-name ((obj string)) "String") 115 | (defmethod obj-class-name ((obj t)) "Object") 116 | 117 | ;; Slots are (offset . flags) conses for scls objects, (value . flags) conses for hcls 118 | (defconstant +slot-ro+ 1) 119 | (defconstant +slot-active+ 2) 120 | (defconstant +slot-noenum+ 4) 121 | (defconstant +slot-nodel+ 8) 122 | (defconstant +slot-dflt+ 0) 123 | 124 | (defun hash-obj (obj hcls) 125 | (let* ((scls (obj-cls obj)) 126 | (hcls (or hcls (make-hcls (cls-prototype scls)))) 127 | (vec (obj-vals obj)) 128 | (table (make-hash-table :test 'eq :size (* (length vec) 2)))) 129 | (loop :for (prop offset . flags) :in (scls-props scls) :do 130 | (setf (gethash prop table) (cons (svref vec offset) flags))) 131 | (setf (obj-cls obj) hcls (obj-vals obj) table)) 132 | obj) 133 | 134 | (defun proc (val) 135 | (if (fobj-p val) 136 | (fobj-proc val) 137 | (js-error :type-error "~a is not a function." (to-string val)))) 138 | 139 | (eval-when (:compile-toplevel :load-toplevel :execute) 140 | (defvar *prop-names* 141 | #+allegro (make-hash-table :test 'equal :weak-keys t :values :weak) 142 | #+sbcl (make-hash-table :test 'equal :weakness :key-or-value) 143 | #-(or allegro sbcl) (make-hash-table :test 'equal))) ;; Space leak when we don't have weak hashes 144 | (defun intern-prop (prop) 145 | (or (gethash prop *prop-names*) 146 | (setf (gethash prop *prop-names*) prop))) 147 | 148 | (defmacro lookup-slot (scls prop) 149 | `(cdr (assoc ,prop (scls-props ,scls) :test #'eq))) 150 | (defmacro dcall (proc obj &rest args) 151 | `(funcall (the function ,proc) ,obj ,@args)) 152 | 153 | (defstruct (cache (:constructor make-cache (prop))) 154 | (op #'cache-miss) prop cls a1 a2) 155 | 156 | (defmethod static-js-prop ((obj obj) cache) 157 | (funcall (the function (cache-op cache)) obj obj cache)) 158 | (defmethod static-js-prop (obj cache) 159 | (declare (ignore cache)) 160 | (js-error :type-error "~a has no properties." (to-string obj))) 161 | 162 | (defun do-lookup (obj start prop) 163 | (simple-lookup obj start (intern-prop (if (stringp prop) prop (to-string prop))))) 164 | (defmethod js-prop ((obj obj) prop) 165 | (do-lookup obj obj prop)) 166 | (defmethod js-prop (obj prop) 167 | (declare (ignore prop)) 168 | (js-error :type-error "~a has no properties." (to-string obj))) 169 | 170 | (defun index-in-range (index len) 171 | (if (and (typep index 'fixnum) (>= index 0) (< index len)) 172 | index 173 | (let ((index (to-string index)) index-int) 174 | (declare (string index)) 175 | (if (and (loop :for ch :across index :do 176 | (unless (<= #.(char-code #\0) (char-code ch) #.(char-code #\9)) (return nil)) 177 | :finally (return t)) 178 | (progn (setf index-int (parse-integer index)) (>= index-int 0) (< index-int len))) 179 | index-int 180 | nil)))) 181 | 182 | (defmethod js-prop ((obj aobj) prop) 183 | (let* ((vec (aobj-arr obj)) 184 | (index (index-in-range prop (length vec)))) 185 | (if index 186 | (aref vec index) 187 | (do-lookup obj obj prop)))) 188 | (defmethod js-prop ((obj argobj) prop) 189 | (let ((lst (argobj-list obj)) 190 | (index (index-in-range prop (argobj-length obj)))) 191 | (if index 192 | (nth index lst) 193 | (do-lookup obj obj prop)))) 194 | 195 | (defvar *not-found* :undefined) 196 | (defmacro if-not-found ((var lookup) &body then/else) 197 | (unless var (setf var (gensym))) 198 | `(let ((,var (let ((*not-found* :not-found)) ,lookup))) 199 | (declare (ignorable ,var)) 200 | (if (eq ,var :not-found) ,@then/else))) 201 | 202 | ;; Used for non-cached lookups 203 | (defun simple-lookup (this start prop) 204 | (loop :for obj := start :then (or (cls-prototype cls) (return *not-found*)) 205 | :for cls := (obj-cls obj) :for vals := (obj-vals obj) :do 206 | (macrolet ((maybe-active (slot value) 207 | `(if (logtest (cdr ,slot) +slot-active+) 208 | (dcall (car ,value) this) 209 | ,value))) 210 | (if (hash-table-p vals) 211 | (let ((slot (gethash prop vals))) 212 | (when slot 213 | (return (maybe-active slot (car slot))))) 214 | (let ((slot (lookup-slot cls prop))) 215 | (when slot 216 | (return (maybe-active slot (svref vals (car slot)))))))))) 217 | 218 | (defun cache-miss (val obj cache) 219 | (multiple-value-bind (fn a1 a2 result) (meta-lookup val obj (cache-prop cache)) 220 | (setf (cache-op cache) fn (cache-a1 cache) a1 (cache-a2 cache) a2 (cache-cls cache) (obj-cls obj)) 221 | result)) 222 | 223 | (defun %direct-lookup (val obj cache) 224 | (if (eq (cache-cls cache) (obj-cls obj)) 225 | (svref (obj-vals obj) (cache-a1 cache)) 226 | (cache-miss val obj cache))) 227 | 228 | (defun %direct-lookup-d (val obj cache) 229 | (if (eq (cache-cls cache) (obj-cls obj)) 230 | (dcall (car (svref (obj-vals obj) (cache-a1 cache))) val) 231 | (cache-miss val obj cache))) 232 | 233 | (defun %direct-lookup-m (val obj cache) 234 | (if (eq (cache-cls cache) (obj-cls obj)) 235 | *not-found* 236 | (cache-miss val obj cache))) 237 | 238 | (defun %direct-lookup-h (val obj cache) 239 | (if (hash-table-p (obj-vals obj)) 240 | (simple-lookup val obj (cache-prop cache)) 241 | (cache-miss val obj cache))) 242 | 243 | (defun %proto-lookup (val obj cache) 244 | (let* ((cls (obj-cls obj)) 245 | (proto (cls-prototype cls))) 246 | (if (and (eq (cache-cls cache) cls) 247 | (eq (cache-a2 cache) (obj-cls proto))) 248 | (svref (obj-vals proto) (cache-a1 cache)) 249 | (cache-miss val obj cache)))) 250 | 251 | (defun %proto-lookup-d (val obj cache) 252 | (let* ((cls (obj-cls obj)) 253 | (proto (cls-prototype cls))) 254 | (if (and (eq (cache-cls cache) cls) 255 | (eq (cache-a2 cache) (obj-cls proto))) 256 | (dcall (car (svref (obj-vals proto) (cache-a1 cache))) val) 257 | (cache-miss val obj cache)))) 258 | 259 | (defun %proto-lookup-m (val obj cache) 260 | (let ((cls (obj-cls obj))) 261 | (if (and (eq (cache-cls cache) cls) 262 | (eq (cache-a2 cache) (obj-cls (cls-prototype cls)))) 263 | *not-found* 264 | (cache-miss val obj cache)))) 265 | 266 | (defun %proto-lookup-h (val obj cache) 267 | (let ((cls (obj-cls obj))) 268 | (if (eq (cache-cls cache) cls) 269 | (simple-lookup val (cls-prototype cls) (cache-prop cache)) 270 | (cache-miss val obj cache)))) 271 | 272 | (defun %deep-lookup (val obj cache) 273 | (let* ((cls (obj-cls obj)) 274 | (proto-cls (obj-cls (cls-prototype cls)))) 275 | (if (and (eq (cache-cls cache) cls) 276 | (eq (cache-a2 cache) proto-cls)) 277 | (simple-lookup val (cls-prototype proto-cls) (cache-prop cache)) 278 | (cache-miss val obj cache)))) 279 | 280 | (defun meta-lookup (this obj prop) 281 | (macrolet ((ret (&rest vals) `(return-from meta-lookup (values ,@vals)))) 282 | (let ((cls (obj-cls obj)) (vals (obj-vals obj))) 283 | (when (hash-table-p vals) 284 | (ret #'%direct-lookup-h nil nil (simple-lookup this obj prop))) 285 | (let ((slot (lookup-slot cls prop))) 286 | (when slot 287 | (if (logtest (cdr slot) +slot-active+) 288 | (ret #'%direct-lookup-d (car slot) nil (dcall (car (svref vals (car slot))) this)) 289 | (ret #'%direct-lookup (car slot) nil (svref vals (car slot)))))) 290 | (let ((proto (cls-prototype cls))) 291 | (unless proto (ret #'%direct-lookup-m nil nil *not-found*)) 292 | (let ((proto-cls (obj-cls proto)) (proto-vals (obj-vals proto))) 293 | (when (hash-table-p proto-vals) 294 | (ret #'%proto-lookup-h nil nil (simple-lookup this proto prop))) 295 | (let ((slot (lookup-slot proto-cls prop))) 296 | (when slot 297 | (if (logtest (cdr slot) +slot-active+) 298 | (ret #'%proto-lookup-d (car slot) proto-cls (dcall (car (svref proto-vals (car slot))) this)) 299 | (ret #'%proto-lookup (car slot) proto-cls (svref proto-vals (car slot)))))) 300 | (let ((proto2 (cls-prototype proto-cls))) 301 | (unless proto2 (ret #'%proto-lookup-m nil proto-cls *not-found*)) 302 | (ret #'%deep-lookup nil proto-cls (simple-lookup this proto2 prop)))))))) 303 | 304 | (defun expand-cached-lookup (obj prop) 305 | `(static-js-prop ,obj (load-time-value (make-cache (intern-prop ,prop))))) 306 | (defmacro cached-lookup (obj prop) 307 | (expand-cached-lookup obj prop)) 308 | 309 | ;; Writing 310 | 311 | (defun update-class-and-set (obj new-cls slot val) 312 | (setf (obj-cls obj) new-cls) 313 | (unless (< slot (length (obj-vals obj))) 314 | (let ((vals (make-array (max 4 (* 2 (length (obj-vals obj))))))) 315 | (replace vals (obj-vals obj)) 316 | (setf (obj-vals obj) vals))) 317 | (setf (svref (obj-vals obj) slot) val)) 318 | 319 | (defstruct (wcache (:constructor make-wcache (prop))) 320 | (op #'wcache-miss) cls prop slot a1) 321 | 322 | (defun %simple-set (obj wcache val) 323 | (if (eq (obj-cls obj) (wcache-cls wcache)) 324 | (setf (svref (obj-vals obj) (wcache-slot wcache)) val) 325 | (wcache-miss obj wcache val))) 326 | 327 | (defun %active-set (obj wcache val) 328 | (if (eq (obj-cls obj) (wcache-cls wcache)) 329 | (progn (dcall (wcache-a1 wcache) obj val) val) 330 | (wcache-miss obj wcache val))) 331 | 332 | (defun %change-class-set (obj wcache val) 333 | (if (eq (obj-cls obj) (wcache-cls wcache)) 334 | (update-class-and-set obj (wcache-a1 wcache) (wcache-slot wcache) val) 335 | (wcache-miss obj wcache val))) 336 | 337 | (defun %ignored-set (obj wcache val) 338 | (if (eq (obj-cls obj) (wcache-cls wcache)) 339 | val 340 | (wcache-miss obj wcache val))) 341 | 342 | (defun %hash-set (obj wcache val) 343 | (if (hash-table-p (obj-vals obj)) 344 | (hash-set obj (wcache-prop wcache) val) 345 | (wcache-miss obj wcache val))) 346 | 347 | (defun %hash-then-set (obj wcache val) 348 | (if (eq (obj-cls obj) (wcache-cls wcache)) 349 | (progn (hash-obj obj (scls-children (obj-cls obj))) 350 | (setf (gethash (wcache-prop wcache) (obj-vals obj)) (cons val +slot-dflt+)) 351 | val) 352 | (wcache-miss obj wcache val))) 353 | 354 | (defun hash-set (obj prop val) 355 | (let* ((table (obj-vals obj)) 356 | (exists (gethash prop table))) 357 | (if exists 358 | (setf (car exists) val) 359 | ;; Check prototypes for read-only or active slots 360 | (if (let (curc curv hash slot) 361 | (loop :for cur := (cls-prototype (obj-cls obj)) :then (cls-prototype curc) :while cur :do 362 | (setf curc (obj-cls cur) curv (obj-vals cur) hash (hash-table-p curv)) 363 | (setf slot (if hash (gethash prop curv) (lookup-slot curc prop))) 364 | (when slot 365 | (when (logtest (cdr slot) +slot-ro+) (return t)) 366 | (when (logtest (cdr slot) +slot-active+) 367 | (let ((func (cdr (if hash (car slot) (svref curv (car slot)))))) 368 | (when func (dcall func obj val)) 369 | (return t))) 370 | (return nil)))) 371 | val 372 | (progn (setf (gethash prop table) (cons val +slot-dflt+)) val))))) 373 | 374 | (defun wcache-miss (obj wcache val) 375 | (setf (wcache-cls wcache) (obj-cls obj)) 376 | (multiple-value-bind (fn slot a1) (meta-set obj (wcache-prop wcache) val) 377 | (setf (wcache-op wcache) fn (wcache-slot wcache) slot (wcache-a1 wcache) a1) 378 | val)) 379 | 380 | ;; This makes the assumption that the read-only flag of a property is 381 | ;; final, and doesn't change at runtime. If we add code to allow 382 | ;; twiddling of this flag, we can no longer cache the check. 383 | (defun meta-set (obj prop val) 384 | (macrolet ((ret (&rest vals) `(return-from meta-set (values ,@vals)))) 385 | (let ((cls (obj-cls obj)) (vals (obj-vals obj))) 386 | (when (hash-table-p vals) 387 | (hash-set obj prop val) 388 | (ret #'%hash-set)) 389 | (let ((slot (lookup-slot cls prop))) 390 | (when slot 391 | (when (logtest (cdr slot) +slot-ro+) 392 | (ret #'%ignored-set)) 393 | (when (logtest (cdr slot) +slot-active+) 394 | (let ((func (cdr (svref vals (car slot))))) 395 | (when func 396 | (dcall func obj val) 397 | (ret #'%active-set (car slot) func)) 398 | (ret #'%ignored-set))) 399 | (setf (svref vals (car slot)) val) 400 | (ret #'%simple-set (car slot)))) 401 | ;; Look for a read-only or active slot in prototypes 402 | (let (curc curv hash) 403 | (loop :for cur := (cls-prototype cls) :then (cls-prototype curc) :while cur :do 404 | (setf curc (obj-cls cur) curv (obj-vals cur) hash (hash-table-p curv)) 405 | (let ((slot (if hash (gethash prop curv) (lookup-slot curc prop)))) 406 | (when slot 407 | (when (logtest (cdr slot) +slot-ro+) (ret #'%ignored-set)) 408 | (when (logtest (cdr slot) +slot-active+) 409 | (let ((func (cdr (if hash (car slot) (svref curv (car slot)))))) 410 | (when func 411 | (dcall func obj val) 412 | (ret #'%active-set (car slot) func)) 413 | (ret #'%ignored-set))) 414 | (return))))) 415 | ;; No direct slot found yet, but can write. Add slot. 416 | (scls-add-slot obj cls prop val +slot-dflt+)))) 417 | 418 | (defun scls-add-slot (obj cls prop val flags) 419 | ;; Setting scls-children to a hash class means hash, using that class, when adding slots 420 | (unless (listp (scls-children cls)) 421 | (hash-obj obj (scls-children cls)) 422 | (setf (gethash prop (obj-vals obj)) (cons val flags)) 423 | (return-from scls-add-slot #'%hash-then-set)) 424 | (let ((new-cls (cdr (assoc prop (scls-children cls) :test #'eq))) slot) 425 | ;; We switch to a hash table if this class has 8 'exits' (probably 426 | ;; being used as a container), and it is not one of the reused classes. 427 | (when (and (not new-cls) (or (nthcdr 8 (scls-children cls)) (nthcdr 40 (scls-props cls))) 428 | (not (find cls (gobj-class-vec *env*) :test #'eq))) 429 | (setf (scls-children cls) (make-hcls (cls-prototype cls))) 430 | (hash-obj obj (scls-children cls)) 431 | (setf (gethash prop (obj-vals obj)) (cons val flags)) 432 | (return-from scls-add-slot #'%hash-then-set)) 433 | (if new-cls 434 | (setf slot (lookup-slot new-cls prop)) 435 | (progn 436 | (setf slot (cons (length (scls-props cls)) flags) 437 | new-cls (make-scls (cons (cons prop slot) (scls-props cls)) (cls-prototype cls))) 438 | (push (cons prop new-cls) (scls-children cls)))) 439 | (update-class-and-set obj new-cls (car slot) val) 440 | (values #'%change-class-set (car slot) new-cls))) 441 | 442 | (defun ensure-slot (obj prop val &optional (flags +slot-dflt+)) 443 | (setf prop (intern-prop prop)) 444 | (let ((vals (obj-vals obj))) 445 | (if (hash-table-p vals) 446 | (setf (gethash prop vals) (cons val flags)) 447 | (let* ((cls (obj-cls obj)) (slot (lookup-slot cls prop))) 448 | (if slot 449 | (setf (svref (obj-vals obj) (car slot)) val) 450 | (scls-add-slot obj cls prop val flags)))))) 451 | 452 | (defmethod (setf static-js-prop) (val (obj obj) wcache) 453 | (funcall (the function (wcache-op wcache)) obj wcache val)) 454 | (defmethod (setf static-js-prop) (val obj wcache) 455 | (declare (ignore wcache val)) 456 | (js-error :type-error "~a has no properties." (to-string obj))) 457 | 458 | (defmethod (setf js-prop) (val (obj obj) prop) 459 | ;; Uses meta-set since the overhead isn't big, and duplicating all 460 | ;; that logic is error-prone. 461 | (meta-set obj (intern-prop (if (stringp prop) prop (to-string prop))) val) 462 | val) 463 | (defmethod (setf js-prop) (val obj prop) 464 | (declare (ignore prop val)) 465 | (js-error :type-error "~a has no properties." (to-string obj))) 466 | ;; TODO sparse storage, clever resizing 467 | (defmethod (setf js-prop) (val (obj aobj) prop) 468 | (let ((index (index-in-range prop most-positive-fixnum))) 469 | (if index 470 | (let ((arr (aobj-arr obj))) 471 | (when (>= index (length arr)) 472 | (adjust-array arr (1+ index) :fill-pointer (1+ index) :initial-element :undefined)) 473 | (setf (aref arr index) val)) 474 | (call-next-method val obj prop)))) 475 | (defmethod (setf js-prop) (val (obj argobj) prop) 476 | (let ((lst (argobj-list obj)) 477 | (index (index-in-range prop (argobj-length obj)))) 478 | (if index 479 | (setf (nth index lst) val) 480 | (call-next-method val obj prop)))) 481 | 482 | (defun expand-cached-set (obj prop val) 483 | `(setf (static-js-prop ,obj (load-time-value (make-wcache (intern-prop ,prop)))) ,val)) 484 | (defmacro cached-set (obj prop val) 485 | (expand-cached-set obj prop val)) 486 | 487 | ;; Optimized global-object access 488 | 489 | (define-condition undefined-variable (js-condition) ()) ;; TODO proper contents 490 | (defun undefined-variable (name) 491 | (let ((err (make-js-error :reference-error "Undefined variable: ~a" name))) 492 | (error 'undefined-variable :value err))) 493 | 494 | (defun gcache-lookup (gcache obj) 495 | (let ((slot (car gcache)) 496 | (cache (cdr gcache))) 497 | (macrolet ((read-slot () 498 | `(if (logtest (cdr slot) +slot-active+) 499 | (if (eq (car slot) :deleted) 500 | (progn (setf (car gcache) nil) 501 | (return-from gcache-lookup (gcache-lookup gcache obj))) 502 | (dcall (car slot) obj)) 503 | (car slot)))) 504 | (cond (slot (read-slot)) 505 | ((setf slot (gethash (cache-prop cache) (obj-vals obj))) 506 | (setf (car gcache) slot) 507 | (read-slot)) 508 | (t (if-not-found (value (static-js-prop obj cache)) 509 | (undefined-variable (cache-prop cache)) 510 | value)))))) 511 | 512 | (defun expand-global-lookup (prop) 513 | `(gcache-lookup (load-time-value (cons nil (make-cache (intern-prop ,prop)))) ,*env*)) 514 | 515 | (defun global-lookup (prop) 516 | (if-not-found (value (js-prop *env* prop)) 517 | (undefined-variable prop) 518 | value)) 519 | 520 | (defun gcache-set (gcache obj val) 521 | (let ((slot (car gcache)) 522 | (prop (cdr gcache))) 523 | (when (cond (slot t) 524 | ((setf slot (gethash prop (obj-vals obj))) (setf (car gcache) slot)) 525 | (t (hash-set obj prop val) nil)) 526 | (cond ((logtest (cdr slot) +slot-active+) 527 | (if (eq (car slot) :deleted) 528 | (progn (setf (car gcache) nil) 529 | (return-from gcache-set (gcache-set gcache obj val))) 530 | (when (cdar slot) (dcall (cdar slot) obj val)))) 531 | ((not (logtest (cdr slot) +slot-ro+)) 532 | (setf (car slot) val)))) 533 | val)) 534 | 535 | (defun expand-global-set (prop val) 536 | `(gcache-set (load-time-value (cons nil (intern-prop ,prop))) ,*env* ,val)) 537 | 538 | ;; Enumerating 539 | 540 | (defmethod js-for-in ((obj obj) func &optional shallow) 541 | (let ((stack ())) 542 | (flet ((maybe-yield (flags name) 543 | (unless (or (logtest flags +slot-noenum+) 544 | (dolist (parent stack) 545 | (when (find-slot* parent name) (return t)))) 546 | (funcall func name)))) 547 | (let (cls vals) 548 | (loop :for cur := obj :then (and shallow (cls-prototype cls)) :while cur :do 549 | (setf cls (obj-cls cur) vals (obj-vals cur)) 550 | (if (hash-table-p vals) 551 | (with-hash-table-iterator (next vals) 552 | (loop (multiple-value-bind (more name val) (next) 553 | (unless more (return)) 554 | (maybe-yield (cdr val) name)))) 555 | (loop :for (name nil . flags) :in (scls-props cls) :do 556 | (maybe-yield flags name))) 557 | (push cur stack)))))) 558 | 559 | (defmethod js-for-in ((obj aobj) func &optional shallow) 560 | (declare (ignore shallow)) 561 | (dotimes (i (length (aobj-arr obj))) (funcall func (princ-to-string i))) 562 | (call-next-method)) 563 | 564 | (defmethod js-for-in ((obj argobj) func &optional shallow) 565 | (declare (ignore shallow)) 566 | (dotimes (i (argobj-length obj)) (funcall func (princ-to-string i))) 567 | (call-next-method)) 568 | 569 | (defmethod js-for-in (obj func &optional shallow) 570 | (declare (ignore obj func shallow))) 571 | 572 | ;; Registering prototypes for string, number, and boolean values 573 | 574 | (defmacro declare-primitive-prototype (specializer proto-id) 575 | `(progn 576 | (defmethod static-js-prop ((obj ,specializer) cache) 577 | (funcall (the function (cache-op cache)) obj (find-proto ,proto-id) cache)) 578 | (defmethod js-prop ((obj ,specializer) prop) 579 | (do-lookup obj (find-proto ,proto-id) prop)) 580 | (defmethod (setf static-js-prop) (val (obj ,specializer) wcache) 581 | (declare (ignore wcache)) 582 | val) 583 | (defmethod (setf js-prop) (val (obj ,specializer) prop) 584 | (declare (ignore prop)) 585 | val) 586 | (defmethod js-for-in ((obj ,specializer) func &optional shallow) 587 | (js-for-in (find-proto ,proto-id) func shallow)))) 588 | 589 | ;; Utilities 590 | 591 | (defun expand-static-obj (proto props) 592 | (let ((cls (gensym))) 593 | `(let ((,cls (load-time-value (make-scls ',(loop :for off :from 0 :for (name . val) :in props :collect 594 | (list* (intern-prop name) off 595 | (if (and (consp val) (eq (car val) :active)) 596 | +slot-active+ +slot-dflt+))) 597 | ,proto)))) 598 | (make-obj ,cls (vector ,@(loop :for (nil . val) :in props :collect 599 | (if (and (consp val) (eq (car val) :active)) 600 | `(cons ,(second val) ,(third val)) 601 | val))))))) 602 | 603 | (defun js-new (func &rest args) 604 | (unless (fobj-p func) 605 | (js-error :type-error "~a is not a constructor." (to-string func))) 606 | (let* ((cls (ensure-fobj-cls func)) 607 | (this (if (cfobj-p func) (funcall (cfobj-make-new func) cls) (make-obj cls))) 608 | (result (apply (the function (proc func)) this args))) 609 | (if (obj-p result) result this))) 610 | 611 | (defun ensure-fobj-cls (fobj) 612 | (let ((proto (js-prop fobj "prototype"))) ;; Active property in function prototype ensures this is always bound 613 | (unless (obj-p proto) 614 | (setf proto (js-obj)) 615 | (setf (js-prop proto "constructor") fobj)) 616 | (unless (and (fobj-new-cls fobj) (eq (cls-prototype (fobj-new-cls fobj)) proto)) 617 | (setf (fobj-new-cls fobj) (make-scls () proto))) 618 | (fobj-new-cls fobj))) 619 | 620 | (defun find-slot (obj prop) 621 | (find-slot* obj (intern-prop prop))) 622 | 623 | (defun find-slot* (obj prop) 624 | (let ((vals (obj-vals obj))) 625 | (if (hash-table-p vals) 626 | (gethash prop vals) 627 | (lookup-slot (obj-cls obj) prop)))) 628 | 629 | (defun delete-prop (obj prop) 630 | (if (obj-p obj) 631 | (let ((slot (find-slot obj prop))) 632 | (cond ((not slot) t) 633 | ((logtest (cdr slot) +slot-nodel+) nil) 634 | (t (cond ((not (hash-table-p (obj-vals obj))) 635 | (hash-obj obj (make-hcls (cls-prototype (obj-cls obj))))) ;; TODO reuse? 636 | ((eq obj *env*) ;; Global slots can be cached, so we have to flag them as deleted 637 | (setf (car slot) :deleted (cdr slot) +slot-active+))) 638 | (remhash (intern-prop prop) (obj-vals obj))))) 639 | t)) 640 | -------------------------------------------------------------------------------- /bench/codemirror.js: -------------------------------------------------------------------------------- 1 | // Selected framework code + JavaScript parser from http://marijn.haverbeke.nl/codemirror 2 | 3 | function codemirrorBench(str) { 4 | var total = 0; 5 | highlightText(str, function(token) {total += token.value.length;}); 6 | if (total != str.length) throw new Error("Invalid output!"); 7 | else return "OK"; 8 | } 9 | 10 | var StopIteration = {toString: function() {return "StopIteration"}}; 11 | 12 | var Editor = {}; 13 | var indentUnit = 2; 14 | 15 | (function(){ 16 | function normaliseString(string) { 17 | var tab = ""; 18 | for (var i = 0; i < indentUnit; i++) tab += " "; 19 | 20 | string = string.replace(/\t/g, tab).replace(/\u00a0/g, " ").replace(/\r\n?/g, "\n"); 21 | var pos = 0, parts = [], lines = string.split("\n"); 22 | for (var line = 0; line < lines.length; line++) { 23 | if (line != 0) parts.push("\n"); 24 | parts.push(lines[line]); 25 | } 26 | 27 | return { 28 | next: function() { 29 | if (pos < parts.length) return parts[pos++]; 30 | else throw StopIteration; 31 | } 32 | }; 33 | } 34 | 35 | this.highlightText = function(string, callback, parser) { 36 | parser = (parser || Editor.Parser).make(stringStream(normaliseString(string))); 37 | try { 38 | while (true) callback(parser.next()); 39 | } 40 | catch (e) { 41 | if (e != StopIteration) throw e; 42 | } 43 | } 44 | })(); 45 | 46 | /* String streams are the things fed to parsers (which can feed them 47 | * to a tokenizer if they want). They provide peek and next methods 48 | * for looking at the current character (next 'consumes' this 49 | * character, peek does not), and a get method for retrieving all the 50 | * text that was consumed since the last time get was called. 51 | * 52 | * An easy mistake to make is to let a StopIteration exception finish 53 | * the token stream while there are still characters pending in the 54 | * string stream (hitting the end of the buffer while parsing a 55 | * token). To make it easier to detect such errors, the stringstreams 56 | * throw an exception when this happens. 57 | */ 58 | 59 | // Make a stringstream stream out of an iterator that returns strings. 60 | // This is applied to the result of traverseDOM (see codemirror.js), 61 | // and the resulting stream is fed to the parser. 62 | var stringStream = function(source){ 63 | // String that's currently being iterated over. 64 | var current = ""; 65 | // Position in that string. 66 | var pos = 0; 67 | // Accumulator for strings that have been iterated over but not 68 | // get()-ed yet. 69 | var accum = ""; 70 | // Make sure there are more characters ready, or throw 71 | // StopIteration. 72 | function ensureChars() { 73 | while (pos == current.length) { 74 | accum += current; 75 | current = ""; // In case source.next() throws 76 | pos = 0; 77 | try {current = source.next();} 78 | catch (e) { 79 | if (e != StopIteration) throw e; 80 | else return false; 81 | } 82 | } 83 | return true; 84 | } 85 | 86 | return { 87 | // Return the next character in the stream. 88 | peek: function() { 89 | if (!ensureChars()) return null; 90 | return current.charAt(pos); 91 | }, 92 | // Get the next character, throw StopIteration if at end, check 93 | // for unused content. 94 | next: function() { 95 | if (!ensureChars()) { 96 | if (accum.length > 0) 97 | throw "End of stringstream reached without emptying buffer ('" + accum + "')."; 98 | else 99 | throw StopIteration; 100 | } 101 | return current.charAt(pos++); 102 | }, 103 | // Return the characters iterated over since the last call to 104 | // .get(). 105 | get: function() { 106 | var temp = accum; 107 | accum = ""; 108 | if (pos > 0){ 109 | temp += current.slice(0, pos); 110 | current = current.slice(pos); 111 | pos = 0; 112 | } 113 | return temp; 114 | }, 115 | // Push a string back into the stream. 116 | push: function(str) { 117 | current = current.slice(0, pos) + str + current.slice(pos); 118 | }, 119 | lookAhead: function(str, consume, skipSpaces, caseInsensitive) { 120 | function cased(str) {return caseInsensitive ? str.toLowerCase() : str;} 121 | str = cased(str); 122 | var found = false; 123 | 124 | var _accum = accum, _pos = pos; 125 | if (skipSpaces) this.nextWhileMatches(/[\s\u00a0]/); 126 | 127 | while (true) { 128 | var end = pos + str.length, left = current.length - pos; 129 | if (end <= current.length) { 130 | found = str == cased(current.slice(pos, end)); 131 | pos = end; 132 | break; 133 | } 134 | else if (str.slice(0, left) == cased(current.slice(pos))) { 135 | accum += current; current = ""; 136 | try {current = source.next();} 137 | catch (e) {break;} 138 | pos = 0; 139 | str = str.slice(left); 140 | } 141 | else { 142 | break; 143 | } 144 | } 145 | 146 | if (!(found && consume)) { 147 | current = accum.slice(_accum.length) + current; 148 | pos = _pos; 149 | accum = _accum; 150 | } 151 | 152 | return found; 153 | }, 154 | 155 | // Utils built on top of the above 156 | more: function() { 157 | return this.peek() !== null; 158 | }, 159 | applies: function(test) { 160 | var next = this.peek(); 161 | return (next !== null && test(next)); 162 | }, 163 | nextWhile: function(test) { 164 | var next; 165 | while ((next = this.peek()) !== null && test(next)) 166 | this.next(); 167 | }, 168 | matches: function(re) { 169 | var next = this.peek(); 170 | return (next !== null && re.test(next)); 171 | }, 172 | nextWhileMatches: function(re) { 173 | var next; 174 | while ((next = this.peek()) !== null && re.test(next)) 175 | this.next(); 176 | }, 177 | equals: function(ch) { 178 | return ch === this.peek(); 179 | }, 180 | endOfLine: function() { 181 | var next = this.peek(); 182 | return next == null || next == "\n"; 183 | } 184 | }; 185 | }; 186 | // A framework for simple tokenizers. Takes care of newlines and 187 | // white-space, and of getting the text from the source stream into 188 | // the token object. A state is a function of two arguments -- a 189 | // string stream and a setState function. The second can be used to 190 | // change the tokenizer's state, and can be ignored for stateless 191 | // tokenizers. This function should advance the stream over a token 192 | // and return a string or object containing information about the next 193 | // token, or null to pass and have the (new) state be called to finish 194 | // the token. When a string is given, it is wrapped in a {style, type} 195 | // object. In the resulting object, the characters consumed are stored 196 | // under the content property. Any whitespace following them is also 197 | // automatically consumed, and added to the value property. (Thus, 198 | // content is the actual meaningful part of the token, while value 199 | // contains all the text it spans.) 200 | 201 | function tokenizer(source, state) { 202 | // Newlines are always a separate token. 203 | function isWhiteSpace(ch) { 204 | // The messy regexp is because IE's regexp matcher is of the 205 | // opinion that non-breaking spaces are no whitespace. 206 | return ch != "\n" && /^[\s\u00a0]*$/.test(ch); 207 | } 208 | 209 | var tokenizer = { 210 | state: state, 211 | 212 | take: function(type) { 213 | if (typeof(type) == "string") 214 | type = {style: type, type: type}; 215 | 216 | type.content = (type.content || "") + source.get(); 217 | if (!/\n$/.test(type.content)) 218 | source.nextWhile(isWhiteSpace); 219 | type.value = type.content + source.get(); 220 | return type; 221 | }, 222 | 223 | next: function () { 224 | if (!source.more()) throw StopIteration; 225 | 226 | var type; 227 | if (source.equals("\n")) { 228 | source.next(); 229 | return this.take("whitespace"); 230 | } 231 | 232 | if (source.applies(isWhiteSpace)) 233 | type = "whitespace"; 234 | else 235 | while (!type) 236 | type = this.state(source, function(s) {tokenizer.state = s;}); 237 | 238 | return this.take(type); 239 | } 240 | }; 241 | return tokenizer; 242 | } 243 | /* Tokenizer for JavaScript code */ 244 | 245 | var tokenizeJavaScript = (function() { 246 | // Advance the stream until the given character (not preceded by a 247 | // backslash) is encountered, or the end of the line is reached. 248 | function nextUntilUnescaped(source, end) { 249 | var escaped = false; 250 | while (!source.endOfLine()) { 251 | var next = source.next(); 252 | if (next == end && !escaped) 253 | return false; 254 | escaped = !escaped && next == "\\"; 255 | } 256 | return escaped; 257 | } 258 | 259 | // A map of JavaScript's keywords. The a/b/c keyword distinction is 260 | // very rough, but it gives the parser enough information to parse 261 | // correct code correctly (we don't care that much how we parse 262 | // incorrect code). The style information included in these objects 263 | // is used by the highlighter to pick the correct CSS style for a 264 | // token. 265 | var keywords = function(){ 266 | function result(type, style){ 267 | return {type: type, style: "js-" + style}; 268 | } 269 | // keywords that take a parenthised expression, and then a 270 | // statement (if) 271 | var keywordA = result("keyword a", "keyword"); 272 | // keywords that take just a statement (else) 273 | var keywordB = result("keyword b", "keyword"); 274 | // keywords that optionally take an expression, and form a 275 | // statement (return) 276 | var keywordC = result("keyword c", "keyword"); 277 | var operator = result("operator", "keyword"); 278 | var atom = result("atom", "atom"); 279 | return { 280 | "if": keywordA, "while": keywordA, "with": keywordA, 281 | "else": keywordB, "do": keywordB, "try": keywordB, "finally": keywordB, 282 | "return": keywordC, "break": keywordC, "continue": keywordC, "new": keywordC, "delete": keywordC, "throw": keywordC, 283 | "in": operator, "typeof": operator, "instanceof": operator, 284 | "var": result("var", "keyword"), "function": result("function", "keyword"), "catch": result("catch", "keyword"), 285 | "for": result("for", "keyword"), "switch": result("switch", "keyword"), 286 | "case": result("case", "keyword"), "default": result("default", "keyword"), 287 | "true": atom, "false": atom, "null": atom, "undefined": atom, "NaN": atom, "Infinity": atom 288 | }; 289 | }(); 290 | 291 | // Some helper regexps 292 | var isOperatorChar = /[+\-*&%=<>!?|]/; 293 | var isHexDigit = /[0-9A-Fa-f]/; 294 | var isWordChar = /[\w\$_]/; 295 | 296 | // Wrapper around jsToken that helps maintain parser state (whether 297 | // we are inside of a multi-line comment and whether the next token 298 | // could be a regular expression). 299 | function jsTokenState(inside, regexp) { 300 | return function(source, setState) { 301 | var newInside = inside; 302 | var type = jsToken(inside, regexp, source, function(c) {newInside = c;}); 303 | var newRegexp = type.type == "operator" || type.type == "keyword c" || type.type.match(/^[\[{}\(,;:]$/); 304 | if (newRegexp != regexp || newInside != inside) 305 | setState(jsTokenState(newInside, newRegexp)); 306 | return type; 307 | }; 308 | } 309 | 310 | // The token reader, intended to be used by the tokenizer from 311 | // tokenize.js (through jsTokenState). Advances the source stream 312 | // over a token, and returns an object containing the type and style 313 | // of that token. 314 | function jsToken(inside, regexp, source, setInside) { 315 | function readHexNumber(){ 316 | source.next(); // skip the 'x' 317 | source.nextWhileMatches(isHexDigit); 318 | return {type: "number", style: "js-atom"}; 319 | } 320 | 321 | function readNumber() { 322 | source.nextWhileMatches(/[0-9]/); 323 | if (source.equals(".")){ 324 | source.next(); 325 | source.nextWhileMatches(/[0-9]/); 326 | } 327 | if (source.equals("e") || source.equals("E")){ 328 | source.next(); 329 | if (source.equals("-")) 330 | source.next(); 331 | source.nextWhileMatches(/[0-9]/); 332 | } 333 | return {type: "number", style: "js-atom"}; 334 | } 335 | // Read a word, look it up in keywords. If not found, it is a 336 | // variable, otherwise it is a keyword of the type found. 337 | function readWord() { 338 | source.nextWhileMatches(isWordChar); 339 | var word = source.get(); 340 | var known = keywords.hasOwnProperty(word) && keywords.propertyIsEnumerable(word) && keywords[word]; 341 | return known ? {type: known.type, style: known.style, content: word} : 342 | {type: "variable", style: "js-variable", content: word}; 343 | } 344 | function readRegexp() { 345 | nextUntilUnescaped(source, "/"); 346 | source.nextWhileMatches(/[gi]/); 347 | return {type: "regexp", style: "js-string"}; 348 | } 349 | // Mutli-line comments are tricky. We want to return the newlines 350 | // embedded in them as regular newline tokens, and then continue 351 | // returning a comment token for every line of the comment. So 352 | // some state has to be saved (inside) to indicate whether we are 353 | // inside a /* */ sequence. 354 | function readMultilineComment(start){ 355 | var newInside = "/*"; 356 | var maybeEnd = (start == "*"); 357 | while (true) { 358 | if (source.endOfLine()) 359 | break; 360 | var next = source.next(); 361 | if (next == "/" && maybeEnd){ 362 | newInside = null; 363 | break; 364 | } 365 | maybeEnd = (next == "*"); 366 | } 367 | setInside(newInside); 368 | return {type: "comment", style: "js-comment"}; 369 | } 370 | function readOperator() { 371 | source.nextWhileMatches(isOperatorChar); 372 | return {type: "operator", style: "js-operator"}; 373 | } 374 | function readString(quote) { 375 | var endBackSlash = nextUntilUnescaped(source, quote); 376 | setInside(endBackSlash ? quote : null); 377 | return {type: "string", style: "js-string"}; 378 | } 379 | 380 | // Fetch the next token. Dispatches on first character in the 381 | // stream, or first two characters when the first is a slash. 382 | if (inside == "\"" || inside == "'") 383 | return readString(inside); 384 | var ch = source.next(); 385 | if (inside == "/*") 386 | return readMultilineComment(ch); 387 | else if (ch == "\"" || ch == "'") 388 | return readString(ch); 389 | // with punctuation, the type of the token is the symbol itself 390 | else if (/[\[\]{}\(\),;\:\.]/.test(ch)) 391 | return {type: ch, style: "js-punctuation"}; 392 | else if (ch == "0" && (source.equals("x") || source.equals("X"))) 393 | return readHexNumber(); 394 | else if (/[0-9]/.test(ch)) 395 | return readNumber(); 396 | else if (ch == "/"){ 397 | if (source.equals("*")) 398 | { source.next(); return readMultilineComment(ch); } 399 | else if (source.equals("/")) 400 | { nextUntilUnescaped(source, null); return {type: "comment", style: "js-comment"};} 401 | else if (regexp) 402 | return readRegexp(); 403 | else 404 | return readOperator(); 405 | } 406 | else if (isOperatorChar.test(ch)) 407 | return readOperator(); 408 | else 409 | return readWord(); 410 | } 411 | 412 | // The external interface to the tokenizer. 413 | return function(source, startState) { 414 | return tokenizer(source, startState || jsTokenState(false, true)); 415 | }; 416 | })(); 417 | /* Parse function for JavaScript. Makes use of the tokenizer from 418 | * tokenizejavascript.js. Note that your parsers do not have to be 419 | * this complicated -- if you don't want to recognize local variables, 420 | * in many languages it is enough to just look for braces, semicolons, 421 | * parentheses, etc, and know when you are inside a string or comment. 422 | * 423 | * See manual.html for more info about the parser interface. 424 | */ 425 | 426 | var JSParser = Editor.Parser = (function() { 427 | // Token types that can be considered to be atoms. 428 | var atomicTypes = {"atom": true, "number": true, "variable": true, "string": true, "regexp": true}; 429 | // Setting that can be used to have JSON data indent properly. 430 | var json = false; 431 | // Constructor for the lexical context objects. 432 | function JSLexical(indented, column, type, align, prev, info) { 433 | // indentation at start of this line 434 | this.indented = indented; 435 | // column at which this scope was opened 436 | this.column = column; 437 | // type of scope ('vardef', 'stat' (statement), 'form' (special form), '[', '{', or '(') 438 | this.type = type; 439 | // '[', '{', or '(' blocks that have any text after their opening 440 | // character are said to be 'aligned' -- any lines below are 441 | // indented all the way to the opening character. 442 | if (align != null) 443 | this.align = align; 444 | // Parent scope, if any. 445 | this.prev = prev; 446 | this.info = info; 447 | } 448 | 449 | // My favourite JavaScript indentation rules. 450 | function indentJS(lexical) { 451 | return function(firstChars) { 452 | var firstChar = firstChars && firstChars.charAt(0), type = lexical.type; 453 | var closing = firstChar == type; 454 | if (type == "vardef") 455 | return lexical.indented + 4; 456 | else if (type == "form" && firstChar == "{") 457 | return lexical.indented; 458 | else if (type == "stat" || type == "form") 459 | return lexical.indented + indentUnit; 460 | else if (lexical.info == "switch" && !closing) 461 | return lexical.indented + (/^(?:case|default)\b/.test(firstChars) ? indentUnit : 2 * indentUnit); 462 | else if (lexical.align) 463 | return lexical.column - (closing ? 1 : 0); 464 | else 465 | return lexical.indented + (closing ? 0 : indentUnit); 466 | }; 467 | } 468 | 469 | // The parser-iterator-producing function itself. 470 | function parseJS(input, basecolumn) { 471 | // Wrap the input in a token stream 472 | var tokens = tokenizeJavaScript(input); 473 | // The parser state. cc is a stack of actions that have to be 474 | // performed to finish the current statement. For example we might 475 | // know that we still need to find a closing parenthesis and a 476 | // semicolon. Actions at the end of the stack go first. It is 477 | // initialized with an infinitely looping action that consumes 478 | // whole statements. 479 | var cc = [json ? expressions : statements]; 480 | // Context contains information about the current local scope, the 481 | // variables defined in that, and the scopes above it. 482 | var context = null; 483 | // The lexical scope, used mostly for indentation. 484 | var lexical = new JSLexical((basecolumn || 0) - indentUnit, 0, "block", false); 485 | // Current column, and the indentation at the start of the current 486 | // line. Used to create lexical scope objects. 487 | var column = 0; 488 | var indented = 0; 489 | // Variables which are used by the mark, cont, and pass functions 490 | // below to communicate with the driver loop in the 'next' 491 | // function. 492 | var consume, marked; 493 | 494 | // The iterator object. 495 | var parser = {next: next, copy: copy}; 496 | 497 | function next(){ 498 | // Start by performing any 'lexical' actions (adjusting the 499 | // lexical variable), or the operations below will be working 500 | // with the wrong lexical state. 501 | while(cc[cc.length - 1].lex) 502 | cc.pop()(); 503 | 504 | // Fetch a token. 505 | var token = tokens.next(); 506 | 507 | // Adjust column and indented. 508 | if (token.type == "whitespace" && column == 0) 509 | indented = token.value.length; 510 | column += token.value.length; 511 | if (token.content == "\n"){ 512 | indented = column = 0; 513 | // If the lexical scope's align property is still undefined at 514 | // the end of the line, it is an un-aligned scope. 515 | if (!("align" in lexical)) 516 | lexical.align = false; 517 | // Newline tokens get an indentation function associated with 518 | // them. 519 | token.indentation = indentJS(lexical); 520 | } 521 | // No more processing for meaningless tokens. 522 | if (token.type == "whitespace" || token.type == "comment") 523 | return token; 524 | // When a meaningful token is found and the lexical scope's 525 | // align is undefined, it is an aligned scope. 526 | if (!("align" in lexical)) 527 | lexical.align = true; 528 | 529 | // Execute actions until one 'consumes' the token and we can 530 | // return it. 531 | while(true) { 532 | consume = marked = false; 533 | // Take and execute the topmost action. 534 | cc.pop()(token.type, token.content); 535 | if (consume){ 536 | // Marked is used to change the style of the current token. 537 | if (marked) 538 | token.style = marked; 539 | // Here we differentiate between local and global variables. 540 | else if (token.type == "variable" && inScope(token.content)) 541 | token.style = "js-localvariable"; 542 | return token; 543 | } 544 | } 545 | } 546 | 547 | // This makes a copy of the parser state. It stores all the 548 | // stateful variables in a closure, and returns a function that 549 | // will restore them when called with a new input stream. Note 550 | // that the cc array has to be copied, because it is contantly 551 | // being modified. Lexical objects are not mutated, and context 552 | // objects are not mutated in a harmful way, so they can be shared 553 | // between runs of the parser. 554 | function copy(){ 555 | var _context = context, _lexical = lexical, _cc = cc.concat([]), _tokenState = tokens.state; 556 | 557 | return function copyParser(input){ 558 | context = _context; 559 | lexical = _lexical; 560 | cc = _cc.concat([]); // copies the array 561 | column = indented = 0; 562 | tokens = tokenizeJavaScript(input, _tokenState); 563 | return parser; 564 | }; 565 | } 566 | 567 | // Helper function for pushing a number of actions onto the cc 568 | // stack in reverse order. 569 | function push(fs){ 570 | for (var i = fs.length - 1; i >= 0; i--) 571 | cc.push(fs[i]); 572 | } 573 | // cont and pass are used by the action functions to add other 574 | // actions to the stack. cont will cause the current token to be 575 | // consumed, pass will leave it for the next action. 576 | function cont(){ 577 | push(arguments); 578 | consume = true; 579 | } 580 | function pass(){ 581 | push(arguments); 582 | consume = false; 583 | } 584 | // Used to change the style of the current token. 585 | function mark(style){ 586 | marked = style; 587 | } 588 | 589 | // Push a new scope. Will automatically link the current scope. 590 | function pushcontext(){ 591 | context = {prev: context, vars: {"this": true, "arguments": true}}; 592 | } 593 | // Pop off the current scope. 594 | function popcontext(){ 595 | context = context.prev; 596 | } 597 | // Register a variable in the current scope. 598 | function register(varname){ 599 | if (context){ 600 | mark("js-variabledef"); 601 | context.vars[varname] = true; 602 | } 603 | } 604 | // Check whether a variable is defined in the current scope. 605 | function inScope(varname){ 606 | var cursor = context; 607 | while (cursor) { 608 | if (cursor.vars[varname]) 609 | return true; 610 | cursor = cursor.prev; 611 | } 612 | return false; 613 | } 614 | 615 | // Push a new lexical context of the given type. 616 | function pushlex(type, info) { 617 | var result = function(){ 618 | lexical = new JSLexical(indented, column, type, null, lexical, info) 619 | }; 620 | result.lex = true; 621 | return result; 622 | } 623 | // Pop off the current lexical context. 624 | function poplex(){ 625 | lexical = lexical.prev; 626 | } 627 | poplex.lex = true; 628 | // The 'lex' flag on these actions is used by the 'next' function 629 | // to know they can (and have to) be ran before moving on to the 630 | // next token. 631 | 632 | // Creates an action that discards tokens until it finds one of 633 | // the given type. 634 | function expect(wanted){ 635 | return function expecting(type){ 636 | if (type == wanted) cont(); 637 | else cont(arguments.callee); 638 | }; 639 | } 640 | 641 | // Looks for a statement, and then calls itself. 642 | function statements(type){ 643 | return pass(statement, statements); 644 | } 645 | function expressions(type){ 646 | return pass(expression, expressions); 647 | } 648 | // Dispatches various types of statements based on the type of the 649 | // current token. 650 | function statement(type){ 651 | if (type == "var") cont(pushlex("vardef"), vardef1, expect(";"), poplex); 652 | else if (type == "keyword a") cont(pushlex("form"), expression, statement, poplex); 653 | else if (type == "keyword b") cont(pushlex("form"), statement, poplex); 654 | else if (type == "{") cont(pushlex("}"), block, poplex); 655 | else if (type == "function") cont(functiondef); 656 | else if (type == "for") cont(pushlex("form"), expect("("), pushlex(")"), forspec1, expect(")"), poplex, statement, poplex); 657 | else if (type == "variable") cont(pushlex("stat"), maybelabel); 658 | else if (type == "switch") cont(pushlex("form"), expression, pushlex("}", "switch"), expect("{"), block, poplex, poplex); 659 | else if (type == "case") cont(expression, expect(":")); 660 | else if (type == "default") cont(expect(":")); 661 | else if (type == "catch") cont(pushlex("form"), pushcontext, expect("("), funarg, expect(")"), statement, poplex, popcontext); 662 | else pass(pushlex("stat"), expression, expect(";"), poplex); 663 | } 664 | // Dispatch expression types. 665 | function expression(type){ 666 | if (atomicTypes.hasOwnProperty(type)) cont(maybeoperator); 667 | else if (type == "function") cont(functiondef); 668 | else if (type == "keyword c") cont(expression); 669 | else if (type == "(") cont(pushlex(")"), expression, expect(")"), poplex, maybeoperator); 670 | else if (type == "operator") cont(expression); 671 | else if (type == "[") cont(pushlex("]"), commasep(expression, "]"), poplex, maybeoperator); 672 | else if (type == "{") cont(pushlex("}"), commasep(objprop, "}"), poplex, maybeoperator); 673 | else cont(); 674 | } 675 | // Called for places where operators, function calls, or 676 | // subscripts are valid. Will skip on to the next action if none 677 | // is found. 678 | function maybeoperator(type){ 679 | if (type == "operator") cont(expression); 680 | else if (type == "(") cont(pushlex(")"), expression, commasep(expression, ")"), poplex, maybeoperator); 681 | else if (type == ".") cont(property, maybeoperator); 682 | else if (type == "[") cont(pushlex("]"), expression, expect("]"), poplex, maybeoperator); 683 | } 684 | // When a statement starts with a variable name, it might be a 685 | // label. If no colon follows, it's a regular statement. 686 | function maybelabel(type){ 687 | if (type == ":") cont(poplex, statement); 688 | else pass(maybeoperator, expect(";"), poplex); 689 | } 690 | // Property names need to have their style adjusted -- the 691 | // tokenizer thinks they are variables. 692 | function property(type){ 693 | if (type == "variable") {mark("js-property"); cont();} 694 | } 695 | // This parses a property and its value in an object literal. 696 | function objprop(type){ 697 | if (type == "variable") mark("js-property"); 698 | if (atomicTypes.hasOwnProperty(type)) cont(expect(":"), expression); 699 | } 700 | // Parses a comma-separated list of the things that are recognized 701 | // by the 'what' argument. 702 | function commasep(what, end){ 703 | function proceed(type) { 704 | if (type == ",") cont(what, proceed); 705 | else if (type == end) cont(); 706 | else cont(expect(end)); 707 | } 708 | return function commaSeparated(type) { 709 | if (type == end) cont(); 710 | else pass(what, proceed); 711 | }; 712 | } 713 | // Look for statements until a closing brace is found. 714 | function block(type){ 715 | if (type == "}") cont(); 716 | else pass(statement, block); 717 | } 718 | // Variable definitions are split into two actions -- 1 looks for 719 | // a name or the end of the definition, 2 looks for an '=' sign or 720 | // a comma. 721 | function vardef1(type, value){ 722 | if (type == "variable"){register(value); cont(vardef2);} 723 | else cont(); 724 | } 725 | function vardef2(type, value){ 726 | if (value == "=") cont(expression, vardef2); 727 | else if (type == ",") cont(vardef1); 728 | } 729 | // For loops. 730 | function forspec1(type){ 731 | if (type == "var") cont(vardef1, forspec2); 732 | else if (type == ";") pass(forspec2); 733 | else if (type == "variable") cont(formaybein); 734 | else pass(forspec2); 735 | } 736 | function formaybein(type, value){ 737 | if (value == "in") cont(expression); 738 | else cont(maybeoperator, forspec2); 739 | } 740 | function forspec2(type, value){ 741 | if (type == ";") cont(forspec3); 742 | else if (value == "in") cont(expression); 743 | else cont(expression, expect(";"), forspec3); 744 | } 745 | function forspec3(type) { 746 | if (type == ")") pass(); 747 | else cont(expression); 748 | } 749 | // A function definition creates a new context, and the variables 750 | // in its argument list have to be added to this context. 751 | function functiondef(type, value){ 752 | if (type == "variable"){register(value); cont(functiondef);} 753 | else if (type == "(") cont(pushcontext, commasep(funarg, ")"), statement, popcontext); 754 | } 755 | function funarg(type, value){ 756 | if (type == "variable"){register(value); cont();} 757 | } 758 | 759 | return parser; 760 | } 761 | 762 | return { 763 | make: parseJS, 764 | electricChars: "{}:", 765 | configure: function(obj) { 766 | if (obj.json != null) json = obj.json; 767 | } 768 | }; 769 | })(); 770 | --------------------------------------------------------------------------------