code:
;;; Guile VM code converters

;; Copyright (C) 2001, 2009, 2010 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 assembly disassemble)
  #:use-module (ice-9 format)
  #:use-module (srfi srfi-1)
  #:use-module (system vm instruction)
  #:use-module (system vm program)
  #:use-module (system base pmatch)
  #:use-module (language assembly)
  #:use-module (system base compile)
  #:export (disassemble))

(define (disassemble x)
  (format #t "Disassembly of ~A:\n\n" x)
  (call-with-values
      (lambda () (decompile x #:from 'value #:to 'assembly))
    disassemble-load-program))

(define (disassemble-load-program asm env)
  (pmatch asm
    ((load-program ,labels ,len ,meta . ,code)
     (let ((objs  (and env (assq-ref env 'objects)))
           (free-vars (and env (assq-ref env 'free-vars)))
           (meta  (and env (assq-ref env 'meta)))
           (blocs (and env (assq-ref env 'blocs)))
           (srcs  (and env (assq-ref env 'sources))))
       (let lp ((pos 0) (code code) (programs '()))
         (cond
          ((null? code)
           (newline)
           (for-each
            (lambda (sym+asm)
              (format #t "Embedded program ~A:\n\n" (car sym+asm))
              (disassemble-load-program (cdr sym+asm) '()))
            (reverse! programs)))
          (else
           (let* ((asm (car code))
                  (len (byte-length asm))
                  (end (+ pos len)))
             (pmatch asm
               ((load-program . _)
                (let ((sym (gensym "")))
                  (print-info pos `(load-program ,sym) #f #f)
                  (lp (+ pos (byte-length asm)) (cdr code)
                      (acons sym asm programs))))
               ((nop)
                (lp (+ pos (byte-length asm)) (cdr code) programs))
               (else
                (print-info pos asm
                            ;; FIXME: code-annotation for whether it's
                            ;; an arg or not, currently passing nargs=-1
                            (code-annotation end asm objs -1 blocs
                                             labels)
                            (and=> (and srcs (assq end srcs)) source->string))
                (lp (+ pos (byte-length asm)) (cdr code) programs)))))))

       (if (pair? free-vars)
           (disassemble-free-vars free-vars))
       (if meta
           (disassemble-meta meta))

       ;; Disassemble other bytecode in it
       ;; FIXME: something about the module.
       (if objs
           (for-each
            (lambda (x)
              (if (program? x)
                  (begin (display "----------------------------------------\n")
                         (disassemble x))))
            (cdr (vector->list objs))))))
    (else
     (error "bad load-program form" asm))))

(define (disassemble-free-vars free-vars)
  (display "Free variables:\n\n")
  (fold (lambda (free-var i)
          (print-info i free-var #f #f)
          (+ 1 i))
        0
        free-vars))

(define-macro (unless test . body)
  `(if (not ,test) (begin ,@body)))

(define *uninteresting-props* '(name))

(define (disassemble-meta meta)
  (let ((props (filter (lambda (x)
                         (not (memq (car x) *uninteresting-props*)))
                       (cdddr meta))))
    (unless (null? props)
      (display "Properties:\n\n")
      (for-each (lambda (x) (print-info #f x #f #f)) props)
      (newline))))

(define (source->string src)
  (format #f "~a:~a:~a" (or (source:file src) "(unknown file)")
          (source:line src) (source:column src)))

(define (make-int16 byte1 byte2)
  (+ (* byte1 256) byte2))

(define (code-annotation end-addr code objs nargs blocs labels)
  (let* ((code (assembly-unpack code))
         (inst (car code))
         (args (cdr code)))
    (case inst
      ((list vector)
       (list "~a element~:p" (apply make-int16 args)))
      ((br br-if br-if-eq br-if-not br-if-not-eq br-if-not-null br-if-null)
       (list "-> ~A" (assq-ref labels (car args))))
      ((br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt)
       (list "-> ~A" (assq-ref labels (caddr args))))
      ((object-ref)
       (and objs (list "~s" (vector-ref objs (car args)))))
      ((local-ref local-boxed-ref local-set local-boxed-set)
       (and blocs
            (let lp ((bindings (list-ref blocs (car args))))
              (and (pair? bindings)
                   (let ((b (car bindings)))
                     (if (and (< (binding:start (car bindings)) end-addr)
                              (>= (binding:end (car bindings)) end-addr))
                         (list "`~a'~@[ (arg)~]"
                               (binding:name b) (< (binding:index b) nargs))
                         (lp (cdr bindings))))))))
      ((free-ref free-boxed-ref free-boxed-set)
       ;; FIXME: we can do better than this
       (list "(closure variable)"))
      ((toplevel-ref toplevel-set)
       (and objs
            (let ((v (vector-ref objs (car args))))
              (if (and (variable? v) (variable-bound? v))
                  (list "~s" (variable-ref v))
                  (list "`~s'" v)))))
      ((mv-call)
       (list "MV -> ~A" (assq-ref labels (cadr args))))
      ((prompt)
       ;; the H is for handler
       (list "H -> ~A" (assq-ref labels (cadr args))))
      (else
       (and=> (assembly->object code)
              (lambda (obj) (list "~s" obj)))))))

;; i am format's daddy.
(define (print-info addr info extra src)
  (format #t "~4@S    ~32S~@[;; ~1{~@?~}~]~@[~61t at ~a~]\n" addr info extra src))


code:
;;; Guile Virtual Machine Assembly

;; Copyright (C) 2001, 2009, 2010 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 assembly spec)
  #:use-module (system base language)
  #:use-module (language assembly compile-bytecode)
  #:use-module (language assembly decompile-bytecode)
  #:export (assembly))

(define-language assembly
  #:title	"Guile Virtual Machine Assembly Language"
  #:reader	(lambda (port env) (read port))
  #:printer	write
  #:parser      read ;; fixme: make a verifier?
  #:compilers   `((bytecode . ,compile-bytecode))
  #:decompilers `((bytecode . ,decompile-bytecode))
  )

license: mit


code:
;;; Brainfuck for GNU 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 brainfuck compile-scheme)
  #:export (compile-scheme))

;; Compilation of Brainfuck to Scheme is pretty straight-forward.  For all of
;; brainfuck's instructions, there are basic representations in Scheme we
;; only have to generate.
;;
;; Brainfuck's pointer and data-tape are stored in the variables pointer and
;; tape, where tape is a vector of integer values initially set to zero.  Pointer
;; starts out at position 0.
;; Our tape is thus of finite length, with an address range of 0..n for
;; some defined upper bound n depending on the length of our tape.

;; Define the length to use for the tape.

(define tape-size 30000)

;; This compiles a whole brainfuck program.  This constructs a Scheme code like:
;; (let ((pointer 0)
;;       (tape (make-vector tape-size 0)))
;;   (begin
;;     <body>
;;     (write-char #\newline)))
;;
;; So first the pointer and tape variables are set up correctly, then the
;; program's body is executed in this context, and finally we output an
;; additional newline character in case the program does not output one.
;;
;; TODO: Find out and explain the details about env, the three return values and
;; how to use the options.  Implement options to set the tape-size, maybe.

(define (compile-scheme exp env opts)
  (values
    `(let ((pointer 0)
           (tape (make-vector ,tape-size 0)))
       ,@(if (not (eq? '<brainfuck> (car exp)))
           (error "expected brainfuck program")
           `(begin
              ,@(compile-body (cdr exp))
              (write-char #\newline))))
    env
    env))

;; Compile a list of instructions to get a list of Scheme codes.  As we always
;; strip off the car of the instructions-list and cons the result onto the
;; result-list, it will get out in reversed order first; so we have to (reverse)
;; it on return.

(define (compile-body instructions)
  (let iterate ((cur instructions)
                (result '()))
    (if (null? cur)
      (reverse result)
      (let ((compiled (compile-instruction (car cur))))
        (iterate (cdr cur) (cons compiled result))))))

;; Compile a single instruction to Scheme, using the direct representations
;; all of Brainfuck's instructions have.

(define (compile-instruction ins)
  (case (car ins)

    ;; Pointer moval >< is done simply by something like:
    ;; (set! pointer (+ pointer +-1))
    ((<bf-move>)
     (let ((dir (cadr ins)))
       `(set! pointer (+ pointer ,dir))))

    ;; Cell increment +- is done as:
    ;; (vector-set! tape pointer (+ (vector-ref tape pointer) +-1))
    ((<bf-increment>)
     (let ((inc (cadr ins)))
       `(vector-set! tape pointer (+ (vector-ref tape pointer) ,inc))))

    ;; Output . is done by converting the cell's integer value to a character
    ;; first and then printing out this character:
    ;; (write-char (integer->char (vector-ref tape pointer)))
    ((<bf-print>)
     '(write-char (integer->char (vector-ref tape pointer))))

    ;; Input , is done similarly, read in a character, get its ASCII code and
    ;; store it into the current cell:
    ;; (vector-set! tape pointer (char->integer (read-char)))
    ((<bf-read>)
     '(vector-set! tape pointer (char->integer (read-char))))

    ;; For loops [...] we use a named let construction to execute the body until
    ;; the current cell gets zero.  The body is compiled via a recursive call
    ;; back to (compile-body).
    ;; (let iterate ()
    ;;   (if (not (= (vector-ref! tape pointer) 0))
    ;;     (begin
    ;;       <body>
    ;;       (iterate))))
    ((<bf-loop>)
     `(let iterate ()
        (if (not (= (vector-ref tape pointer) 0))
          (begin
            ,@(compile-body (cdr ins))
            (iterate)))))

    (else (error "unknown brainfuck instruction " (car ins)))))


code:
;;; Brainfuck for GNU 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

;;; Commentary:

;; Brainfuck is a simple language that mostly mimics the operations of a
;; Turing machine. This file implements a compiler from Brainfuck to
;; Guile's Tree-IL.

;;; Code:

(define-module (language brainfuck compile-tree-il)
  #:use-module (system base pmatch)
  #:use-module (language tree-il)
  #:export (compile-tree-il))

;; Compilation of Brainfuck is pretty straight-forward. For all of
;; brainfuck's instructions, there are basic representations in Tree-IL
;; we only have to generate.
;;
;; Brainfuck's pointer and data-tape are stored in the variables pointer and
;; tape, where tape is a vector of integer values initially set to zero.  Pointer
;; starts out at position 0.
;; Our tape is thus of finite length, with an address range of 0..n for
;; some defined upper bound n depending on the length of our tape.

;; Define the length to use for the tape.

(define tape-size 30000)

;; This compiles a whole brainfuck program. This constructs a Tree-IL
;; code equivalent to Scheme code like this:
;;
;;    (let ((pointer 0)
;;          (tape (make-vector tape-size 0)))
;;      (begin
;;       <body>
;;       (write-char #\newline)))
;;
;; So first the pointer and tape variables are set up correctly, then the
;; program's body is executed in this context, and finally we output an
;; additional newline character in case the program does not output one.
;;
;; The fact that we are compiling to Guile primitives gives this
;; implementation a number of interesting characteristics. First, the
;; values of the tape cells do not underflow or overflow. We could make
;; them do otherwise via compiling calls to "modulo" at certain points.
;;
;; In addition, tape overruns or underruns will be detected, and will
;; throw an error, whereas a number of Brainfuck compilers do not detect
;; this.
;;
;; Note that we're generating the S-expression representation of
;; Tree-IL, then using parse-tree-il to turn it into the actual Tree-IL
;; data structures. This makes the compiler more pleasant to look at,
;; but we do lose is the ability to propagate source information. Since
;; Brainfuck is so obtuse anyway, this shouldn't matter ;-)
;;
;; `compile-tree-il' takes as its input the read expression, the
;; environment, and some compile options. It returns the compiled
;; expression, the environment appropriate for the next pass of the
;; compiler -- in our case, just the environment unchanged -- and the
;; continuation environment.
;;
;; The normal use of a continuation environment is if compiling one
;; expression changes the environment, and that changed environment
;; should be passed to the next compiled expression -- for example,
;; changing the current module. But Brainfuck is incapable of that, so
;; for us, the continuation environment is just the same environment we
;; got in.
;;
;; FIXME: perhaps use options or the env to set the tape-size?

(define (compile-tree-il exp env opts)
  (values
   (parse-tree-il
    `(let (pointer tape) (pointer tape)
          ((const 0)
           (apply (primitive make-vector) (const ,tape-size) (const 0)))
          ,(compile-body exp)))
   env
   env))

;; Compile a list of instructions to a Tree-IL expression.

(define (compile-body instructions)
  (let lp ((in instructions) (out '()))
    (define (emit x)
      (lp (cdr in) (cons x out)))
    (cond
     ((null? in)
      ;; No more input, build our output.
       (cond
        ((null? out) '(void)) ; no output
        ((null? (cdr out)) (car out)) ; single expression
        (else `(begin ,@(reverse out))))  ; sequence
       )
     (else
      (pmatch (car in)

        ;; Pointer moves >< are done simply by something like:
        ;;   (set! pointer (+ pointer +-1))
        ((<bf-move> ,dir)
         (emit `(set! (lexical pointer)
                      (apply (primitive +) (lexical pointer) (const ,dir)))))

        ;; Cell increment +- is done as:
        ;;   (vector-set! tape pointer (+ (vector-ref tape pointer) +-1))
        ((<bf-increment> ,inc)
         (emit `(apply (primitive vector-set!) (lexical tape) (lexical pointer)
                       (apply (primitive +)
                              (apply (primitive vector-ref)
                                     (lexical tape) (lexical pointer))
                              (const ,inc)))))

        ;; Output . is done by converting the cell's integer value to a
        ;; character first and then printing out this character:
        ;;   (write-char (integer->char (vector-ref tape pointer)))
        ((<bf-print>)
         (emit `(apply (primitive write-char)
                       (apply (primitive integer->char)
                              (apply (primitive vector-ref)
                                     (lexical tape) (lexical pointer))))))

        ;; Input , is done similarly, read in a character, get its ASCII
        ;; code and store it into the current cell:
        ;;   (vector-set! tape pointer (char->integer (read-char)))
        ((<bf-read>)
         (emit `(apply (primitive vector-set!)
                       (lexical tape) (lexical pointer)
                       (apply (primitive char->integer)
                              (apply (primitive read-char))))))

        ;; For loops [...] we use a letrec construction to execute the body until
        ;; the current cell gets zero.  The body is compiled via a recursive call
        ;; back to (compile-body).
        ;;   (let iterate ()
        ;;     (if (not (= (vector-ref! tape pointer) 0))
        ;;         (begin
        ;;          <body>
        ;;          (iterate))))
        ;;
        ;; Indeed, letrec is the only way we have to loop in Tree-IL.
        ;; Note that this does not mean that the closure must actually
        ;; be created; later passes can compile tail-recursive letrec
        ;; calls into inline code with gotos. Admittedly, that part of
        ;; the compiler is not yet in place, but it will be, and in the
        ;; meantime the code is still reasonably efficient.
        ((<bf-loop> . ,body)
         (let ((iterate (gensym)))
           (emit `(letrec (iterate) (,iterate)
                          ((lambda ()
                             (lambda-case
                              ((() #f #f #f () ())
                               (if (apply (primitive =)
                                          (apply (primitive vector-ref)
                                                 (lexical tape) (lexical pointer))
                                          (const 0))
                                   (void)
                                   (begin ,(compile-body body)
                                          (apply (lexical ,iterate)))))
                              #f)))
                     (apply (lexical ,iterate))))))

        (else (error "unknown brainfuck instruction" (car in))))))))


code:
;;; Brainfuck for GNU 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 brainfuck parse)
  #:export (read-brainfuck))

; Purpose of the parse module is to read in brainfuck in text form and produce
; the corresponding tree representing the brainfuck code.
;
; Each object (representing basically a single instruction) is structured like:
; (<instruction> [arguments])
; where <instruction> is a symbolic name representing the type of instruction
; and the optional arguments represent further data (for instance, the body of
; a [...] loop as a number of nested instructions).
;
; A full brainfuck program is represented by the (<brainfuck> instructions)
; object.

; While reading a number of instructions in sequence, all of them are cons'ed
; onto a list of instructions; thus this list gets out in reverse order.
; Additionally, for "comment characters" (everything not an instruction) we
; generate <bf-nop> NOP instructions.
;
; This routine reverses a list of instructions and removes all <bf-nop>'s on the
; way to fix these two issues for a read-in list.

(define (reverse-without-nops lst)
  (let iterate ((cur lst)
                (result '()))
    (if (null? cur)
      result
      (let ((head (car cur))
            (tail (cdr cur)))
        (if (eq? (car head) '<bf-nop>)
          (iterate tail result)
          (iterate tail (cons head result)))))))

; Read in a set of instructions until a terminating ] character is found (or
; end of file is reached).  This is used both for loop bodies and whole
; programs, so that a program has to be either terminated by EOF or an
; additional ], too.
;
; For instance, the basic program so just echo one character would be:
; ,.]

(define (read-brainfuck p)
  (let iterate ((parsed '()))
    (let ((chr (read-char p)))
      (cond
       ((eof-object? chr)
        (let ((parsed (reverse-without-nops parsed)))
          (if (null? parsed)
              chr ;; pass on the EOF object
              parsed)))
       ((eqv? chr #\])
        (reverse-without-nops parsed))
       (else
        (iterate (cons (process-input-char chr p) parsed)))))))

; This routine processes a single character of input and builds the
; corresponding instruction.  Loop bodies are read by recursively calling
; back (read-brainfuck).
;
; For the poiner movement commands >< and the cell increment/decrement +-
; commands, we only use one instruction form each and specify the direction of
; the pointer/value increment using an argument to the instruction form.

(define (process-input-char chr p)
  (case chr
    ((#\>) '(<bf-move> 1))
    ((#\<) '(<bf-move> -1))
    ((#\+) '(<bf-increment> 1))
    ((#\-) '(<bf-increment> -1))
    ((#\.) '(<bf-print>))
    ((#\,) '(<bf-read>))
    ((#\[) `(<bf-loop> ,@(read-brainfuck p)))
    (else '(<bf-nop>))))


code:
;;; Brainfuck for GNU Guile.

;; Copyright (C) 2009, 2010 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 brainfuck spec)
  #:use-module (language brainfuck compile-tree-il)
  #:use-module (language brainfuck compile-scheme)
  #:use-module (language brainfuck parse)
  #:use-module (system base language)
  #:export (brainfuck))

; The new language is integrated into Guile via this (define-language)
; specification in the special module (language [lang] spec).
; Provided is a parser-routine in #:reader, a output routine in #:printer
; and one or more compiler routines (as target-language - routine pairs)
; in #:compilers.  This is the basic set of fields needed to specify a new
; language.

(define-language brainfuck
  #:title	"Brainfuck"
  #:reader	(lambda (port env) (read-brainfuck port))
  #:compilers	`((tree-il . ,compile-tree-il)
                  (scheme . ,compile-scheme))
  #:printer	write
  )


code:
;;; Guile Lowlevel Intermediate Language

;; Copyright (C) 2001, 2009, 2010 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 bytecode spec)
  #:use-module (system base language)
  #:use-module (system vm objcode)
  #:export (bytecode))

(define (compile-objcode x e opts)
  (values (bytecode->objcode x) e e))

(define (decompile-objcode x e opts)
  (values (objcode->bytecode x) e))

(define-language bytecode
  #:title	"Guile Bytecode Vectors"
  #:reader	(lambda (port env) (read port))
  #:printer	write
  #:compilers   `((objcode . ,compile-objcode))
  #:decompilers `((objcode . ,decompile-objcode))
  )


code:
;;; ECMAScript for Guile

;; Copyright (C) 2009, 2010 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 array)
  #:use-module (oop goops)
  #:use-module (language ecmascript base)
  #:use-module (language ecmascript function)
  #:export (*array-prototype* new-array))

(define-class <js-array-object> (<js-object>)
  (vector #:init-value #() #:accessor js-array-vector #:init-keyword #:vector))

(define (new-array . vals)
  (let ((o (make <js-array-object> #:class "Array"
                 #:prototype *array-prototype*)))
    (pput o 'length (length vals))
    (let ((vect (js-array-vector o)))
      (let lp ((i 0) (vals vals))
        (cond ((not (null? vals))
               (vector-set! vect i (car vals))
               (lp (1+ i) (cdr vals)))
              (else o))))))

(define *array-prototype* (make <js-object> #:class "Array"
                                #:value new-array
                                #:constructor new-array))

(hashq-set! *program-wrappers* new-array *array-prototype*)

(pput *array-prototype* 'prototype *array-prototype*)
(pput *array-prototype* 'constructor new-array)

(define-method (pget (o <js-array-object>) p)
  (cond ((and (integer? p) (exact? p) (>= p 0))
         (let ((v (js-array-vector o)))
           (if (< p (vector-length v))
               (vector-ref v p)
               (next-method))))
        ((or (and (symbol? p) (eq? p 'length))
             (and (string? p) (string=? p "length")))
         (vector-length (js-array-vector o)))
        (else (next-method))))

(define-method (pput (o <js-array-object>) p v)
  (cond ((and (integer? p) (exact? p) (>= 0 p))
         (let ((vect (js-array-vector o)))
           (if (< p (vector-length vect))
               (vector-set! vect p v)
               ;; Fixme: round up to powers of 2?
               (let ((new (make-vector (1+ p) 0)))
                 (vector-move-left! vect 0 (vector-length vect) new 0)
                 (set! (js-array-vector o) new)
                 (vector-set! new p v)))))
        ((or (and (symbol? p) (eq? p 'length))
             (and (string? p) (string=? p "length")))
         (let ((vect (js-array-vector o)))
           (let ((new (make-vector (->uint32 v) 0)))
             (vector-move-left! vect 0 (min (vector-length vect) (->uint32 v))
                                new 0)
             (set! (js-array-vector o) new))))
        (else (next-method))))

(define-js-method *array-prototype* (toString)
  (format #f "~A" (js-array-vector this)))

(define-js-method *array-prototype* (concat . rest)
  (let* ((len (apply + (->uint32 (pget this 'length))
                     (map (lambda (x) (->uint32 (pget x 'length)))
                          rest)))
         (rv (make-vector len 0)))
    (let lp ((objs (cons this rest)) (i 0))
      (cond ((null? objs) (make <js-array-object> #:class "Array"
                                #:prototype *array-prototype*
                                #:vector rv))
            ((is-a? (car objs) <js-array-object>)
             (let ((v (js-array-vector (car objs))))
               (vector-move-left! v 0 (vector-length v)
                                  rv i)
               (lp (cdr objs) (+ i (vector-length v)))))
            (else
             (error "generic array concats not yet implemented"))))))

(define-js-method *array-prototype* (join . separator)
  (let lp ((i (1- (->uint32 (pget this 'length)))) (l '()))
    (if (< i 0)
        (string-join l (if separator (->string (car separator)) ","))
        (lp (1+ i)
            (cons (->string (pget this i)) l)))))

(define-js-method *array-prototype* (pop)
  (let ((len (->uint32 (pget this 'length))))
    (if (zero? len)
        *undefined*
        (let ((ret (pget this (1- len))))
          (pput this 'length (1- len))
          ret))))

(define-js-method *array-prototype* (push . args)
  (let lp ((args args))
    (if (null? args)
        (->uint32 (pget this 'length))
        (begin (pput this (->uint32 (pget this 'length)) (car args))
               (lp (cdr args))))))


code:
;;; 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 base)
  #:use-module (oop goops)
  #:export (*undefined* *this*
            <js-object> *object-prototype*
            js-prototype js-props js-prop-attrs js-value js-constructor js-class
            pget prop-keys prop-attrs prop-has-attr? pput has-property? pdel

            object->string object->number object->value/string
            object->value/number object->value

            ->primitive ->boolean ->number ->integer ->int32 ->uint32
            ->uint16 ->string ->object

            call/this* call/this lambda/this define-js-method

            new-object new))

(define *undefined* ((@@ (oop goops) make-unbound)))
(define *this* (make-fluid))

(define-class <js-object> ()
  (prototype #:getter js-prototype #:init-keyword #:prototype
             #:init-thunk (lambda () *object-prototype*))
  (props #:getter js-props #:init-form (make-hash-table 7))
  (prop-attrs #:getter js-prop-attrs #:init-value #f)
  (value #:getter js-value #:init-value #f #:init-keyword #:value)
  (constructor #:getter js-constructor #:init-value #f #:init-keyword #:constructor)
  (class #:getter js-class #:init-value "Object" #:init-keyword #:class))

(define-method (prop-keys (o <js-object>))
  (hash-map->list (lambda (k v) k) (js-props o)))

(define-method (pget (o <js-object>) (p <string>))
  (pget o (string->symbol p)))

(define-method (pget (o <js-object>) p)
  (let ((h (hashq-get-handle (js-props o) p)))
    (if h
        (cdr h)
        (let ((proto (js-prototype o)))
          (if proto
              (pget proto p)
              *undefined*)))))

(define-method (prop-attrs (o <js-object>) p)
  (or (let ((attrs (js-prop-attrs o)))
        (and attrs (hashq-ref (js-prop-attrs o) p)))
      (let ((proto (js-prototype o)))
        (if proto
            (prop-attrs proto p)
            '()))))

(define-method (prop-has-attr? (o <js-object>) p attr)
  (memq attr (prop-attrs o p)))

(define-method (pput (o <js-object>) p v)
  (if (prop-has-attr? o p 'ReadOnly)
      (throw 'ReferenceError o p)
      (hashq-set! (js-props o) p v)))

(define-method (pput (o <js-object>) (p <string>) v)
  (pput o (string->symbol p) v))

(define-method (pdel (o <js-object>) p)
  (if (prop-has-attr? o p 'DontDelete)
      #f
      (begin
        (pput o p *undefined*)
        #t)))

(define-method (pdel (o <js-object>) (p <string>) v)
  (pdel o (string->symbol p)))

(define-method (has-property? (o <js-object>) p)
  (if (hashq-get-handle (js-props o) v)
      #t
      (let ((proto (js-prototype o)))
        (if proto
            (has-property? proto p)
            #f))))

(define (call/this* this f)
  (with-fluid* *this* this f))

(define-macro (call/this this f . args)
  `(with-fluid* *this* ,this (lambda () (,f . ,args))))
(define-macro (lambda/this formals . body)
  `(lambda ,formals (let ((this (fluid-ref *this*))) . ,body)))
(define-macro (define-js-method object name-and-args . body)
  `(pput ,object ',(car name-and-args) (lambda/this ,(cdr name-and-args) . ,body)))

(define *object-prototype* #f)
(set! *object-prototype* (make <js-object>))

(define-js-method *object-prototype* (toString)
  (format #f "[object ~A]" (js-class this)))
(define-js-method *object-prototype* (toLocaleString . args)
  ((pget *object-prototype* 'toString)))
(define-js-method *object-prototype* (valueOf)
  this)
(define-js-method *object-prototype* (hasOwnProperty p)
  (and (hashq-get-handle (js-props this) p) #t))
(define-js-method *object-prototype* (isPrototypeOf v)
  (eq? this (js-prototype v)))
(define-js-method *object-prototype* (propertyIsEnumerable p)
  (and (hashq-get-handle (js-props this) p)
       (not (prop-has-attr? this p 'DontEnum))))

(define (object->string o error?)
  (let ((toString (pget o 'toString)))
    (if (procedure? toString)
        (let ((x (call/this o toString)))
          (if (and error? (is-a? x <js-object>))
              (throw 'TypeError o 'default-value)
              x))
        (if error?
            (throw 'TypeError o 'default-value)
            o))))

(define (object->number o error?)
  (let ((valueOf (pget o 'valueOf)))
    (if (procedure? valueOf)
        (let ((x (call/this o valueOf)))
          (if (and error? (is-a? x <js-object>))
              (throw 'TypeError o 'default-value)
              x))
        (if error?
            (throw 'TypeError o 'default-value)
            o))))

(define (object->value/string o)
  (if (is-a? o <js-object>)
      (object->number o #t)
      o))

(define (object->value/number o)
  (if (is-a? o <js-object>)
      (object->string o #t)
      o))

(define (object->value o)
  ;; FIXME: if it's a date, we should try numbers first
  (object->value/string o))

(define (->primitive x)
  (if (is-a? x <js-object>)
      (object->value x)
      x))

(define (->boolean x)
  (not (or (not x) (null? x) (eq? x *undefined*) (zero? x) (nan? x)
           (and (string? x) (= (string-length x) 0)))))

(define (->number x)
  (cond ((number? x) x)
        ((boolean? x) (if x 1 0))
        ((null? x) 0)
        ((eq? x *undefined*) +nan.0)
        ((is-a? x <js-object>) (object->number x))
        ((string? x) (string->number x))
        (else (throw 'TypeError o '->number))))

(define (->integer x)
  (let ((n (->number x)))
    (cond ((nan? n) 0)
          ((zero? n) n)
          ((inf? n) n)
          (else (inexact->exact (round n))))))

(define (->int32 x)
  (let ((n (->number x)))
    (if (or (nan? n) (zero? n) (inf? n))
        0
        (let ((m (logand (1- (ash 1 32)) (inexact->exact (round n)))))
          (if (negative? n)
              (- m (ash 1 32))
              m)))))

(define (->uint32 x)
  (let ((n (->number x)))
    (if (or (nan? n) (zero? n) (inf? n))
        0
        (logand (1- (ash 1 32)) (inexact->exact (round n))))))

(define (->uint16 x)
  (let ((n (->number x)))
    (if (or (nan? n) (zero? n) (inf? n))
        0
        (logand (1- (ash 1 16)) (inexact->exact (round n))))))

(define (->string x)
  (cond ((eq? x *undefined*) "undefined")
        ((null? x) "null")
        ((boolean? x) (if x "true" "false"))
        ((string? x) x)
        ((number? x)
         (cond ((nan? x) "NaN")
               ((zero? x) "0")
               ((inf? x) "Infinity")
               (else (number->string x))))
        (else (->string (object->value/string x)))))

(define (->object x)
  (cond ((eq? x *undefined*) (throw 'TypeError x '->object))
        ((null? x) (throw 'TypeError x '->object))
        ((boolean? x) (make <js-object> #:prototype Boolean #:value x))
        ((number? x) (make <js-object> #:prototype String #:value x))
        ((string? x) (make <js-object> #:prototype Number #:value x))
        (else x)))

(define (new-object . pairs)
  (let ((o (make <js-object>)))
    (map (lambda (pair)
           (pput o (car pair) (cdr pair)))
         pairs)
    o))
(slot-set! *object-prototype* 'constructor new-object)

(define-method (new o . initargs)
  (let ((ctor (js-constructor o)))
    (if (not ctor)
        (throw 'TypeError 'new o)
        (let ((o (make <js-object>
                   #:prototype (or (js-prototype o) *object-prototype*))))
          (let ((new-o (call/this o apply ctor initargs)))
            (if (is-a? new-o <js-object>)
                new-o
                o))))))


code:
;;; 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 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 ->
  (syntax-rules ()
    ((_ (type arg ...))
     `(type ,arg ...))))

(define-syntax @implv
  (syntax-rules ()
    ((_ sym)
     (-> (@ '(language ecmascript impl) 'sym)))))

(define-syntax @impl
  (syntax-rules ()
    ((_ sym arg ...)
     (-> (apply (@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 pmatch/source
  (syntax-rules ()
    ((_ x clause ...)
     (let ((x x))
       (let ((res (pmatch x
                    clause ...)))
         (let ((loc (location x)))
           (if loc
               (set-source-properties! res (location x))))
         res)))))

(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)
       (-> (apply (-> (primitive '+))
                  (@impl ->number (comp a e))
                  (-> (const 0)))))
      ((- ,a)
       (-> (apply (-> (primitive '-)) (-> (const 0)) (comp a e))))
      ((~ ,a)
       (@impl bitwise-not (comp a e)))
      ((! ,a)
       (@impl logical-not (comp a e)))
      ((+ ,a ,b)
       (-> (apply (-> (primitive '+)) (comp a e) (comp b e))))
      ((- ,a ,b)
       (-> (apply (-> (primitive '-)) (comp a e) (comp b e))))
      ((/ ,a ,b)
       (-> (apply (-> (primitive '/)) (comp a e) (comp b e))))
      ((* ,a ,b)
       (-> (apply (-> (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)
       (-> (apply (-> (primitive '<)) (comp a e) (comp b e))))
      ((<= ,a ,b)
       (-> (apply (-> (primitive '<=)) (comp a e) (comp b e))))
      ((> ,a ,b)
       (-> (apply (-> (primitive '>)) (comp a e) (comp b e))))
      ((>= ,a ,b)
       (-> (apply (-> (primitive '>=)) (comp a e) (comp b e))))
      ((in ,a ,b)
       (@impl has-property? (comp a e) (comp b e)))
      ((== ,a ,b)
       (-> (apply (-> (primitive 'equal?)) (comp a e) (comp b e))))
      ((!= ,a ,b)
       (-> (apply (-> (primitive 'not))
                  (-> (apply (-> (primitive 'equal?))
                             (comp a e) (comp b e))))))
      ((=== ,a ,b)
       (-> (apply (-> (primitive 'eqv?)) (comp a e) (comp b e))))
      ((!== ,a ,b)
       (-> (apply (-> (primitive 'not))
                  (-> (apply (-> (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)
                           (-> (apply (-> (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))
                                (-> (apply (-> (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))
                                        (-> (apply (-> (primitive '+))
                                                   (-> (lexical tmpvar tmpvar))
                                                   (-> (const 1))))))))))))
      ((postdec (ref ,foo))
       (begin1 (comp `(ref ,foo) e)
               (lambda (var)
                 (-> (set (lookup foo e)
                          (-> (apply (-> (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))
                                (-> (apply (-> (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
                         (-> (apply (-> (primitive '+))
                                    v
                                    (-> (const 1))))))
               v))))
      ((preinc (pref ,obj ,prop))
       (let1 (comp obj e)
             (lambda (objvar)
               (begin1 (-> (apply (-> (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 (-> (apply (-> (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
                        (-> (apply (-> (primitive '-))
                                   v
                                   (-> (const 1))))))
               v))))
      ((predec (pref ,obj ,prop))
       (let1 (comp obj e)
             (lambda (objvar)
               (begin1 (-> (apply (-> (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 (-> (apply (-> (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)
              ,(comp-body e body formals syms))))))
      ((call/this ,obj ,prop . ,args)
       (@impl call/this*
              obj
              (-> (lambda '()
                    `(lambda-case
                      ((() #f #f #f () ())
                       (apply ,(@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)
       `(apply ,(comp proc e)
               ,@(map (lambda (x) (comp x e)) args)))
      ((return ,expr)
       (-> (apply (-> (primitive 'return))
                  (comp expr e))))
      ((array . ,args)
       `(apply ,(@implv new-array)
               ,@(map (lambda (x) (comp x e)) args)))
      ((object . ,args)
       (@impl new-object
              (map (lambda (x)
                     (pmatch x
                       ((,prop ,val)
                        (-> (apply (-> (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)
       (@impl new
              (map (lambda (x) (comp x e))
                   (cons what 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)
                                                 (-> (apply (-> (lexical '%continue %continue)))))))))))
                             (-> (lambda '()
                                   (-> (lambda-case
                                        `((() #f #f #f () ())
                                          ,(-> (if (@impl ->boolean (comp test e))
                                                   (-> (apply (-> (lexical '%loop %loop))))
                                                   (@implv *undefined*)))))))))
                       (-> (apply (-> (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)
                                                              (-> (apply (-> (lexical '%continue %continue))))))
                                                   (@implv *undefined*)))))))))
                       (-> (apply (-> (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)
                                                              (-> (apply (-> (lexical '%continue %continue))))))
                                                   (@implv *undefined*)))))))))
                       (-> (begin (comp (or init '(begin)) e)
                                  (-> (apply (-> (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)
                                                        (-> (apply (-> (lexical '%continue %continue))))))
                                                  (@implv *undefined*)))))))))
                       (-> (apply (-> (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))))))


code:
;;; 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)))


code:
;;; 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 impl)
  #:use-module (oop goops)
  #:use-module (language ecmascript base)
  #:use-module (language ecmascript function)
  #:use-module (language ecmascript array)
  #:re-export (*undefined* *this* call/this*
               pget pput pdel has-property?
               ->boolean ->number
               new-object new new-array)
  #:export (js-init get-this
            typeof
            bitwise-not logical-not
            shift
            mod
            band bxor bior
            make-enumerator))

(define-class <js-module-object> (<js-object>)
  (module #:init-form (current-module) #:init-keyword #:module
          #:getter js-module))
(define-method (pget (o <js-module-object>) (p <string>))
  (pget o (string->symbol p)))
(define-method (pget (o <js-module-object>) (p <symbol>))
  (let ((v (module-variable (js-module o) p)))
    (if v
        (variable-ref v)
        (next-method))))
(define-method (pput (o <js-module-object>) (p <string>) v)
  (pput o (string->symbol p) v))
(define-method (pput (o <js-module-object>) (p <symbol>) v)
  (module-define! (js-module o) p v))
(define-method (prop-attrs (o <js-module-object>) (p <symbol>))
  (cond ((module-local-variable (js-module o) p) '())
        ((module-variable (js-module o) p) '(DontDelete ReadOnly))
        (else (next-method))))
(define-method (prop-attrs (o <js-module-object>) (p <string>))
  (prop-attrs o (string->symbol p)))
(define-method (prop-keys (o <js-module-object>))
  (append (hash-map->list (lambda (k v) k) (module-obarray (js-module o)))
          (next-method)))

;; we could make a renamer, but having obj['foo-bar'] should be enough
(define (js-require modstr)
  (make <js-module-object> #:module
        (resolve-interface (map string->symbol (string-split modstr #\.)))))

(define-class <js-global-object> (<js-module-object>))
(define-method (js-module (o <js-global-object>))
  (current-module))

(define (init-js-bindings! mod)
  (module-define! mod 'NaN +nan.0)
  (module-define! mod 'Infinity +inf.0)
  (module-define! mod 'undefined *undefined*)
  (module-define! mod 'require js-require)
  ;; isNAN, isFinite, parseFloat, parseInt, eval
  ;; decodeURI, decodeURIComponent, encodeURI, encodeURIComponent
  ;; Object Function Array String Boolean Number Date RegExp Error EvalError
  ;; RangeError ReferenceError SyntaxError TypeError URIError
  (module-define! mod 'Object *object-prototype*)
  (module-define! mod 'Array *array-prototype*))

(define (js-init)
  (cond ((get-this))
        (else
         (fluid-set! *this* (make <js-global-object>))
         (init-js-bindings! (current-module)))))

(define (get-this)
  (fluid-ref *this*))

(define (typeof x)
  (cond ((eq? x *undefined*) "undefined")
        ((null? x) "object")
        ((boolean? x) "boolean")
        ((number? x) "number")
        ((string? x) "string")
        ((procedure? x) "function")
        ((is-a? x <js-object>) "object")
        (else "scm")))

(define bitwise-not lognot)
(define (logical-not x)
  (not (->boolean (->primitive x))))

(define shift ash)

(define band logand)
(define bxor logxor)
(define bior logior)

(define mod modulo)

(define-method (+ (a <string>) (b <string>))
  (string-append a b))

(define-method (+ (a <string>) b)
  (string-append a (->string b)))

(define-method (+ a (b <string>))
  (string-append (->string a) b))

(define-method (+ a b)
  (+ (->number a) (->number b)))

(define-method (- a b)
  (- (->number a) (->number b)))

(define-method (* a b)
  (* (->number a) (->number b)))

(define-method (/ a b)
  (/ (->number a) (->number b)))

(define-method (< a b)
  (< (->number a) (->number b)))
(define-method (< (a <string>) (b <string>))
  (string< a b))

(define-method (<= a b)
  (<= (->number a) (->number b)))
(define-method (<= (a <string>) (b <string>))
  (string<= a b))

(define-method (>= a b)
  (>= (->number a) (->number b)))
(define-method (>= (a <string>) (b <string>))
  (string>= a b))

(define-method (> a b)
  (> (->number a) (->number b)))
(define-method (> (a <string>) (b <string>))
  (string> a b))

(define (obj-and-prototypes o)
  (if o
      (cons o (obj-and-prototypes (js-prototype o)))
      '()))

(define (make-enumerator obj)
  (let ((props (make-hash-table 23)))
    (for-each (lambda (o)
                (for-each (lambda (k) (hashq-set! props k #t))
                          (prop-keys o)))
              (obj-and-prototypes obj))
    (apply new-array (filter (lambda (p)
                               (not (prop-has-attr? obj p 'DontEnum)))
                             (hash-map->list (lambda (k v) k) props)))))


code:
;;; ECMAScript for Guile

;; Copyright (C) 2009, 2010 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 parse)
  #:use-module (system base lalr)
  #:use-module (language ecmascript tokenize)
  #:export (read-ecmascript read-ecmascript/1 make-parser))

(define (syntax-error message . args)
  (apply throw 'SyntaxError message args))

(define (read-ecmascript port)
  (let ((parse (make-parser)))
    (parse (make-tokenizer port) syntax-error)))

(define (read-ecmascript/1 port)
  (let ((parse (make-parser)))
    (parse (make-tokenizer/1 port) syntax-error)))

(define *eof-object*
  (call-with-input-string "" read-char))

(define (make-parser)
  ;; Return a fresh ECMAScript parser.  Parsers produced by `lalr-scm' are now
  ;; stateful (e.g., they won't invoke the tokenizer any more once it has
  ;; returned `*eoi*'), hence the need to instantiate new parsers.

  (lalr-parser
   ;; terminal (i.e. input) token types
   (lbrace rbrace lparen rparen lbracket rbracket dot semicolon comma <
    > <= >= == != === !== + - * % ++ -- << >> >>> & bor ^ ! ~ && or ?
    colon = += -= *= %= <<= >>= >>>= &= bor= ^= / /=

    break else new var case finally return void catch for switch while
    continue function this with default if throw delete in try do
    instanceof typeof null true false

    Identifier StringLiteral NumericLiteral RegexpLiteral)

   (Program (SourceElements) : $1
            (*eoi*) : *eof-object*)

   ;;
   ;; Verily, here we define statements. Expressions are defined
   ;; afterwards.
   ;;

   (SourceElement (Statement) : $1
                  (FunctionDeclaration) : $1)

   (FunctionDeclaration (function Identifier lparen rparen lbrace FunctionBody rbrace) : `(var (,$2 (lambda () ,$6)))
                        (function Identifier lparen FormalParameterList rparen lbrace FunctionBody rbrace) : `(var (,$2 (lambda ,$4 ,$7))))
   (FunctionExpression (function lparen rparen lbrace FunctionBody rbrace) : `(lambda () ,$5)
                       (function Identifier lparen rparen lbrace FunctionBody rbrace) : `(lambda () ,$6)
                       (function lparen FormalParameterList rparen lbrace FunctionBody rbrace) : `(lambda ,$3 ,$6)
                       (function Identifier lparen FormalParameterList rparen lbrace FunctionBody rbrace) : `(lambda ,$4 ,$7))
   (FormalParameterList (Identifier) : `(,$1)
                        (FormalParameterList comma Identifier) : `(,@$1 ,$3))
   (SourceElements (SourceElement) : $1
                   (SourceElements SourceElement) : (if (and (pair? $1) (eq? (car $1) 'begin))
                                                         `(begin ,@(cdr $1) ,$2)
                                                         `(begin ,$1 ,$2)))
   (FunctionBody (SourceElements) : $1)

   (Statement (Block) : $1
              (VariableStatement) : $1
              (EmptyStatement) : $1
              (ExpressionStatement) : $1
              (IfStatement) : $1
              (IterationStatement) : $1
              (ContinueStatement) : $1
              (BreakStatement) : $1
              (ReturnStatement) : $1
              (WithStatement) : $1
              (LabelledStatement) : $1
              (SwitchStatement) : $1
              (ThrowStatement) : $1
              (TryStatement) : $1)

   (Block (lbrace StatementList rbrace) : `(block ,$2))
   (StatementList (Statement) : $1
                  (StatementList Statement) : (if (and (pair? $1) (eq? (car $1) 'begin))
                                                   `(begin ,@(cdr $1) ,$2)
                                                   `(begin ,$1 ,$2)))

   (VariableStatement (var VariableDeclarationList) : `(var ,@$2))
   (VariableDeclarationList (VariableDeclaration) : `(,$1)
                            (VariableDeclarationList comma VariableDeclaration) : `(,@$1 ,$2))
   (VariableDeclarationListNoIn (VariableDeclarationNoIn) : `(,$1)
                                (VariableDeclarationListNoIn comma VariableDeclarationNoIn) : `(,@$1 ,$2))
   (VariableDeclaration (Identifier) : `(,$1)
                        (Identifier Initialiser) : `(,$1 ,$2))
   (VariableDeclarationNoIn (Identifier) : `(,$1)
                            (Identifier Initialiser) : `(,$1 ,$2))
   (Initialiser (= AssignmentExpression) : $2)
   (InitialiserNoIn (= AssignmentExpressionNoIn) : $2)

   (EmptyStatement (semicolon) : '(begin))

   (ExpressionStatement (Expression semicolon) : $1)

   (IfStatement (if lparen Expression rparen Statement else Statement) : `(if ,$3 ,$5 ,$7)
                (if lparen Expression rparen Statement) : `(if ,$3 ,$5))

   (IterationStatement (do Statement while lparen Expression rparen semicolon) : `(do ,$2 ,$5)

                       (while lparen Expression rparen Statement) : `(while ,$3 ,$5)

                       (for lparen semicolon semicolon rparen Statement) : `(for #f #f #f ,$6)
                       (for lparen semicolon semicolon Expression rparen Statement) : `(for #f #f ,$5 ,$7)
                       (for lparen semicolon Expression semicolon rparen Statement) : `(for #f ,$4 #f ,$7)
                       (for lparen semicolon Expression semicolon Expression rparen Statement) : `(for #f ,$4 ,$6 ,$8)

                       (for lparen ExpressionNoIn semicolon semicolon rparen Statement) : `(for ,$3 #f #f ,$7)
                       (for lparen ExpressionNoIn semicolon semicolon Expression rparen Statement) : `(for ,$3 #f ,$6 ,$8)
                       (for lparen ExpressionNoIn semicolon Expression semicolon rparen Statement) : `(for ,$3 ,$5 #f ,$8)
                       (for lparen ExpressionNoIn semicolon Expression semicolon Expression rparen Statement) : `(for ,$3 ,$5 ,$7 ,$9)

                       (for lparen var VariableDeclarationListNoIn semicolon semicolon rparen Statement) : `(for (var ,@$4) #f #f ,$8)
                       (for lparen var VariableDeclarationListNoIn semicolon semicolon Expression rparen Statement) : `(for (var ,@$4) #f ,$7 ,$9)
                       (for lparen var VariableDeclarationListNoIn semicolon Expression semicolon rparen Statement) : `(for (var ,@$4) ,$6 #f ,$9)
                       (for lparen var VariableDeclarationListNoIn semicolon Expression semicolon Expression rparen Statement) : `(for (var ,@$4) ,$6 ,$8 ,$10)

                       (for lparen LeftHandSideExpression in Expression rparen Statement) : `(for-in ,$3 ,$5 ,$7)
                       (for lparen var VariableDeclarationNoIn in Expression rparen Statement) : `(begin (var ,$4) (for-in (ref ,@$4) ,$6 ,$8)))

   (ContinueStatement (continue Identifier semicolon) : `(continue ,$2)
                      (continue semicolon) : `(continue))

   (BreakStatement (break Identifier semicolon) : `(break ,$2)
                   (break semicolon) : `(break))

   (ReturnStatement (return Expression semicolon) : `(return ,$2)
                    (return semicolon) : `(return))

   (WithStatement (with lparen Expression rparen Statement) : `(with ,$3 ,$5))

   (SwitchStatement (switch lparen Expression rparen CaseBlock) : `(switch ,$3 ,@$5))
   (CaseBlock (lbrace rbrace) : '()
              (lbrace CaseClauses rbrace) : $2
              (lbrace CaseClauses DefaultClause rbrace) : `(,@$2 ,@$3)
              (lbrace DefaultClause rbrace) : `(,$2)
              (lbrace DefaultClause CaseClauses rbrace) : `(,@$2 ,@$3))
   (CaseClauses (CaseClause) : `(,$1)
                (CaseClauses CaseClause) : `(,@$1 ,$2))
   (CaseClause (case Expression colon) : `(case ,$2)
               (case Expression colon StatementList) : `(case ,$2 ,$4))
   (DefaultClause (default colon) : `(default)
                  (default colon StatementList) : `(default ,$3))

   (LabelledStatement (Identifier colon Statement) : `(label ,$1 ,$3))

   (ThrowStatement (throw Expression semicolon) : `(throw ,$2))

   (TryStatement (try Block Catch) : `(try ,$2 ,$3 #f)
                 (try Block Finally) : `(try ,$2 #f ,$3)
                 (try Block Catch Finally) : `(try ,$2 ,$3 ,$4))
   (Catch (catch lparen Identifier rparen Block) : `(catch ,$3 ,$5))
   (Finally (finally Block) : `(finally ,$2))

   ;;
   ;; As promised, expressions. We build up to Expression bottom-up, so
   ;; as to get operator precedence right.
   ;;

   (PrimaryExpression (this) : 'this
                      (null) : 'null
                      (true) : 'true
                      (false) : 'false
                      (Identifier) : `(ref ,$1)
                      (StringLiteral) : `(string ,$1)
                      (RegexpLiteral) : `(regexp ,$1)
                      (NumericLiteral) : `(number ,$1)
                      (ArrayLiteral) : $1
                      (ObjectLiteral) : $1
                      (lparen Expression rparen) : $2)

   (ArrayLiteral (lbracket rbracket) : '(array)
                 (lbracket Elision rbracket) : '(array ,@$2)
                 (lbracket ElementList rbracket) : `(array ,@$2)
                 (lbracket ElementList comma rbracket) : `(array ,@$2)
                 (lbracket ElementList comma Elision rbracket) : `(array ,@$2))
   (ElementList (AssignmentExpression) : `(,$1)
                (Elision AssignmentExpression) : `(,@$1 ,$2)
                (ElementList comma AssignmentExpression) : `(,@$1 ,$3)
                (ElementList comma Elision AssignmentExpression) : `(,@$1 ,@$3 ,$4))
   (Elision (comma) : '((number 0))
            (Elision comma) : `(,@$1 (number 0)))

   (ObjectLiteral (lbrace rbrace) : `(object)
                  (lbrace PropertyNameAndValueList rbrace) : `(object ,@$2))
   (PropertyNameAndValueList (PropertyName colon AssignmentExpression) : `((,$1 ,$3))
                             (PropertyNameAndValueList comma PropertyName colon AssignmentExpression) : `(,@$1 (,$3 ,$5)))
   (PropertyName (Identifier) : $1
                 (StringLiteral) : (string->symbol $1)
                 (NumericLiteral) : $1)

   (MemberExpression (PrimaryExpression) : $1
                     (FunctionExpression) : $1
                     (MemberExpression lbracket Expression rbracket) : `(aref ,$1 ,$3)
                     (MemberExpression dot Identifier) : `(pref ,$1 ,$3)
                     (new MemberExpression Arguments) : `(new ,$2 ,$3))

   (NewExpression (MemberExpression) : $1
                  (new NewExpression) : `(new ,$2 ()))

   (CallExpression (MemberExpression Arguments) : `(call ,$1 ,$2)
                   (CallExpression Arguments) : `(call ,$1 ,$2)
                   (CallExpression lbracket Expression rbracket) : `(aref ,$1 ,$3)
                   (CallExpression dot Identifier) : `(pref ,$1 ,$3))
   (Arguments (lparen rparen) : '()
              (lparen ArgumentList rparen) : $2)
   (ArgumentList (AssignmentExpression) : `(,$1)
                 (ArgumentList comma AssignmentExpression) : `(,@$1 ,$3))

   (LeftHandSideExpression (NewExpression) : $1
                           (CallExpression) : $1)

   (PostfixExpression (LeftHandSideExpression) : $1
                      (LeftHandSideExpression ++) : `(postinc ,$1)
                      (LeftHandSideExpression --) : `(postdec ,$1))

   (UnaryExpression (PostfixExpression) : $1
                    (delete UnaryExpression) : `(delete ,$2)
                    (void UnaryExpression) : `(void ,$2)
                    (typeof UnaryExpression) : `(typeof ,$2)
                    (++ UnaryExpression) : `(preinc ,$2)
                    (-- UnaryExpression) : `(predec ,$2)
                    (+ UnaryExpression) : `(+ ,$2)
                    (- UnaryExpression) : `(- ,$2)
                    (~ UnaryExpression) : `(~ ,$2)
                    (! UnaryExpression) : `(! ,$2))

   (MultiplicativeExpression (UnaryExpression) : $1
                             (MultiplicativeExpression * UnaryExpression) : `(* ,$1 ,$3)
                             (MultiplicativeExpression / UnaryExpression) : `(/ ,$1 ,$3)
                             (MultiplicativeExpression % UnaryExpression) : `(% ,$1 ,$3))

   (AdditiveExpression (MultiplicativeExpression) : $1
                       (AdditiveExpression + MultiplicativeExpression) : `(+ ,$1 ,$3)
                       (AdditiveExpression - MultiplicativeExpression) : `(- ,$1 ,$3))

   (ShiftExpression (AdditiveExpression) : $1
                    (ShiftExpression << MultiplicativeExpression) : `(<< ,$1 ,$3)
                    (ShiftExpression >> MultiplicativeExpression) : `(>> ,$1 ,$3)
                    (ShiftExpression >>> MultiplicativeExpression) : `(>>> ,$1 ,$3))

   (RelationalExpression (ShiftExpression) : $1
                         (RelationalExpression < ShiftExpression) : `(< ,$1 ,$3)
                         (RelationalExpression > ShiftExpression) : `(> ,$1 ,$3)
                         (RelationalExpression <= ShiftExpression) : `(<= ,$1 ,$3)
                         (RelationalExpression >= ShiftExpression) : `(>= ,$1 ,$3)
                         (RelationalExpression instanceof ShiftExpression) : `(instanceof ,$1 ,$3)
                         (RelationalExpression in ShiftExpression) : `(in ,$1 ,$3))

   (RelationalExpressionNoIn (ShiftExpression) : $1
                             (RelationalExpressionNoIn < ShiftExpression) : `(< ,$1 ,$3)
                             (RelationalExpressionNoIn > ShiftExpression) : `(> ,$1 ,$3)
                             (RelationalExpressionNoIn <= ShiftExpression) : `(<= ,$1 ,$3)
                             (RelationalExpressionNoIn >= ShiftExpression) : `(>= ,$1 ,$3)
                             (RelationalExpressionNoIn instanceof ShiftExpression) : `(instanceof ,$1 ,$3))

   (EqualityExpression (RelationalExpression) : $1
                       (EqualityExpression == RelationalExpression) : `(== ,$1 ,$3)
                       (EqualityExpression != RelationalExpression) : `(!= ,$1 ,$3)
                       (EqualityExpression === RelationalExpression) : `(=== ,$1 ,$3)
                       (EqualityExpression !== RelationalExpression) : `(!== ,$1 ,$3))

   (EqualityExpressionNoIn (RelationalExpressionNoIn) : $1
                           (EqualityExpressionNoIn == RelationalExpressionNoIn) : `(== ,$1 ,$3)
                           (EqualityExpressionNoIn != RelationalExpressionNoIn) : `(!= ,$1 ,$3)
                           (EqualityExpressionNoIn === RelationalExpressionNoIn) : `(=== ,$1 ,$3)
                           (EqualityExpressionNoIn !== RelationalExpressionNoIn) : `(!== ,$1 ,$3))

   (BitwiseANDExpression (EqualityExpression) : $1
                         (BitwiseANDExpression & EqualityExpression) : `(& ,$1 ,$3))
   (BitwiseANDExpressionNoIn (EqualityExpressionNoIn) : $1
                             (BitwiseANDExpressionNoIn & EqualityExpressionNoIn) : `(& ,$1 ,$3))

   (BitwiseXORExpression (BitwiseANDExpression) : $1
                         (BitwiseXORExpression ^ BitwiseANDExpression) : `(^ ,$1 ,$3))
   (BitwiseXORExpressionNoIn (BitwiseANDExpressionNoIn) : $1
                             (BitwiseXORExpressionNoIn ^ BitwiseANDExpressionNoIn) : `(^ ,$1 ,$3))

   (BitwiseORExpression (BitwiseXORExpression) : $1
                        (BitwiseORExpression bor BitwiseXORExpression) : `(bor ,$1 ,$3))
   (BitwiseORExpressionNoIn (BitwiseXORExpressionNoIn) : $1
                            (BitwiseORExpressionNoIn bor BitwiseXORExpressionNoIn) : `(bor ,$1 ,$3))

   (LogicalANDExpression (BitwiseORExpression) : $1
                         (LogicalANDExpression && BitwiseORExpression) : `(and ,$1 ,$3))
   (LogicalANDExpressionNoIn (BitwiseORExpressionNoIn) : $1
                             (LogicalANDExpressionNoIn && BitwiseORExpressionNoIn) : `(and ,$1 ,$3))

   (LogicalORExpression (LogicalANDExpression) : $1
                        (LogicalORExpression or LogicalANDExpression) : `(or ,$1 ,$3))
   (LogicalORExpressionNoIn (LogicalANDExpressionNoIn) : $1
                            (LogicalORExpressionNoIn or LogicalANDExpressionNoIn) : `(or ,$1 ,$3))

   (ConditionalExpression (LogicalORExpression) : $1
                          (LogicalORExpression ? AssignmentExpression colon AssignmentExpression) : `(if ,$1 ,$3 ,$5))
   (ConditionalExpressionNoIn (LogicalORExpressionNoIn) : $1
                              (LogicalORExpressionNoIn ? AssignmentExpressionNoIn colon AssignmentExpressionNoIn) : `(if ,$1 ,$3 ,$5))

   (AssignmentExpression (ConditionalExpression) : $1
                         (LeftHandSideExpression AssignmentOperator AssignmentExpression) : `(,$2 ,$1 ,$3))
   (AssignmentExpressionNoIn (ConditionalExpressionNoIn) : $1
                             (LeftHandSideExpression AssignmentOperator AssignmentExpressionNoIn) : `(,$2 ,$1 ,$3))
   (AssignmentOperator (=) : '=
                       (*=) : '*=
                       (/=) : '/=
                       (%=) : '%=
                       (+=) : '+=
                       (-=) : '-=
                       (<<=) : '<<=
                       (>>=) : '>>=
                       (>>>=) : '>>>=
                       (&=) : '&=
                       (^=) : '^=
                       (bor=) : 'bor=)

   (Expression (AssignmentExpression) : $1
               (Expression comma AssignmentExpression) : `(begin ,$1 ,$3))
   (ExpressionNoIn (AssignmentExpressionNoIn) : $1
                   (ExpressionNoIn comma AssignmentExpressionNoIn) : `(begin ,$1 ,$3))))


code:
;;; ECMAScript specification for Guile

;; Copyright (C) 2009, 2010 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 spec)
  #:use-module (system base language)
  #:use-module (language ecmascript parse)
  #:use-module (language ecmascript compile-tree-il)
  #:export (ecmascript))

;;;
;;; Language definition
;;;

(define-language ecmascript
  #:title	"ECMAScript"
  #:reader	(lambda (port env) (read-ecmascript/1 port))
  #:compilers   `((tree-il . ,compile-tree-il))
  ;; a pretty-printer would be interesting.
  #:printer	write
  )