LilyPond-Ruby 0.0.2.1 → 0.1.2

data/share/guile/2.2/language/ecmascript/compile-tree-il.scm

@@ -0,0 +1,576 @@
+;;; ECMAScript for Guile
+
+;; Copyright (C) 2009, 2011, 2016 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (language ecmascript compile-tree-il)
+  #:use-module (language tree-il)
+  #:use-module (ice-9 receive)
+  #:use-module (system base pmatch)
+  #:use-module (srfi srfi-1)
+  #:export (compile-tree-il))
+
+(define-syntax-rule (-> (type arg ...))
+  `(type ,arg ...))
+
+(define-syntax-rule (@implv sym)
+  (-> (@ '(language ecmascript impl) 'sym)))
+
+(define-syntax-rule (@impl sym arg ...)
+  (-> (call (@implv sym) arg ...)))
+
+(define (empty-lexical-environment)
+  '())
+
+(define (econs name gensym env)
+  (acons name (-> (lexical name gensym)) env))
+
+(define (lookup name env)
+  (or (assq-ref env name)
+      (-> (toplevel name))))
+
+(define (compile-tree-il exp env opts)
+  (values
+   (parse-tree-il
+    (-> (begin (@impl js-init)
+               (comp exp (empty-lexical-environment)))))
+   env
+   env))
+
+(define (location x)
+  (and (pair? x)
+       (let ((props (source-properties x)))
+	 (and (not (null? props))
+              props))))
+
+;; for emacs:
+;; (put 'pmatch/source 'scheme-indent-function 1)
+
+(define-syntax-rule (pmatch/source x clause ...)
+  (let ((x x))
+    (let ((res (pmatch x
+                 clause ...)))
+      (let ((loc (location x)))
+        (if loc
+            (set-source-properties! res (location x))))
+      res)))
+
+(define current-return-tag (make-parameter #f))
+
+(define (return expr)
+  (-> (abort (or (current-return-tag) (error "return outside function"))
+             (list expr)
+             (-> (const '())))))
+
+(define (with-return-prompt body-thunk)
+  (let ((tag (gensym "return")))
+    (parameterize ((current-return-tag
+                    (-> (lexical 'return tag))))
+      (-> (let '(return) (list tag)
+               (list (-> (primcall 'make-prompt-tag)))
+               (-> (prompt #t
+                           (current-return-tag)
+                           (body-thunk)
+                           (let ((val (gensym "val")))
+                             (-> (lambda '()
+                                   (-> (lambda-case
+                                        `(((k val) #f #f #f () (,(gensym) ,val))
+                                          ,(-> (lexical 'val val)))))))))))))))
+
+(define (comp x e)
+  (let ((l (location x)))
+    (define (let1 what proc)
+      (let ((sym (gensym))) 
+        (-> (let (list sym) (list sym) (list what)
+                 (proc sym)))))
+    (define (begin1 what proc)
+      (let1 what (lambda (v)
+                   (-> (begin (proc v)
+                              (-> (lexical v v)))))))
+    (pmatch/source x
+      (null
+       ;; FIXME, null doesn't have much relation to EOL...
+       (-> (const '())))
+      (true
+       (-> (const #t)))
+      (false
+       (-> (const #f)))
+      ((number ,num)
+       (-> (const num)))
+      ((string ,str)
+       (-> (const str)))
+      (this
+       (@impl get-this))
+      ((+ ,a)
+       (-> (call (-> (primitive '+))
+                 (@impl ->number (comp a e))
+                 (-> (const 0)))))
+      ((- ,a)
+       (-> (call (-> (primitive '-)) (-> (const 0)) (comp a e))))
+      ((~ ,a)
+       (@impl bitwise-not (comp a e)))
+      ((! ,a)
+       (@impl logical-not (comp a e)))
+      ((+ ,a ,b)
+       (-> (call (-> (primitive '+)) (comp a e) (comp b e))))
+      ((- ,a ,b)
+       (-> (call (-> (primitive '-)) (comp a e) (comp b e))))
+      ((/ ,a ,b)
+       (-> (call (-> (primitive '/)) (comp a e) (comp b e))))
+      ((* ,a ,b)
+       (-> (call (-> (primitive '*)) (comp a e) (comp b e))))
+      ((% ,a ,b)
+       (@impl mod (comp a e) (comp b e)))
+      ((<< ,a ,b)
+       (@impl shift (comp a e) (comp b e)))
+      ((>> ,a ,b)
+       (@impl shift (comp a e) (comp `(- ,b) e)))
+      ((< ,a ,b)
+       (-> (call (-> (primitive '<)) (comp a e) (comp b e))))
+      ((<= ,a ,b)
+       (-> (call (-> (primitive '<=)) (comp a e) (comp b e))))
+      ((> ,a ,b)
+       (-> (call (-> (primitive '>)) (comp a e) (comp b e))))
+      ((>= ,a ,b)
+       (-> (call (-> (primitive '>=)) (comp a e) (comp b e))))
+      ((in ,a ,b)
+       (@impl has-property? (comp a e) (comp b e)))
+      ((== ,a ,b)
+       (-> (call (-> (primitive 'equal?)) (comp a e) (comp b e))))
+      ((!= ,a ,b)
+       (-> (call (-> (primitive 'not))
+                 (-> (call (-> (primitive 'equal?))
+                           (comp a e) (comp b e))))))
+      ((=== ,a ,b)
+       (-> (call (-> (primitive 'eqv?)) (comp a e) (comp b e))))
+      ((!== ,a ,b)
+       (-> (call (-> (primitive 'not))
+                 (-> (call (-> (primitive 'eqv?))
+                           (comp a e) (comp b e))))))
+      ((& ,a ,b)
+       (@impl band (comp a e) (comp b e)))
+      ((^ ,a ,b)
+       (@impl bxor (comp a e) (comp b e)))
+      ((bor ,a ,b)
+       (@impl bior (comp a e) (comp b e)))
+      ((and ,a ,b)
+       (-> (if (@impl ->boolean (comp a e))
+               (comp b e)
+               (-> (const #f)))))
+      ((or ,a ,b)
+       (let1 (comp a e)
+             (lambda (v)
+               (-> (if (@impl ->boolean (-> (lexical v v)))
+                       (-> (lexical v v))
+                       (comp b e))))))
+      ((if ,test ,then ,else)
+       (-> (if (@impl ->boolean (comp test e))
+               (comp then e)
+               (comp else e))))
+      ((if ,test ,then)
+       (-> (if (@impl ->boolean (comp test e))
+               (comp then e)
+               (@implv *undefined*))))
+      ((postinc (ref ,foo))
+       (begin1 (comp `(ref ,foo) e)
+               (lambda (var)
+                 (-> (set! (lookup foo e)
+                           (-> (call (-> (primitive '+))
+                                     (-> (lexical var var))
+                                     (-> (const 1)))))))))
+      ((postinc (pref ,obj ,prop))
+       (let1 (comp obj e)
+             (lambda (objvar)
+               (begin1 (@impl pget
+                              (-> (lexical objvar objvar))
+                              (-> (const prop)))
+                       (lambda (tmpvar)
+                         (@impl pput
+                                (-> (lexical objvar objvar))
+                                (-> (const prop))
+                                (-> (call (-> (primitive '+))
+                                          (-> (lexical tmpvar tmpvar))
+                                          (-> (const 1))))))))))
+      ((postinc (aref ,obj ,prop))
+       (let1 (comp obj e)
+             (lambda (objvar)
+               (let1 (comp prop e)
+                     (lambda (propvar)
+                       (begin1 (@impl pget
+                                      (-> (lexical objvar objvar))
+                                      (-> (lexical propvar propvar)))
+                               (lambda (tmpvar)
+                                 (@impl pput
+                                        (-> (lexical objvar objvar))
+                                        (-> (lexical propvar propvar))
+                                        (-> (call (-> (primitive '+))
+                                                  (-> (lexical tmpvar tmpvar))
+                                                  (-> (const 1))))))))))))
+      ((postdec (ref ,foo))
+       (begin1 (comp `(ref ,foo) e)
+               (lambda (var)
+                 (-> (set (lookup foo e)
+                          (-> (call (-> (primitive '-))
+                                    (-> (lexical var var))
+                                    (-> (const 1)))))))))
+      ((postdec (pref ,obj ,prop))
+       (let1 (comp obj e)
+             (lambda (objvar)
+               (begin1 (@impl pget
+                              (-> (lexical objvar objvar))
+                              (-> (const prop)))
+                       (lambda (tmpvar)
+                         (@impl pput
+                                (-> (lexical objvar objvar))
+                                (-> (const prop))
+                                (-> (call (-> (primitive '-))
+                                          (-> (lexical tmpvar tmpvar))
+                                          (-> (const 1))))))))))
+      ((postdec (aref ,obj ,prop))
+       (let1 (comp obj e)
+             (lambda (objvar)
+               (let1 (comp prop e)
+                     (lambda (propvar)
+                       (begin1 (@impl pget
+                                      (-> (lexical objvar objvar))
+                                      (-> (lexical propvar propvar)))
+                               (lambda (tmpvar)
+                                 (@impl pput
+                                        (-> (lexical objvar objvar))
+                                        (-> (lexical propvar propvar))
+                                        (-> (inline
+                                             '- (-> (lexical tmpvar tmpvar))
+                                             (-> (const 1))))))))))))
+      ((preinc (ref ,foo))
+       (let ((v (lookup foo e)))
+         (-> (begin
+               (-> (set! v
+                         (-> (call (-> (primitive '+))
+                                   v
+                                   (-> (const 1))))))
+               v))))
+      ((preinc (pref ,obj ,prop))
+       (let1 (comp obj e)
+             (lambda (objvar)
+               (begin1 (-> (call (-> (primitive '+))
+                                 (@impl pget
+                                        (-> (lexical objvar objvar))
+                                        (-> (const prop)))
+                                 (-> (const 1))))
+                       (lambda (tmpvar)
+                         (@impl pput (-> (lexical objvar objvar))
+                                (-> (const prop))
+                                (-> (lexical tmpvar tmpvar))))))))
+      ((preinc (aref ,obj ,prop))
+       (let1 (comp obj e)
+             (lambda (objvar)
+               (let1 (comp prop e)
+                     (lambda (propvar)
+                       (begin1 (-> (call (-> (primitive '+))
+                                         (@impl pget
+                                                (-> (lexical objvar objvar))
+                                                (-> (lexical propvar propvar)))
+                                         (-> (const 1))))
+                               (lambda (tmpvar)
+                                 (@impl pput
+                                        (-> (lexical objvar objvar))
+                                        (-> (lexical propvar propvar))
+                                        (-> (lexical tmpvar tmpvar))))))))))
+      ((predec (ref ,foo))
+       (let ((v (lookup foo e)))
+         (-> (begin
+               (-> (set! v
+                         (-> (call (-> (primitive '-))
+                                   v
+                                   (-> (const 1))))))
+               v))))
+      ((predec (pref ,obj ,prop))
+       (let1 (comp obj e)
+             (lambda (objvar)
+               (begin1 (-> (call (-> (primitive '-))
+                                 (@impl pget
+                                        (-> (lexical objvar objvar))
+                                        (-> (const prop)))
+                                 (-> (const 1))))
+                       (lambda (tmpvar)
+                         (@impl pput
+                                (-> (lexical objvar objvar))
+                                (-> (const prop))
+                                (-> (lexical tmpvar tmpvar))))))))
+      ((predec (aref ,obj ,prop))
+       (let1 (comp obj e)
+             (lambda (objvar)
+               (let1 (comp prop e)
+                     (lambda (propvar)
+                       (begin1 (-> (call (-> (primitive '-))
+                                         (@impl pget
+                                                (-> (lexical objvar objvar))
+                                                (-> (lexical propvar propvar)))
+                                         (-> (const 1))))
+                               (lambda (tmpvar)
+                                 (@impl pput
+                                        (-> (lexical objvar objvar))
+                                        (-> (lexical propvar propvar))
+                                        (-> (lexical tmpvar tmpvar))))))))))
+      ((ref ,id)
+       (lookup id e))
+      ((var . ,forms)
+       `(begin
+          ,@(map (lambda (form)
+                   (pmatch form
+                     ((,x ,y)
+                      (-> (define x (comp y e))))
+                     ((,x)
+                      (-> (define x (@implv *undefined*))))
+                     (else (error "bad var form" form))))
+                 forms)))
+      ((begin)
+       (-> (void)))
+      ((begin ,form)
+       (comp form e))
+      ((begin . ,forms)
+       `(begin ,@(map (lambda (x) (comp x e)) forms)))
+      ((lambda ,formals ,body)
+       (let ((syms (map (lambda (x)
+                          (gensym (string-append (symbol->string x) " ")))
+                        formals)))
+         `(lambda ()
+            (lambda-case
+             ((() ,formals #f #f ,(map (lambda (x) (@implv *undefined*)) formals) ,syms)
+              ,(with-return-prompt
+                (lambda ()
+                  (comp-body e body formals syms))))))))
+      ((call/this ,obj ,prop . ,args)
+       (@impl call/this*
+              obj
+              (-> (lambda '() 
+                    `(lambda-case
+                      ((() #f #f #f () ())
+                       (call ,(@impl pget obj prop) ,@args)))))))
+      ((call (pref ,obj ,prop) ,args)
+       (comp `(call/this ,(comp obj e)
+                         ,(-> (const prop))
+                         ,@(map (lambda (x) (comp x e)) args))
+             e))
+      ((call (aref ,obj ,prop) ,args)
+       (comp `(call/this ,(comp obj e)
+                         ,(comp prop e)
+                         ,@(map (lambda (x) (comp x e)) args))
+             e))
+      ((call ,proc ,args)
+       `(call ,(comp proc e)                
+              ,@(map (lambda (x) (comp x e)) args)))
+      ((return ,expr)
+       (return (comp expr e)))
+      ((array . ,args)
+       `(call ,(@implv new-array)
+              ,@(map (lambda (x) (comp x e)) args)))
+      ((object . ,args)
+       `(call ,(@implv new-object)
+              ,@(map (lambda (x)
+                       (pmatch x
+                         ((,prop ,val)
+                          (-> (call (-> (primitive 'cons))
+                                    (-> (const prop))
+                                    (comp val e))))
+                         (else
+                          (error "bad prop-val pair" x))))
+                     args)))
+      ((pref ,obj ,prop)
+       (@impl pget
+              (comp obj e)
+              (-> (const prop))))
+      ((aref ,obj ,index)
+       (@impl pget
+              (comp obj e)
+              (comp index e)))
+      ((= (ref ,name) ,val)
+       (let ((v (lookup name e)))
+         (-> (begin
+               (-> (set! v (comp val e)))
+               v))))
+      ((= (pref ,obj ,prop) ,val)
+       (@impl pput
+              (comp obj e)
+              (-> (const prop))
+              (comp val e)))
+      ((= (aref ,obj ,prop) ,val)
+       (@impl pput
+              (comp obj e)
+              (comp prop e)
+              (comp val e)))
+      ((+= ,what ,val)
+       (comp `(= ,what (+ ,what ,val)) e))
+      ((-= ,what ,val)
+       (comp `(= ,what (- ,what ,val)) e))
+      ((/= ,what ,val)
+       (comp `(= ,what (/ ,what ,val)) e))
+      ((*= ,what ,val)
+       (comp `(= ,what (* ,what ,val)) e))
+      ((%= ,what ,val)
+       (comp `(= ,what (% ,what ,val)) e))
+      ((>>= ,what ,val)
+       (comp `(= ,what (>> ,what ,val)) e))
+      ((<<= ,what ,val)
+       (comp `(= ,what (<< ,what ,val)) e))
+      ((>>>= ,what ,val)
+       (comp `(= ,what (>>> ,what ,val)) e))
+      ((&= ,what ,val)
+       (comp `(= ,what (& ,what ,val)) e))
+      ((bor= ,what ,val)
+       (comp `(= ,what (bor ,what ,val)) e))
+      ((^= ,what ,val)
+       (comp `(= ,what (^ ,what ,val)) e))
+      ((new ,what ,args)
+       `(call ,(@implv new)
+              ,(comp what e)
+              ,@(map (lambda (x) (comp x e)) args)))
+      ((delete (pref ,obj ,prop))
+       (@impl pdel
+              (comp obj e)
+              (-> (const prop))))
+      ((delete (aref ,obj ,prop))
+       (@impl pdel
+              (comp obj e)
+              (comp prop e)))
+      ((void ,expr)
+       (-> (begin
+             (comp expr e)
+             (@implv *undefined*))))
+      ((typeof ,expr)
+       (@impl typeof
+              (comp expr e)))
+      ((do ,statement ,test)
+       (let ((%loop (gensym "%loop "))
+             (%continue (gensym "%continue ")))
+         (let ((e (econs '%loop %loop (econs '%continue %continue e))))
+           (-> (letrec '(%loop %continue) (list %loop %continue)
+                       (list (-> (lambda '()
+                                   (-> (lambda-case
+                                        `((() #f #f #f () ())
+                                          ,(-> (begin
+                                                 (comp statement e)
+                                                 (-> (call (-> (lexical '%continue %continue)))))))))))
+                             (-> (lambda '()
+                                   (-> (lambda-case
+                                        `((() #f #f #f () ())
+                                          ,(-> (if (@impl ->boolean (comp test e))
+                                                   (-> (call (-> (lexical '%loop %loop))))
+                                                   (@implv *undefined*)))))))))
+                       (-> (call (-> (lexical '%loop %loop)))))))))
+      ((while ,test ,statement)
+       (let ((%continue (gensym "%continue ")))
+         (let ((e (econs '%continue %continue e)))
+           (-> (letrec '(%continue) (list %continue)
+                       (list (-> (lambda '()
+                                   (-> (lambda-case
+                                        `((() #f #f #f () ())
+                                          ,(-> (if (@impl ->boolean (comp test e))
+                                                   (-> (begin (comp statement e)
+                                                              (-> (call (-> (lexical '%continue %continue))))))
+                                                   (@implv *undefined*)))))))))
+                       (-> (call (-> (lexical '%continue %continue)))))))))
+      
+      ((for ,init ,test ,inc ,statement)
+       (let ((%continue (gensym "%continue ")))
+         (let ((e (econs '%continue %continue e)))
+           (-> (letrec '(%continue) (list %continue)
+                       (list (-> (lambda '()
+                                   (-> (lambda-case
+                                        `((() #f #f #f () ())
+                                          ,(-> (if (if test
+                                                       (@impl ->boolean (comp test e))
+                                                       (comp 'true e))
+                                                   (-> (begin (comp statement e)
+                                                              (comp (or inc '(begin)) e)
+                                                              (-> (call (-> (lexical '%continue %continue))))))
+                                                   (@implv *undefined*)))))))))
+                       (-> (begin (comp (or init '(begin)) e)
+                                  (-> (call (-> (lexical '%continue %continue)))))))))))
+      
+      ((for-in ,var ,object ,statement)
+       (let ((%enum (gensym "%enum "))
+             (%continue (gensym "%continue ")))
+         (let ((e (econs '%enum %enum (econs '%continue %continue e))))
+           (-> (letrec '(%enum %continue) (list %enum %continue)
+                       (list (@impl make-enumerator (comp object e))
+                             (-> (lambda '()
+                                   (-> (lambda-case
+                                        `((() #f #f #f () ())
+                                          (-> (if (@impl ->boolean
+                                                         (@impl pget
+                                                                (-> (lexical '%enum %enum))
+                                                                (-> (const 'length))))
+                                                  (-> (begin
+                                                        (comp `(= ,var (call/this ,(-> (lexical '%enum %enum))
+                                                                                  ,(-> (const 'pop))))
+                                                              e)
+                                                        (comp statement e)
+                                                        (-> (call (-> (lexical '%continue %continue))))))
+                                                  (@implv *undefined*)))))))))
+                       (-> (call (-> (lexical '%continue %continue)))))))))
+      
+      ((block ,x)
+       (comp x e))
+      (else
+       (error "compilation not yet implemented:" x)))))
+
+(define (comp-body e body formals formal-syms)
+  (define (process)
+    (let lp ((in body) (out '()) (rvars '()))
+      (pmatch in
+        (((var (,x) . ,morevars) . ,rest)
+         (lp `((var . ,morevars) . ,rest)
+             out
+             (if (or (memq x rvars) (memq x formals))
+                 rvars
+                 (cons x rvars))))
+        (((var (,x ,y) . ,morevars) . ,rest)
+         (lp `((var . ,morevars) . ,rest)
+             `((= (ref ,x) ,y) . ,out)
+             (if (or (memq x rvars) (memq x formals))
+                 rvars
+                 (cons x rvars))))
+        (((var) . ,rest)
+         (lp rest out rvars))
+        ((,x . ,rest) (guard (and (pair? x) (eq? (car x) 'lambda)))
+         (lp rest
+             (cons x out)
+             rvars))
+        ((,x . ,rest) (guard (pair? x))
+         (receive (sub-out rvars)
+             (lp x '() rvars)
+           (lp rest
+               (cons sub-out out)
+               rvars)))
+        ((,x . ,rest)
+         (lp rest
+             (cons x out)
+             rvars))
+        (()
+         (values (reverse! out)
+                 rvars)))))
+  (receive (out rvars)
+      (process)
+    (let* ((names (reverse rvars))
+           (syms (map (lambda (x)
+                        (gensym (string-append (symbol->string x) " ")))
+                      names))
+           (e (fold econs (fold econs e formals formal-syms) names syms)))
+      (-> (let names syms (map (lambda (x) (@implv *undefined*)) names)
+               (comp out e))))))

data/share/guile/2.2/language/ecmascript/function.scm

@@ -0,0 +1,78 @@
+;;; ECMAScript for Guile
+
+;; Copyright (C) 2009 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (language ecmascript function)
+  #:use-module (oop goops)
+  #:use-module (language ecmascript base)
+  #:export (*function-prototype* *program-wrappers*))
+
+
+(define-class <js-program-wrapper> (<js-object>))
+
+(define *program-wrappers* (make-doubly-weak-hash-table 31))
+
+(define *function-prototype* (make <js-object> #:class "Function"
+                                   #:value (lambda args *undefined*)))
+
+(define-js-method *function-prototype* (toString)
+  (format #f "~A" (js-value this)))
+
+(define-js-method *function-prototype* (apply this-arg array)
+  (cond ((or (null? array) (eq? array *undefined*))
+         (call/this this-arg (js-value this)))
+        ((is-a? array <js-array-object>)
+         (call/this this-arg
+                    (lambda ()
+                      (apply (js-value this)
+                             (vector->list (js-array-vector array))))))
+        (else
+         (throw 'TypeError 'apply array))))
+
+(define-js-method *function-prototype* (call this-arg . args)
+  (call/this this-arg
+             (lambda ()
+               (apply (js-value this) args))))
+
+(define-method (pget (o <applicable>) p)
+  (let ((wrapper (hashq-ref *program-wrappers* o)))
+    (if wrapper
+        (pget wrapper p)
+        (pget *function-prototype* p))))
+
+(define-method (pput (o <applicable>) p v)
+  (let ((wrapper (hashq-ref *program-wrappers* o)))
+    (if wrapper
+        (pput wrapper p v)
+        (let ((wrapper (make <js-program-wrapper> #:value o #:class "Function"
+                             #:prototype *function-prototype*)))
+          (hashq-set! *program-wrappers* o wrapper)
+          (pput wrapper p v)))))
+
+(define-method (js-prototype (o <applicable>))
+  (let ((wrapper (hashq-ref *program-wrappers* o)))
+    (if wrapper
+        (js-prototype wrapper)
+        #f)))
+
+(define-method (js-constructor (o <applicable>))
+  (let ((wrapper (hashq-ref *program-wrappers* o)))
+    (if wrapper
+        (js-constructor wrapper)
+        #f)))