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 tokenize)
  #:use-module (ice-9 rdelim)
  #:use-module ((srfi srfi-1) #:select (unfold-right))
  #:use-module (system base lalr)
  #:export (next-token make-tokenizer make-tokenizer/1 tokenize tokenize/1))

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

;; taken from SSAX, sorta
(define (read-until delims port)
  (if (eof-object? (peek-char port))
      (syntax-error "EOF while reading a token")
      (let ((token (read-delimited delims port 'peek)))
        (if (eof-object? (peek-char port))
            (syntax-error "EOF while reading a token")
            token))))

(define (char-hex? c)
  (and (not (eof-object? c))
       (or (char-numeric? c)
           (memv c '(#\a #\b #\c #\d #\e #\f))
           (memv c '(#\A #\B #\C #\D #\E #\F)))))

(define (digit->number c)
  (- (char->integer c) (char->integer #\0)))

(define (hex->number c)
  (if (char-numeric? c)
      (digit->number c)
      (+ 10 (- (char->integer (char-downcase c)) (char->integer #\a)))))

(define (read-slash port div?)
  (let ((c1 (begin
              (read-char port)
              (peek-char port))))
    (cond
     ((eof-object? c1)
      ;; hmm. error if we're not looking for a div? ?
      '(/ . #f))
     ((char=? c1 #\/)
      (read-line port)
      (next-token port div?))
     ((char=? c1 #\*)
      (read-char port)
      (let lp ((c (read-char port)))
        (cond
         ((eof-object? c) (syntax-error "EOF while in multi-line comment"))
         ((char=? c #\*)
          (if (eqv? (peek-char port) #\/)
              (begin
                (read-char port)
                (next-token port div?))
              (lp (read-char port))))
         (else
          (lp (read-char port))))))
     (div?
      (case c1
        ((#\=) (read-char port) (make-lexical-token '/= #f #f))
        (else (make-lexical-token '/ #f #f))))
     (else
      (read-regexp port)))))

(define (read-regexp port)
  ;; first slash already read
  (let ((terms (string #\/ #\\ #\nl #\cr)))
    (let lp ((str (read-until terms port)) (head ""))
      (let ((terminator (peek-char port)))
        (cond
         ((char=? terminator #\/)
          (read-char port)
          ;; flags
          (let lp ((c (peek-char port)) (flags '()))
            (if (or (eof-object? c)
                    (not (or (char-alphabetic? c)
                             (char-numeric? c)
                             (char=? c #\$)
                             (char=? c #\_))))
                (make-lexical-token 'RegexpLiteral #f
                                    (cons (string-append head str)
                                          (reverse flags)))
                (begin (read-char port)
                       (lp (peek-char port) (cons c flags))))))
         ((char=? terminator #\\)
          (read-char port)
          (let ((echar (read-char port)))
            (lp (read-until terms port)
                (string-append head str (string #\\ echar)))))
         (else
          (syntax-error "regexp literals may not contain newlines" str)))))))

(define (read-string port)
  (let ((c (read-char port)))
    (let ((terms (string c #\\ #\nl #\cr)))
      (define (read-escape port)
        (let ((c (read-char port)))
          (case c
            ((#\' #\" #\\) c)
            ((#\b) #\bs)
            ((#\f) #\np)
            ((#\n) #\nl)
            ((#\r) #\cr)
            ((#\t) #\tab)
            ((#\v) #\vt)
            ((#\0)
             (let ((next (peek-char port)))
               (cond ((eof-object? next) #\nul)
                     ((char-numeric? next)
                      (syntax-error "octal escape sequences are not supported"))
                     (else #\nul))))
            ((#\x)
             (let* ((a (read-char port))
                    (b (read-char port)))
               (cond
                ((and (char-hex? a) (char-hex? b))
                 (integer->char (+ (* 16 (hex->number a)) (hex->number b))))
                (else
                 (syntax-error "bad hex character escape" a b)))))
            ((#\u)
             (syntax-error "unicode not supported"))
            (else
             c))))
      (let lp ((str (read-until terms port)))
        (let ((terminator (peek-char port)))
          (cond
           ((char=? terminator c)
            (read-char port)
            str)
           ((char=? terminator #\\)
            (read-char port)
            (let ((echar (read-escape port)))
              (lp (string-append str (string echar)
                                 (read-until terms port)))))
           (else
            (syntax-error "string literals may not contain newlines" str))))))))

(define *keywords*
  '(("break" . break)
    ("else" . else)
    ("new" . new)
    ("var" . var)
    ("case" . case)
    ("finally" . finally)
    ("return" . return)
    ("void" . void)
    ("catch" . catch)
    ("for" . for)
    ("switch" . switch)
    ("while" . while)
    ("continue" . continue)
    ("function" . function)
    ("this" . this)
    ("with" . with)
    ("default" . default)
    ("if" . if)
    ("throw" . throw)
    ("delete" . delete)
    ("in" . in)
    ("try" . try)
    ("do" . do)
    ("instanceof" . instanceof)
    ("typeof" . typeof)

    ;; these aren't exactly keywords, but hey
    ("null" . null)
    ("true" . true)
    ("false" . false)))

(define *future-reserved-words*
  '(("abstract" . abstract)
    ("enum" . enum)
    ("int" . int)
    ("short" . short)
    ("boolean" . boolean)
    ("export" . export)
    ("interface" . interface)
    ("static" . static)
    ("byte" . byte)
    ("extends" . extends)
    ("long" . long)
    ("super" . super)
    ("char" . char)
    ("final" . final)
    ("native" . native)
    ("synchronized" . synchronized)
    ("class" . class)
    ("float" . float)
    ("package" . package)
    ("throws" . throws)
    ("const" . const)
    ("goto" . goto)
    ("private" . private)
    ("transient" . transient)
    ("debugger" . debugger)
    ("implements" . implements)
    ("protected" . protected)
    ("volatile" . volatile)
    ("double" . double)
    ("import" . import)
    ("public" . public)))

(define (read-identifier port loc)
  (let lp ((c (peek-char port)) (chars '()))
    (if (or (eof-object? c)
            (not (or (char-alphabetic? c)
                     (char-numeric? c)
                     (char=? c #\$)
                     (char=? c #\_))))
        (let ((word (list->string (reverse chars))))
          (cond ((assoc-ref *keywords* word)
                 => (lambda (x) (make-lexical-token x loc #f)))
                ((assoc-ref *future-reserved-words* word)
                 (syntax-error "word is reserved for the future, dude." word))
                (else (make-lexical-token 'Identifier loc
                                          (string->symbol word)))))
        (begin (read-char port)
               (lp (peek-char port) (cons c chars))))))

(define (read-numeric port)
  (let* ((c0 (if (char=? (peek-char port) #\.)
                 #\0
                 (read-char port)))
         (c1 (peek-char port)))
    (cond
     ((eof-object? c1) (digit->number c0))
     ((and (char=? c0 #\0) (char=? c1 #\x))
      (read-char port)
      (let ((c (peek-char port)))
        (if (not (char-hex? c))
            (syntax-error "bad digit reading hexadecimal number" c))
        (let lp ((c c) (acc 0))
          (cond ((char-hex? c)
                 (read-char port)
                 (lp (peek-char port)
                     (+ (* 16 acc) (hex->number c))))
                (else
                 acc)))))
     ((and (char=? c0 #\0) (char-numeric? c1))
      (let lp ((c c1) (acc 0))
        (cond ((eof-object? c) acc)
              ((char-numeric? c)
               (if (or (char=? c #\8) (char=? c #\9))
                   (syntax-error "invalid digit in octal sequence" c))
               (read-char port)
               (lp (peek-char port)
                   (+ (* 8 acc) (digit->number c))))
              (else
               acc))))
     (else
      (let lp ((c1 c1) (acc (digit->number c0)))
        (cond
         ((eof-object? c1) acc)
         ((char-numeric? c1)
          (read-char port)
          (lp (peek-char port)
              (+ (* 10 acc) (digit->number c1))))
         ((or (char=? c1 #\e) (char=? c1 #\E))
          (read-char port)
          (let ((add (let ((c (peek-char port)))
                       (cond ((eof-object? c) (syntax-error "error reading exponent: EOF"))
                             ((char=? c #\+) (read-char port) +)
                             ((char=? c #\-) (read-char port) -)
                             ((char-numeric? c) +)
                             (else (syntax-error "error reading exponent: non-digit"
                                                 c))))))
            (let lp ((c (peek-char port)) (e 0))
              (cond ((and (not (eof-object? c)) (char-numeric? c))
                     (read-char port)
                     (lp (peek-char port) (add (* 10 e) (digit->number c))))
                    (else
                     (* (if (negative? e) (* acc 1.0) acc) (expt 10 e)))))))
         ((char=? c1 #\.)
          (read-char port)
          (let lp2 ((c (peek-char port)) (dec 0.0) (n -1))
            (cond ((and (not (eof-object? c)) (char-numeric? c))
                   (read-char port)
                   (lp2 (peek-char port)
                        (+ dec (* (digit->number c) (expt 10 n)))
                        (1- n)))
                  (else
                   ;; loop back to catch an exponential part
                   (lp c (+ acc dec))))))
         (else
          acc)))))))

(define *punctuation*
  '(("{" . lbrace)
    ("}" . rbrace)
    ("(" . lparen)
    (")" . rparen)
    ("[" . lbracket)
    ("]" . rbracket)
    ("." . dot)
    (";" . semicolon)
    ("," . comma)
    ("<" . <)
    (">" . >)
    ("<=" . <=)
    (">=" . >=)
    ("==" . ==)
    ("!=" . !=)
    ("===" . ===)
    ("!==" . !==)
    ("+" . +)
    ("-" . -)
    ("*" . *)
    ("%" . %)
    ("++" . ++)
    ("--" . --)
    ("<<" . <<)
    (">>" . >>)
    (">>>" . >>>)
    ("&" . &)
    ("|" . bor)
    ("^" . ^)
    ("!" . !)
    ("~" . ~)
    ("&&" . &&)
    ("||" . or)
    ("?" . ?)
    (":" . colon)
    ("=" . =)
    ("+=" . +=)
    ("-=" . -=)
    ("*=" . *=)
    ("%=" . %=)
    ("<<=" . <<=)
    (">>=" . >>=)
    (">>>=" . >>>=)
    ("&=" . &=)
    ("|=" . bor=)
    ("^=" . ^=)))

(define *div-punctuation*
  '(("/" . /)
    ("/=" . /=)))

;; node ::= (char (symbol | #f) node*)
(define read-punctuation
  (let ((punc-tree (let lp ((nodes '()) (puncs *punctuation*))
                     (cond ((null? puncs)
                            nodes)
                           ((assv-ref nodes (string-ref (caar puncs) 0))
                            => (lambda (node-tail)
                                 (if (= (string-length (caar puncs)) 1)
                                     (set-car! node-tail (cdar puncs))
                                     (set-cdr! node-tail
                                               (lp (cdr node-tail)
                                                   `((,(substring (caar puncs) 1)
                                                      . ,(cdar puncs))))))
                                 (lp nodes (cdr puncs))))
                           (else
                            (lp (cons (list (string-ref (caar puncs) 0) #f) nodes)
                                puncs))))))
    (lambda (port loc)
      (let lp ((c (peek-char port)) (tree punc-tree) (candidate #f))
        (cond
         ((assv-ref tree c)
          => (lambda (node-tail)
               (read-char port)
               (lp (peek-char port) (cdr node-tail) (car node-tail))))
         (candidate
          (make-lexical-token candidate loc #f))
         (else
          (syntax-error "bad syntax: character not allowed" c)))))))

(define (next-token port div?)
  (let ((c   (peek-char port))
        (loc (make-source-location (port-filename port)
                                   (port-line port)
                                   (port-column port)
                                   (false-if-exception (seek port 0 SEEK_CUR))
                                   #f)))
    (let ((tok
           (case c
             ((#\ht #\vt #\np #\space)
                                        ; whitespace
              (read-char port)
              (next-token port div?))
             ((#\newline #\cr)
                                        ; line break
              (read-char port)
              (next-token port div?))
             ((#\/)
              ;; division, single comment, double comment, or regexp
              (read-slash port div?))
             ((#\" #\')
                                        ; string literal
              (make-lexical-token 'StringLiteral loc (read-string port)))
             (else
              (cond
               ((eof-object? c)
                '*eoi*)
               ((or (char-alphabetic? c)
                    (char=? c #\$)
                    (char=? c #\_))
                ;; reserved word or identifier
                (read-identifier port loc))
               ((char-numeric? c)
                ;; numeric -- also accept . FIXME, requires lookahead
                (make-lexical-token 'NumericLiteral loc (read-numeric port)))
               (else
                ;; punctuation
                (read-punctuation port loc)))))))

      tok)))

(define (make-tokenizer port)
  (let ((div? #f))
    (lambda ()
      (let ((tok (next-token port div?)))
        (set! div? (and (pair? tok) (eq? (car tok) 'identifier)))
        tok))))

(define (make-tokenizer/1 port)
  (let ((div? #f)
        (eoi? #f)
        (stack '()))
    (lambda ()
      (if eoi?
          '*eoi*
          (let ((tok (next-token port div?)))
            (case (if (lexical-token? tok) (lexical-token-category tok) tok)
              ((lparen)
               (set! stack (make-lexical-token 'lparen #f stack)))
              ((rparen)
               (if (and (pair? stack) (eq? (car stack) 'lparen))
                   (set! stack (cdr stack))
                   (syntax-error "unexpected right parenthesis")))
              ((lbracket)
               (set! stack (make-lexical-token 'lbracket #f stack)))
              ((rbracket)
               (if (and (pair? stack) (eq? (car stack) 'lbracket))
                   (set! stack (cdr stack))
                   (syntax-error "unexpected right bracket" stack)))
              ((lbrace)
               (set! stack (make-lexical-token 'lbrace #f stack)))
              ((rbrace)
               (if (and (pair? stack) (eq? (car stack) 'lbrace))
                   (set! stack (cdr stack))
                   (syntax-error "unexpected right brace" stack)))
              ((semicolon)
               (set! eoi? (null? stack))))
            (set! div? (and (lexical-token? tok)
                            (let ((cat (lexical-token-category tok)))
                              (or (eq? cat 'Identifier)
                                  (eq? cat 'NumericLiteral)
                                  (eq? cat 'StringLiteral)))))
            tok)))))

(define (tokenize port)
  (let ((next (make-tokenizer port)))
    (let lp ((out '()))
      (let ((tok (next)))
        (if (eq? tok '*eoi*)
            (reverse! out)
            (lp (cons tok out)))))))

(define (tokenize/1 port)
  (let ((next (make-tokenizer/1 port)))
    (let lp ((out '()))
      (let ((tok (next)))
        (if (eq? tok '*eoi*)
            (reverse! out)
            (lp (cons tok out)))))))


code:
;; Per-directory local variables for GNU Emacs 23 and later.

((nil . ((fill-column . 72))))

license: mit


code:
Guile's Emacs Lisp compiler
===========================

This is more or less a lot of work in progress.  Here are some notes as well
as status information.

Already implemented:
  * progn, prog1, prog2
  * if, cond, when, unless
  * not, and, or
  * referencing and setting (setq) variables
  * set, symbol-value, makunbound, boundp functions
  * fset, symbol-function, fmakunbound, fboundp
  * funcall, apply (also with raw lists as arguments and the like!)
  * eval
  * while, dotimes, dolist
  * catch, throw, unwind-protect
  * let, let*
  * lambda expressions, function calls using list notation
  * some built-ins (mainly numbers/arithmetic)
  * defconst, defvar, defun
  * macros
  * quotation and backquotation with unquote/unquote-splicing
  * specific elisp reader

Especially still missing:
  * more general built-ins
  * advice?
  * defsubst and inlining
  * recursive macros
  * anonymous macros

Other ideas and things to think about:
  * #nil vs. #f/'() handling in Guile

Compiler options implemented:
  * #:disable-void-check ['all / '(sym1 sym2 sym3)] to disable the check
    for void value on access either completely or for some symbols
  * #:always-lexical (usable same as disable-void-check) to always bind
    certain or all symbols lexically (including lambda arguments)

Extensions over original elisp:
  * guile-ref, guile-primitive
  * flet and flet*
  * lexical-let and lexical-let*
  * without-void-checks, with-always-lexical

Details to the implemented extensions
=====================================

guile-ref and guile-primitive:
------------------------------

(guile-ref module sym) is a new special construct to access symbols from the
Guile-world.  Actually, (guile-ref module sym) is the same as (@ module sym)
would be in Scheme.  Both module and sym must be statically given and are not
evaluated.

(guile-primitive sym) does the same to access a Guile primitive directly, which
is slightly faster where applicable.

flet and flet*:
---------------

These constructs behave exactly like let and let*, except that they bind the
function slots rather than the value slots, and so make dynamic scoping
available for functions, too.

The distinction between flet and flet* is probably less useful than the one
between let and let*, but it was easy to implement both flet and flet*
based on the existing let and let* code, so not having both of them seemed
a little inconsistent.

lexical-let and lexical-let*:
-----------------------------

lexical-let and lexical-let* are constructs provided by the elisp package
'cl originally, but in Guile they are natively implemented because using
lexical instead of dynamic binding gives better performance in this case.

They work just like let and let*, but bind their target symbols lexically.
Some oberservations with the Emacs 'cl implementation that we mimic in Guile
for compatibility:

  * Ordinary let's within the lexical scope of a lexical-let still establish new
    *lexical* bindings for symbols already lexically bound.  So once lexical,
    always lexical (on a per-symbol basis).

  * However, lambda constructs within the lexical scope of a lexical-let where
    one of their arguments is already lexically bound still bind it dynamically
    for their scope.

  * On the other hand, symbols lexically bound that are not rebound via the
    argument-list build lexical closures just well.

  * If symbols are accessed where they are not known at compile-time (like
    symbol-value or set primitives), this always refers to the dynamic binding
    and never the lexical one.  That's very nice to the implementor...

without-void-checks:
--------------------

Disable void checks in addition to the compiler option for all or some symbols
in the lexical scope of this construct:

(without-void-checks all body...) or
(without-void-checks (sym1 sym2 ...) body...

with-always-lexical:
--------------------

As without-void-checks but adds to list of symbols that should always be bound
lexically.  This lexical binding includes lambda arguments (if the symbols
match up with the list), which can not be bound lexically otherwise.

path: module/language/elisp/README


code:
;;; Guile Emacs Lisp

;;; 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 elisp bindings)
  #:export (make-bindings
            mark-global-needed!
            map-globals-needed
            with-lexical-bindings
            with-dynamic-bindings
            get-lexical-binding))

;;; This module defines routines to handle analysis of symbol bindings
;;; used during elisp compilation. This data allows to collect the
;;; symbols, for which globals need to be created, or mark certain
;;; symbols as lexically bound.
;;;
;;; Needed globals are stored in an association-list that stores a list
;;; of symbols for each module they are needed in.
;;;
;;; The lexical bindings of symbols are stored in a hash-table that
;;; associates symbols to fluids; those fluids are used in the
;;; with-lexical-binding and with-dynamic-binding routines to associate
;;; symbols to different bindings over a dynamic extent.

;;; Record type used to hold the data necessary.

(define bindings-type
  (make-record-type 'bindings '(needed-globals lexical-bindings)))

;;; Construct an 'empty' instance of the bindings data structure to be
;;; used at the start of a fresh compilation.

(define (make-bindings)
  ((record-constructor bindings-type) '() (make-hash-table)))

;;; Mark that a given symbol is needed as global in the specified
;;; slot-module.

(define (mark-global-needed! bindings sym module)
  (let* ((old-needed ((record-accessor bindings-type 'needed-globals)
                      bindings))
         (old-in-module (or (assoc-ref old-needed module) '()))
         (new-in-module (if (memq sym old-in-module)
                            old-in-module
                            (cons sym old-in-module)))
         (new-needed (assoc-set! old-needed module new-in-module)))
    ((record-modifier bindings-type 'needed-globals)
     bindings
     new-needed)))

;;; Cycle through all globals needed in order to generate the code for
;;; their creation or some other analysis.

(define (map-globals-needed bindings proc)
  (let ((needed ((record-accessor bindings-type 'needed-globals)
                 bindings)))
    (let iterate-modules ((mod-tail needed)
                          (mod-result '()))
      (if (null? mod-tail)
          mod-result
          (iterate-modules
           (cdr mod-tail)
           (let* ((aentry (car mod-tail))
                  (module (car aentry))
                  (symbols (cdr aentry)))
             (let iterate-symbols ((sym-tail symbols)
                                   (sym-result mod-result))
               (if (null? sym-tail)
                   sym-result
                   (iterate-symbols (cdr sym-tail)
                                    (cons (proc module (car sym-tail))
                                          sym-result))))))))))

;;; Get the current lexical binding (gensym it should refer to in the
;;; current scope) for a symbol or #f if it is dynamically bound.

(define (get-lexical-binding bindings sym)
  (let* ((lex ((record-accessor bindings-type 'lexical-bindings)
               bindings))
         (slot (hash-ref lex sym #f)))
    (if slot
        (fluid-ref slot)
        #f)))

;;; Establish a binding or mark a symbol as dynamically bound for the
;;; extent of calling proc.

(define (with-symbol-bindings bindings syms targets proc)
  (if (or (not (list? syms))
          (not (and-map symbol? syms)))
      (error "can't bind non-symbols" syms))
  (let ((lex ((record-accessor bindings-type 'lexical-bindings)
              bindings)))
    (for-each (lambda (sym)
                (if (not (hash-ref lex sym))
                    (hash-set! lex sym (make-fluid))))
              syms)
    (with-fluids* (map (lambda (sym) (hash-ref lex sym)) syms)
                  targets
                  proc)))

(define (with-lexical-bindings bindings syms targets proc)
  (if (or (not (list? targets))
          (not (and-map symbol? targets)))
      (error "invalid targets for lexical binding" targets)
      (with-symbol-bindings bindings syms targets proc)))

(define (with-dynamic-bindings bindings syms proc)
  (with-symbol-bindings bindings
                        syms
                        (map (lambda (el) #f) syms)
                        proc))


code:
;;; Guile Emacs Lisp

;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3, or (at your option)
;;; any later version.
;;;
;;; This program 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
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; see the file COPYING. If not, write to the
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
;;; MA 02111-1307, USA.

;;; Code:

(define-module (language elisp compile-tree-il)
  #:use-module (language elisp bindings)
  #:use-module (language elisp runtime)
  #:use-module (language tree-il)
  #:use-module (system base pmatch)
  #:use-module (system base compile)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-8)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:export (compile-tree-il
            compile-progn
            compile-if
            compile-defconst
            compile-defvar
            compile-setq
            compile-let
            compile-lexical-let
            compile-flet
            compile-let*
            compile-lexical-let*
            compile-flet*
            compile-without-void-checks
            compile-with-always-lexical
            compile-guile-ref
            compile-guile-primitive
            compile-while
            compile-function
            compile-defmacro
            compile-defun
            #{compile-`}#
            compile-quote))

;;; Certain common parameters (like the bindings data structure or
;;; compiler options) are not always passed around but accessed using
;;; fluids to simulate dynamic binding (hey, this is about elisp).

;;; The bindings data structure to keep track of symbol binding related
;;; data.

(define bindings-data (make-fluid))

;;; Store for which symbols (or all/none) void checks are disabled.

(define disable-void-check (make-fluid))

;;; Store which symbols (or all/none) should always be bound lexically,
;;; even with ordinary let and as lambda arguments.

(define always-lexical (make-fluid))

;;; Find the source properties of some parsed expression if there are
;;; any associated with it.

(define (location x)
  (and (pair? x)
       (let ((props (source-properties x)))
         (and (not (null? props))
              props))))

;;; Values to use for Elisp's nil and t.

(define (nil-value loc)
  (make-const loc (@ (language elisp runtime) nil-value)))

(define (t-value loc)
  (make-const loc (@ (language elisp runtime) t-value)))

;;; Modules that contain the value and function slot bindings.

(define runtime '(language elisp runtime))

(define value-slot (@ (language elisp runtime) value-slot-module))

(define function-slot (@ (language elisp runtime) function-slot-module))

;;; The backquoting works the same as quasiquotes in Scheme, but the
;;; forms are named differently; to make easy adaptions, we define these
;;; predicates checking for a symbol being the car of an
;;; unquote/unquote-splicing/backquote form.

(define (unquote? sym)
  (and (symbol? sym) (eq? sym '#{,}#)))

(define (unquote-splicing? sym)
  (and (symbol? sym) (eq? sym '#{,@}#)))

;;; Build a call to a primitive procedure nicely.

(define (call-primitive loc sym . args)
  (make-application loc (make-primitive-ref loc sym) args))

;;; Error reporting routine for syntax/compilation problems or build
;;; code for a runtime-error output.

(define (report-error loc . args)
  (apply error args))

(define (runtime-error loc msg . args)
  (make-application loc
                    (make-primitive-ref loc 'error)
                    (cons (make-const loc msg) args)))

;;; Generate code to ensure a global symbol is there for further use of
;;; a given symbol. In general during the compilation, those needed are
;;; only tracked with the bindings data structure. Afterwards, however,
;;; for all those needed symbols the globals are really generated with
;;; this routine.

(define (generate-ensure-global loc sym module)
  (make-application loc
                    (make-module-ref loc runtime 'ensure-fluid! #t)
                    (list (make-const loc module)
                          (make-const loc sym))))

(define (ensuring-globals loc bindings body)
  (make-sequence
   loc
   `(,@(map-globals-needed (fluid-ref bindings)
                           (lambda (mod sym)
                             (generate-ensure-global loc sym mod)))
     ,body)))

;;; Build a construct that establishes dynamic bindings for certain
;;; variables. We may want to choose between binding with fluids and
;;; with-fluids* and using just ordinary module symbols and
;;; setting/reverting their values with a dynamic-wind.

(define (let-dynamic loc syms module vals body)
  (call-primitive
   loc
   'with-fluids*
   (make-application loc
                     (make-primitive-ref loc 'list)
                     (map (lambda (sym)
                            (make-module-ref loc module sym #t))
                          syms))
   (make-application loc (make-primitive-ref loc 'list) vals)
   (make-lambda loc
                '()
                (make-lambda-case #f '() #f #f #f '() '() body #f))))

;;; Handle access to a variable (reference/setting) correctly depending
;;; on whether it is currently lexically or dynamically bound. lexical
;;; access is done only for references to the value-slot module!

(define (access-variable loc
                         sym
                         module
                         handle-global
                         handle-lexical
                         handle-dynamic)
  (let ((lexical (get-lexical-binding (fluid-ref bindings-data) sym)))
    (cond
     (lexical (handle-lexical lexical))
     ((equal? module function-slot) (handle-global))
     (else (handle-dynamic)))))

;;; Generate code to reference a variable. For references in the
;;; value-slot module, we may want to generate a lexical reference
;;; instead if the variable has a lexical binding.

(define (reference-variable loc sym module)
  (access-variable
   loc
   sym
   module
   (lambda () (make-module-ref loc module sym #t))
   (lambda (lexical) (make-lexical-ref loc lexical lexical))
   (lambda ()
     (mark-global-needed! (fluid-ref bindings-data) sym module)
     (call-primitive loc
                     'fluid-ref
                     (make-module-ref loc module sym #t)))))

;;; Generate code to set a variable. Just as with reference-variable, in
;;; case of a reference to value-slot, we want to generate a lexical set
;;; when the variable has a lexical binding.

(define (set-variable! loc sym module value)
  (access-variable
   loc
   sym
   module
   (lambda ()
     (make-application
      loc
      (make-module-ref loc runtime 'set-variable! #t)
      (list (make-const loc module) (make-const loc sym) value)))
   (lambda (lexical) (make-lexical-set loc lexical lexical value))
   (lambda ()
     (mark-global-needed! (fluid-ref bindings-data) sym module)
     (call-primitive loc
                     'fluid-set!
                     (make-module-ref loc module sym #t)
                     value))))

;;; Process the bindings part of a let or let* expression; that is,
;;; check for correctness and bring it to the form ((sym1 . val1) (sym2
;;; . val2) ...).

(define (process-let-bindings loc bindings)
  (map
   (lambda (b)
     (if (symbol? b)
         (cons b 'nil)
         (if (or (not (list? b))
                 (not (= (length b) 2)))
             (report-error
              loc
              "expected symbol or list of 2 elements in let")
             (if (not (symbol? (car b)))
                 (report-error loc "expected symbol in let")
                 (cons (car b) (cadr b))))))
   bindings))

;;; Split the let bindings into a list to be done lexically and one
;;; dynamically. A symbol will be bound lexically if and only if: We're
;;; processing a lexical-let (i.e. module is 'lexical), OR we're
;;; processing a value-slot binding AND the symbol is already lexically
;;; bound or is always lexical, OR we're processing a function-slot
;;; binding.

(define (bind-lexically? sym module)
  (or (eq? module 'lexical)
      (eq? module function-slot)
      (and (equal? module value-slot)
           (let ((always (fluid-ref always-lexical)))
             (or (eq? always 'all)
                 (memq sym always)
                 (get-lexical-binding (fluid-ref bindings-data) sym))))))

(define (split-let-bindings bindings module)
  (let iterate ((tail bindings)
                (lexical '())
                (dynamic '()))
    (if (null? tail)
        (values (reverse lexical) (reverse dynamic))
        (if (bind-lexically? (caar tail) module)
            (iterate (cdr tail) (cons (car tail) lexical) dynamic)
            (iterate (cdr tail) lexical (cons (car tail) dynamic))))))

;;; Compile let and let* expressions. The code here is used both for
;;; let/let* and flet/flet*, just with a different bindings module.
;;;
;;; A special module value 'lexical means that we're doing a lexical-let
;;; instead and the bindings should not be saved to globals at all but
;;; be done with the lexical framework instead.

;;; Let is done with a single call to let-dynamic binding them locally
;;; to new values all "at once". If there is at least one variable to
;;; bind lexically among the bindings, we first do a let for all of them
;;; to evaluate all values before any bindings take place, and then call
;;; let-dynamic for the variables to bind dynamically.

(define (generate-let loc module bindings body)
  (let ((bind (process-let-bindings loc bindings)))
    (call-with-values
        (lambda () (split-let-bindings bind module))
      (lambda (lexical dynamic)
        (for-each (lambda (sym)
                    (mark-global-needed! (fluid-ref bindings-data)
                                         sym
                                         module))
                  (map car dynamic))
        (let ((make-values (lambda (for)
                             (map (lambda (el) (compile-expr (cdr el)))
                                  for)))
              (make-body (lambda ()
                           (make-sequence loc (map compile-expr body)))))
          (if (null? lexical)
              (let-dynamic loc (map car dynamic) module
                           (make-values dynamic) (make-body))
              (let* ((lexical-syms (map (lambda (el) (gensym)) lexical))
                     (dynamic-syms (map (lambda (el) (gensym)) dynamic))
                     (all-syms (append lexical-syms dynamic-syms))
                     (vals (append (make-values lexical)
                                   (make-values dynamic))))
                (make-let loc
                          all-syms
                          all-syms
                          vals
                          (with-lexical-bindings
                           (fluid-ref bindings-data)
                           (map car lexical) lexical-syms
                           (lambda ()
                             (if (null? dynamic)
                                 (make-body)
                                 (let-dynamic loc
                                              (map car dynamic)
                                              module
                                              (map
                                               (lambda (sym)
                                                 (make-lexical-ref loc
                                                                   sym
                                                                   sym))
                                               dynamic-syms)
                                              (make-body)))))))))))))

;;; Let* is compiled to a cascaded set of "small lets" for each binding
;;; in turn so that each one already sees the preceding bindings.

(define (generate-let* loc module bindings body)
  (let ((bind (process-let-bindings loc bindings)))
    (begin
      (for-each (lambda (sym)
                  (if (not (bind-lexically? sym module))
                      (mark-global-needed! (fluid-ref bindings-data)
                                           sym
                                           module)))
                (map car bind))
      (let iterate ((tail bind))
        (if (null? tail)
            (make-sequence loc (map compile-expr body))
            (let ((sym (caar tail))
                  (value (compile-expr (cdar tail))))
              (if (bind-lexically? sym module)
                  (let ((target (gensym)))
                    (make-let loc
                              `(,target)
                              `(,target)
                              `(,value)
                              (with-lexical-bindings
                               (fluid-ref bindings-data)
                               `(,sym)
                               `(,target)
                               (lambda () (iterate (cdr tail))))))
                  (let-dynamic loc
                               `(,(caar tail))
                               module
                               `(,value)
                               (iterate (cdr tail))))))))))

;;; Split the argument list of a lambda expression into required,
;;; optional and rest arguments and also check it is actually valid.
;;; Additionally, we create a list of all "local variables" (that is,
;;; required, optional and rest arguments together) and also this one
;;; split into those to be bound lexically and dynamically. Returned is
;;; as multiple values: required optional rest lexical dynamic

(define (bind-arg-lexical? arg)
  (let ((always (fluid-ref always-lexical)))
    (or (eq? always 'all)
        (memq arg always))))

(define (split-lambda-arguments loc args)
  (let iterate ((tail args)
                (mode 'required)
                (required '())
                (optional '())
                (lexical '())
                (dynamic '()))
    (cond
     ((null? tail)
      (let ((final-required (reverse required))
            (final-optional (reverse optional))
            (final-lexical (reverse lexical))
            (final-dynamic (reverse dynamic)))
        (values final-required
                final-optional
                #f
                final-lexical
                final-dynamic)))
     ((and (eq? mode 'required)
           (eq? (car tail) '&optional))
      (iterate (cdr tail) 'optional required optional lexical dynamic))
     ((eq? (car tail) '&rest)
      (if (or (null? (cdr tail))
              (not (null? (cddr tail))))
          (report-error loc "expected exactly one symbol after &rest")
          (let* ((rest (cadr tail))
                 (rest-lexical (bind-arg-lexical? rest))
                 (final-required (reverse required))
                 (final-optional (reverse optional))
                 (final-lexical (reverse (if rest-lexical
                                             (cons rest lexical)
                                             lexical)))
                 (final-dynamic (reverse (if rest-lexical
                                             dynamic
                                             (cons rest dynamic)))))
            (values final-required
                    final-optional
                    rest
                    final-lexical
                    final-dynamic))))
     (else
      (if (not (symbol? (car tail)))
          (report-error loc
                        "expected symbol in argument list, got"
                        (car tail))
          (let* ((arg (car tail))
                 (bind-lexical (bind-arg-lexical? arg))
                 (new-lexical (if bind-lexical
                                  (cons arg lexical)
                                  lexical))
                 (new-dynamic (if bind-lexical
                                  dynamic
                                  (cons arg dynamic))))
            (case mode
              ((required) (iterate (cdr tail) mode
                                   (cons arg required) optional
                                   new-lexical new-dynamic))
              ((optional) (iterate (cdr tail) mode
                                   required (cons arg optional)
                                   new-lexical new-dynamic))
              (else
               (error "invalid mode in split-lambda-arguments"
                      mode)))))))))

;;; Compile a lambda expression. One thing we have to be aware of is
;;; that lambda arguments are usually dynamically bound, even when a
;;; lexical binding is intact for a symbol. For symbols that are marked
;;; as 'always lexical,' however, we lexically bind here as well, and
;;; thus we get them out of the let-dynamic call and register a lexical
;;; binding for them (the lexical target variable is already there,
;;; namely the real lambda argument from TreeIL).

(define (compile-lambda loc args body)
  (if (not (list? args))
      (report-error loc "expected list for argument-list" args))
  (if (null? body)
      (report-error loc "function body must not be empty"))
  (receive (required optional rest lexical dynamic)
           (split-lambda-arguments loc args)
    (define (process-args args)
      (define (find-pairs pairs filter)
        (lset-intersection (lambda (name+sym x)
                             (eq? (car name+sym) x))
                           pairs
                           filter))
      (let* ((syms (map (lambda (x) (gensym)) args))
             (pairs (map cons args syms))
             (lexical-pairs (find-pairs pairs lexical))
             (dynamic-pairs (find-pairs pairs dynamic)))
        (values syms pairs lexical-pairs dynamic-pairs)))
    (let*-values (((required-syms
                    required-pairs
                    required-lex-pairs
                    required-dyn-pairs)
                   (process-args required))
                  ((optional-syms
                    optional-pairs
                    optional-lex-pairs
                    optional-dyn-pairs)
                   (process-args optional))
                  ((rest-syms rest-pairs rest-lex-pairs rest-dyn-pairs)
                   (process-args (if rest (list rest) '())))
                  ((the-rest-sym) (if rest (car rest-syms) #f))
                  ((all-syms) (append required-syms
                                      optional-syms
                                      rest-syms))
                  ((all-lex-pairs) (append required-lex-pairs
                                           optional-lex-pairs
                                           rest-lex-pairs))
                  ((all-dyn-pairs) (append required-dyn-pairs
                                           optional-dyn-pairs
                                           rest-dyn-pairs)))
      (for-each (lambda (sym)
                  (mark-global-needed! (fluid-ref bindings-data)
                                       sym
                                       value-slot))
                dynamic)
      (with-dynamic-bindings
       (fluid-ref bindings-data)
       dynamic
       (lambda ()
         (with-lexical-bindings
          (fluid-ref bindings-data)
          (map car all-lex-pairs)
          (map cdr all-lex-pairs)
          (lambda ()
            (make-lambda
             loc
             '()
             (make-lambda-case
              #f
              required
              optional
              rest
              #f
              (map (lambda (x) (nil-value loc)) optional)
              all-syms
              (let ((compiled-body
                     (make-sequence loc (map compile-expr body))))
                (make-sequence
                 loc
                 (list
                  (if rest
                      (make-conditional
                       loc
                       (call-primitive loc
                                       'null?
                                       (make-lexical-ref loc
                                                         rest
                                                         the-rest-sym))
                       (make-lexical-set loc
                                         rest
                                         the-rest-sym
                                         (nil-value loc))
                       (make-void loc))
                      (make-void loc))
                  (if (null? dynamic)
                      compiled-body
                      (let-dynamic loc
                                   dynamic
                                   value-slot
                                   (map (lambda (name-sym)
                                          (make-lexical-ref
                                           loc
                                           (car name-sym)
                                           (cdr name-sym)))
                                        all-dyn-pairs)
                                   compiled-body)))))
              #f)))))))))

;;; Handle the common part of defconst and defvar, that is, checking for
;;; a correct doc string and arguments as well as maybe in the future
;;; handling the docstring somehow.

(define (handle-var-def loc sym doc)
  (cond
   ((not (symbol? sym)) (report-error loc "expected symbol, got" sym))
   ((> (length doc) 1) (report-error loc "too many arguments to defvar"))
   ((and (not (null? doc)) (not (string? (car doc))))
    (report-error loc "expected string as third argument of defvar, got"
                  (car doc)))
   ;; TODO: Handle doc string if present.
   (else #t)))

;;; Handle macro and special operator bindings.

(define (find-operator sym type)
  (and
   (symbol? sym)
   (module-defined? (resolve-interface function-slot) sym)
   (let* ((op (module-ref (resolve-module function-slot) sym))
          (op (if (fluid? op) (fluid-ref op) op)))
     (if (and (pair? op) (eq? (car op) type))
         (cdr op)
         #f))))

;;; See if a (backquoted) expression contains any unquotes.

(define (contains-unquotes? expr)
  (if (pair? expr)
      (if (or (unquote? (car expr)) (unquote-splicing? (car expr)))
          #t
          (or (contains-unquotes? (car expr))
              (contains-unquotes? (cdr expr))))
      #f))

;;; Process a backquoted expression by building up the needed
;;; cons/append calls. For splicing, it is assumed that the expression
;;; spliced in evaluates to a list. The emacs manual does not really
;;; state either it has to or what to do if it does not, but Scheme
;;; explicitly forbids it and this seems reasonable also for elisp.

(define (unquote-cell? expr)
  (and (list? expr) (= (length expr) 2) (unquote? (car expr))))

(define (unquote-splicing-cell? expr)
  (and (list? expr) (= (length expr) 2) (unquote-splicing? (car expr))))

(define (process-backquote loc expr)
  (if (contains-unquotes? expr)
      (if (pair? expr)
          (if (or (unquote-cell? expr) (unquote-splicing-cell? expr))
              (compile-expr (cadr expr))
              (let* ((head (car expr))
                     (processed-tail (process-backquote loc (cdr expr)))
                     (head-is-list-2 (and (list? head)
                                          (= (length head) 2)))
                     (head-unquote (and head-is-list-2
                                        (unquote? (car head))))
                     (head-unquote-splicing (and head-is-list-2
                                                 (unquote-splicing?
                                                  (car head)))))
                (if head-unquote-splicing
                    (call-primitive loc
                                    'append
                                    (compile-expr (cadr head))
                                    processed-tail)
                    (call-primitive loc 'cons
                                    (if head-unquote
                                        (compile-expr (cadr head))
                                        (process-backquote loc head))
                                    processed-tail))))
          (report-error loc
                        "non-pair expression contains unquotes"
                        expr))
      (make-const loc expr)))

;;; Temporarily update a list of symbols that are handled specially
;;; (disabled void check or always lexical) for compiling body. We need
;;; to handle special cases for already all / set to all and the like.

(define (with-added-symbols loc fluid syms body)
  (if (null? body)
      (report-error loc "symbol-list construct has empty body"))
  (if (not (or (eq? syms 'all)
               (and (list? syms) (and-map symbol? syms))))
      (report-error loc "invalid symbol list" syms))
  (let ((old (fluid-ref fluid))
        (make-body (lambda ()
                     (make-sequence loc (map compile-expr body)))))
    (if (eq? old 'all)
        (make-body)
        (let ((new (if (eq? syms 'all)
                       'all
                       (append syms old))))
          (with-fluids ((fluid new))
            (make-body))))))

;;; Special operators

(defspecial progn (loc args)
  (make-sequence loc (map compile-expr args)))

(defspecial if (loc args)
  (pmatch args
    ((,cond ,then . ,else)
     (make-conditional loc
                       (compile-expr cond)
                       (compile-expr then)
                       (if (null? else)
                           (nil-value loc)
                           (make-sequence loc
                                          (map compile-expr else)))))))

(defspecial defconst (loc args)
  (pmatch args
    ((,sym ,value . ,doc)
     (if (handle-var-def loc sym doc)
         (make-sequence loc
                        (list (set-variable! loc
                                             sym
                                             value-slot
                                             (compile-expr value))
                              (make-const loc sym)))))))

(defspecial defvar (loc args)
  (pmatch args
    ((,sym) (make-const loc sym))
    ((,sym ,value . ,doc)
     (if (handle-var-def loc sym doc)
         (make-sequence
          loc
          (list
           (make-conditional
            loc
            (make-conditional
             loc
             (call-primitive
              loc
              'module-bound?
              (call-primitive loc
                              'resolve-interface
                              (make-const loc value-slot))
              (make-const loc sym))
             (call-primitive loc
                             'fluid-bound?
                             (make-module-ref loc value-slot sym #t))
             (make-const loc #f))
            (make-void loc)
            (set-variable! loc sym value-slot (compile-expr value)))
           (make-const loc sym)))))))

(defspecial setq (loc args)
  (define (car* x) (if (null? x) '() (car x)))
  (define (cdr* x) (if (null? x) '() (cdr x)))
  (define (cadr* x) (car* (cdr* x)))
  (define (cddr* x) (cdr* (cdr* x)))
  (make-sequence
   loc
   (let loop ((args args) (last (nil-value loc)))
     (if (null? args)
         (list last)
         (let ((sym (car args))
               (val (compile-expr (cadr* args))))
           (if (not (symbol? sym))
               (report-error loc "expected symbol in setq")
               (cons
                (set-variable! loc sym value-slot val)
                (loop (cddr* args)
                      (reference-variable loc sym value-slot)))))))))

(defspecial let (loc args)
  (pmatch args
    ((,bindings . ,body)
     (generate-let loc value-slot bindings body))))

(defspecial lexical-let (loc args)
  (pmatch args
    ((,bindings . ,body)
     (generate-let loc 'lexical bindings body))))

(defspecial flet (loc args)
  (pmatch args
    ((,bindings . ,body)
     (generate-let loc function-slot bindings body))))

(defspecial let* (loc args)
  (pmatch args
    ((,bindings . ,body)
     (generate-let* loc value-slot bindings body))))

(defspecial lexical-let* (loc args)
  (pmatch args
    ((,bindings . ,body)
     (generate-let* loc 'lexical bindings body))))

(defspecial flet* (loc args)
  (pmatch args
    ((,bindings . ,body)
     (generate-let* loc function-slot bindings body))))

;;; Temporarily set symbols as always lexical only for the lexical scope
;;; of a construct.

(defspecial with-always-lexical (loc args)
  (pmatch args
    ((,syms . ,body)
     (with-added-symbols loc always-lexical syms body))))

;;; guile-ref allows building TreeIL's module references from within
;;; elisp as a way to access data within the Guile universe. The module
;;; and symbol referenced are static values, just like (@ module symbol)
;;; does!

(defspecial guile-ref (loc args)
  (pmatch args
    ((,module ,sym) (guard (and (list? module) (symbol? sym)))
     (make-module-ref loc module sym #t))))

;;; guile-primitive allows to create primitive references, which are
;;; still a little faster.

(defspecial guile-primitive (loc args)
  (pmatch args
    ((,sym)
     (make-primitive-ref loc sym))))

;;; A while construct is transformed into a tail-recursive loop like
;;; this:
;;;
;;; (letrec ((iterate (lambda ()
;;;                     (if condition
;;;                       (begin body
;;;                              (iterate))
;;;                       #nil))))
;;;   (iterate))
;;;
;;; As letrec is not directly accessible from elisp, while is
;;; implemented here instead of with a macro.

(defspecial while (loc args)
  (pmatch args
    ((,condition . ,body)
     (let* ((itersym (gensym))
            (compiled-body (map compile-expr body))
            (iter-call (make-application loc
                                         (make-lexical-ref loc
                                                           'iterate
                                                           itersym)
                                         (list)))
            (full-body (make-sequence loc
                                      `(,@compiled-body ,iter-call)))
            (lambda-body (make-conditional loc
                                           (compile-expr condition)
                                           full-body
                                           (nil-value loc)))
            (iter-thunk (make-lambda loc
                                     '()
                                     (make-lambda-case #f
                                                       '()
                                                       #f
                                                       #f
                                                       #f
                                                       '()
                                                       '()
                                                       lambda-body
                                                       #f))))
       (make-letrec loc
                    #f
                    '(iterate)
                    (list itersym)
                    (list iter-thunk)
                    iter-call)))))

(defspecial function (loc args)
  (pmatch args
    (((lambda ,args . ,body))
     (compile-lambda loc args body))
    ((,sym) (guard (symbol? sym))
     (reference-variable loc sym function-slot))))

(defspecial defmacro (loc args)
  (pmatch args
    ((,name ,args . ,body)
     (if (not (symbol? name))
         (report-error loc "expected symbol as macro name" name)
         (let* ((tree-il
                 (make-sequence
                  loc
                  (list
                   (set-variable!
                    loc
                    name
                    function-slot
                    (make-application
                     loc
                     (make-module-ref loc '(guile) 'cons #t)
                     (list (make-const loc 'macro)
                           (compile-lambda loc args body))))
                   (make-const loc name)))))
           (compile (ensuring-globals loc bindings-data tree-il)
                    #:from 'tree-il
                    #:to 'value)
           tree-il)))))

(defspecial defun (loc args)
  (pmatch args
    ((,name ,args . ,body)
     (if (not (symbol? name))
         (report-error loc "expected symbol as function name" name)
         (make-sequence loc
                        (list (set-variable! loc
                                             name
                                             function-slot
                                             (compile-lambda loc
                                                             args
                                                             body))
                              (make-const loc name)))))))

(defspecial #{`}# (loc args)
  (pmatch args
    ((,val)
     (process-backquote loc val))))

(defspecial quote (loc args)
  (pmatch args
    ((,val)
     (make-const loc val))))

;;; Compile a compound expression to Tree-IL.

(define (compile-pair loc expr)
  (let ((operator (car expr))
        (arguments (cdr expr)))
    (cond
     ((find-operator operator 'special-operator)
      => (lambda (special-operator-function)
           (special-operator-function loc arguments)))
     ((find-operator operator 'macro)
      => (lambda (macro-function)
           (compile-expr (apply macro-function arguments))))
     (else
      (make-application loc
                        (if (symbol? operator)
                            (reference-variable loc
                                                operator
                                                function-slot)
                            (compile-expr operator))
                        (map compile-expr arguments))))))

;;; Compile a symbol expression. This is a variable reference or maybe
;;; some special value like nil.

(define (compile-symbol loc sym)
  (case sym
    ((nil) (nil-value loc))
    ((t) (t-value loc))
    (else (reference-variable loc sym value-slot))))

;;; Compile a single expression to TreeIL.

(define (compile-expr expr)
  (let ((loc (location expr)))
    (cond
     ((symbol? expr)
      (compile-symbol loc expr))
     ((pair? expr)
      (compile-pair loc expr))
     (else (make-const loc expr)))))

;;; Process the compiler options. FIXME: Why is '(()) passed as options
;;; by the REPL?

(define (valid-symbol-list-arg? value)
  (or (eq? value 'all)
      (and (list? value) (and-map symbol? value))))

(define (process-options! opt)
  (if (and (not (null? opt))
           (not (equal? opt '(()))))
      (if (null? (cdr opt))
          (report-error #f "Invalid compiler options" opt)
          (let ((key (car opt))
                (value (cadr opt)))
            (case key
              ((#:warnings)             ; ignore
               #f)
              ((#:always-lexical)
               (if (valid-symbol-list-arg? value)
                   (fluid-set! always-lexical value)
                   (report-error #f
                                 "Invalid value for #:always-lexical"
                                 value)))
              (else (report-error #f
                                  "Invalid compiler option"
                                  key)))))))

;;; Entry point for compilation to TreeIL. This creates the bindings
;;; data structure, and after compiling the main expression we need to
;;; make sure all globals for symbols used during the compilation are
;;; created using the generate-ensure-global function.

(define (compile-tree-il expr env opts)
  (values
   (with-fluids ((bindings-data (make-bindings))
                 (disable-void-check '())
                 (always-lexical '()))
     (process-options! opts)
     (let ((compiled (compile-expr expr)))
      (ensuring-globals (location expr) bindings-data compiled)))
   env
   env))


code:
;;; Guile Emacs Lisp

;;; 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 elisp lexer)
  #:use-module (ice-9 regex)
  #:export (get-lexer get-lexer/1))

;;; This is the lexical analyzer for the elisp reader. It is
;;; hand-written instead of using some generator. I think this is the
;;; best solution because of all that fancy escape sequence handling and
;;; the like.
;;;
;;; Characters are handled internally as integers representing their
;;; code value. This is necessary because elisp allows a lot of fancy
;;; modifiers that set certain high-range bits and the resulting values
;;; would not fit into a real Scheme character range. Additionally,
;;; elisp wants characters as integers, so we just do the right thing...
;;;
;;; TODO: #@count comments

;;; Report an error from the lexer (that is, invalid input given).

(define (lexer-error port msg . args)
  (apply error msg args))

;;; In a character, set a given bit. This is just some bit-wise or'ing
;;; on the characters integer code and converting back to character.

(define (set-char-bit chr bit)
  (logior chr (ash 1 bit)))

;;; Check if a character equals some other. This is just like char=?
;;; except that the tested one could be EOF in which case it simply
;;; isn't equal.

(define (is-char? tested should-be)
  (and (not (eof-object? tested))
       (char=? tested should-be)))

;;; For a character (as integer code), find the real character it
;;; represents or #\nul if out of range. This is used to work with
;;; Scheme character functions like char-numeric?.

(define (real-character chr)
  (if (< chr 256)
      (integer->char chr)
      #\nul))

;;; Return the control modified version of a character. This is not just
;;; setting a modifier bit, because ASCII conrol characters must be
;;; handled as such, and in elisp C-? is the delete character for
;;; historical reasons. Otherwise, we set bit 26.

(define (add-control chr)
  (let ((real (real-character chr)))
    (if (char-alphabetic? real)
        (- (char->integer (char-upcase real)) (char->integer #\@))
        (case real
          ((#\?) 127)
          ((#\@) 0)
          (else (set-char-bit chr 26))))))

;;; Parse a charcode given in some base, basically octal or hexadecimal
;;; are needed. A requested number of digits can be given (#f means it
;;; does not matter and arbitrary many are allowed), and additionally
;;; early return allowed (if fewer valid digits are found). These
;;; options are all we need to handle the \u, \U, \x and \ddd (octal
;;; digits) escape sequences.

(define (charcode-escape port base digits early-return)
  (let iterate ((result 0)
                (procdigs 0))
    (if (and digits (>= procdigs digits))
        result
        (let* ((cur (read-char port))
               (value (cond
                       ((char-numeric? cur)
                        (- (char->integer cur) (char->integer #\0)))
                       ((char-alphabetic? cur)
                        (let ((code (- (char->integer (char-upcase cur))
                                       (char->integer #\A))))
                          (if (< code 0)
                              #f
                              (+ code 10))))
                       (else #f)))
               (valid (and value (< value base))))
          (if (not valid)
              (if (or (not digits) early-return)
                  (begin
                    (unread-char cur port)
                    result)
                  (lexer-error port
                               "invalid digit in escape-code"
                               base
                               cur))
              (iterate (+ (* result base) value) (1+ procdigs)))))))

;;; Read a character and process escape-sequences when necessary. The
;;; special in-string argument defines if this character is part of a
;;; string literal or a single character literal, the difference being
;;; that in strings the meta modifier sets bit 7, while it is bit 27 for
;;; characters.

(define basic-escape-codes
  '((#\a . 7)
    (#\b . 8)
    (#\t . 9)
    (#\n . 10)
    (#\v . 11)
    (#\f . 12)
    (#\r . 13)
    (#\e . 27)
    (#\s . 32)
    (#\d . 127)))

(define (get-character port in-string)
  (let ((meta-bits `((#\A . 22)
                     (#\s . 23)
                     (#\H . 24)
                     (#\S . 25)
                     (#\M . ,(if in-string 7 27))))
        (cur (read-char port)))
    (if (char=? cur #\\)
        ;; Handle an escape-sequence.
        (let* ((escaped (read-char port))
               (esc-code (assq-ref basic-escape-codes escaped))
               (meta (assq-ref meta-bits escaped)))
          (cond
           ;; Meta-check must be before esc-code check because \s- must
           ;; be recognized as the super-meta modifier if a - follows.
           ;; If not, it will be caught as \s -> space escape code.
           ((and meta (is-char? (peek-char port) #\-))
            (if (not (char=? (read-char port) #\-))
                (error "expected - after control sequence"))
            (set-char-bit (get-character port in-string) meta))
           ;; One of the basic control character escape names?
           (esc-code esc-code)
           ;; Handle \ddd octal code if it is one.
           ((and (char>=? escaped #\0) (char<? escaped #\8))
            (begin
              (unread-char escaped port)
              (charcode-escape port 8 3 #t)))
           ;; Check for some escape-codes directly or otherwise use the
           ;; escaped character literally.
           (else
            (case escaped
              ((#\^) (add-control (get-character port in-string)))
              ((#\C)
               (if (is-char? (peek-char port) #\-)
                   (begin
                     (if (not (char=? (read-char port) #\-))
                         (error "expected - after control sequence"))
                     (add-control (get-character port in-string)))
                   escaped))
              ((#\x) (charcode-escape port 16 #f #t))
              ((#\u) (charcode-escape port 16 4 #f))
              ((#\U) (charcode-escape port 16 8 #f))
              (else (char->integer escaped))))))
        ;; No escape-sequence, just the literal character. But remember
        ;; to get the code instead!
        (char->integer cur))))

;;; Read a symbol or number from a port until something follows that
;;; marks the start of a new token (like whitespace or parentheses). The
;;; data read is returned as a string for further conversion to the
;;; correct type, but we also return what this is
;;; (integer/float/symbol). If any escaped character is found, it must
;;; be a symbol. Otherwise we at the end check the result-string against
;;; regular expressions to determine if it is possibly an integer or a
;;; float.

(define integer-regex (make-regexp "^[+-]?[0-9]+\\.?$"))

(define float-regex
  (make-regexp
   "^[+-]?([0-9]+\\.?[0-9]*|[0-9]*\\.?[0-9]+)(e[+-]?[0-9]+)?$"))

;;; A dot is also allowed literally, only a single dort alone is parsed
;;; as the 'dot' terminal for dotted lists.

(define no-escape-punctuation (string->char-set "-+=*/_~!@$%^&:<>{}?."))

(define (get-symbol-or-number port)
  (let iterate ((result-chars '())
                (had-escape #f))
    (let* ((c (read-char port))
           (finish (lambda ()
                     (let ((result (list->string
                                    (reverse result-chars))))
                       (values
                        (cond
                         ((and (not had-escape)
                               (regexp-exec integer-regex result))
                          'integer)
                         ((and (not had-escape)
                               (regexp-exec float-regex result))
                          'float)
                         (else 'symbol))
                        result))))
           (need-no-escape? (lambda (c)
                              (or (char-numeric? c)
                                  (char-alphabetic? c)
                                  (char-set-contains?
                                   no-escape-punctuation
                                   c)))))
      (cond
       ((eof-object? c) (finish))
       ((need-no-escape? c) (iterate (cons c result-chars) had-escape))
       ((char=? c #\\) (iterate (cons (read-char port) result-chars) #t))
       (else
        (unread-char c port)
        (finish))))))

;;; Parse a circular structure marker without the leading # (which was
;;; already read and recognized), that is, a number as identifier and
;;; then either = or #.

(define (get-circular-marker port)
  (call-with-values
      (lambda ()
        (let iterate ((result 0))
          (let ((cur (read-char port)))
            (if (char-numeric? cur)
                (let ((val (- (char->integer cur) (char->integer #\0))))
                  (iterate (+ (* result 10) val)))
                (values result cur)))))
    (lambda (id type)
      (case type
        ((#\#) `(circular-ref . ,id))
        ((#\=) `(circular-def . ,id))
        (else (lexer-error port
                           "invalid circular marker character"
                           type))))))

;;; Main lexer routine, which is given a port and does look for the next
;;; token.

(define (lex port)
  (let ((return (let ((file (if (file-port? port)
                                (port-filename port)
                                #f))
                      (line (1+ (port-line port)))
                      (column (1+ (port-column port))))
                  (lambda (token value)
                    (let ((obj (cons token value)))
                      (set-source-property! obj 'filename file)
                      (set-source-property! obj 'line line)
                      (set-source-property! obj 'column column)
                      obj))))
        ;; Read afterwards so the source-properties are correct above
        ;; and actually point to the very character to be read.
        (c (read-char port)))
    (cond
     ;; End of input must be specially marked to the parser.
     ((eof-object? c) (return 'eof c))
     ;; Whitespace, just skip it.
     ((char-whitespace? c) (lex port))
     ;; The dot is only the one for dotted lists if followed by
     ;; whitespace. Otherwise it is considered part of a number of
     ;; symbol.
     ((and (char=? c #\.)
           (char-whitespace? (peek-char port)))
      (return 'dot #f))
     ;; Continue checking for literal character values.
     (else
      (case c
        ;; A line comment, skip until end-of-line is found.
        ((#\;)
         (let iterate ()
           (let ((cur (read-char port)))
             (if (or (eof-object? cur) (char=? cur #\newline))
                 (lex port)
                 (iterate)))))
        ;; A character literal.
        ((#\?)
         (return 'character (get-character port #f)))
        ;; A literal string. This is mainly a sequence of characters
        ;; just as in the character literals, the only difference is
        ;; that escaped newline and space are to be completely ignored
        ;; and that meta-escapes set bit 7 rather than bit 27.
        ((#\")
         (let iterate ((result-chars '()))
           (let ((cur (read-char port)))
             (case cur
               ((#\")
                (return 'string (list->string (reverse result-chars))))
               ((#\\)
                (let ((escaped (read-char port)))
                  (case escaped
                    ((#\newline #\space)
                     (iterate result-chars))
                    (else
                     (unread-char escaped port)
                     (unread-char cur port)
                     (iterate
                      (cons (integer->char (get-character port #t))
                            result-chars))))))
               (else (iterate (cons cur result-chars)))))))
        ((#\#)
         (let ((c (read-char port)))
          (case c
            ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
             (unread-char c port)
             (let ((mark (get-circular-marker port)))
               (return (car mark) (cdr mark))))
            ((#\')
             (return 'function #f)))))
        ;; Parentheses and other special-meaning single characters.
        ((#\() (return 'paren-open #f))
        ((#\)) (return 'paren-close #f))
        ((#\[) (return 'square-open #f))
        ((#\]) (return 'square-close #f))
        ((#\') (return 'quote #f))
        ((#\`) (return 'backquote #f))
        ;; Unquote and unquote-splicing.
        ((#\,)
         (if (is-char? (peek-char port) #\@)
             (if (not (char=? (read-char port) #\@))
                 (error "expected @ in unquote-splicing")
                 (return 'unquote-splicing #f))
             (return 'unquote #f)))
        ;; Remaining are numbers and symbols. Process input until next
        ;; whitespace is found, and see if it looks like a number
        ;; (float/integer) or symbol and return accordingly.
        (else
         (unread-char c port)
         (call-with-values
             (lambda () (get-symbol-or-number port))
           (lambda (type str)
             (case type
               ((symbol)
                ;; str could be empty if the first character is already
                ;; something not allowed in a symbol (and not escaped)!
                ;; Take care about that, it is an error because that
                ;; character should have been handled elsewhere or is
                ;; invalid in the input.
                (if (zero? (string-length str))
                    (begin
                      ;; Take it out so the REPL might not get into an
                      ;; infinite loop with further reading attempts.
                      (read-char port)
                      (error "invalid character in input" c))
                    (return 'symbol (string->symbol str))))
               ((integer)
                ;; In elisp, something like "1." is an integer, while
                ;; string->number returns an inexact real. Thus we need
                ;; a conversion here, but it should always result in an
                ;; integer!
                (return
                 'integer
                 (let ((num (inexact->exact (string->number str))))
                   (if (not (integer? num))
                       (error "expected integer" str num))
                   num)))
               ((float)
                (return 'float (let ((num (string->number str)))
                                 (if (exact? num)
                                     (error "expected inexact float"
                                            str
                                            num))
                                 num)))
               (else (error "wrong number/symbol type" type)))))))))))

;;; Build a lexer thunk for a port. This is the exported routine which
;;; can be used to create a lexer for the parser to use.

(define (get-lexer port)
  (lambda () (lex port)))

;;; Build a special lexer that will only read enough for one expression
;;; and then always return end-of-input. If we find one of the quotation
;;; stuff, one more expression is needed in any case.

(define (get-lexer/1 port)
  (let ((lex (get-lexer port))
        (finished #f)
        (paren-level 0))
    (lambda ()
      (if finished
          (cons 'eof ((@ (rnrs io ports) eof-object)))
          (let ((next (lex))
                (quotation #f))
            (case (car next)
              ((paren-open square-open)
               (set! paren-level (1+ paren-level)))
              ((paren-close square-close)
               (set! paren-level (1- paren-level)))
              ((quote backquote unquote unquote-splicing circular-def)
               (set! quotation #t)))
            (if (and (not quotation) (<= paren-level 0))
                (set! finished #t))
            next)))))


code:
;;; Guile Emacs Lisp

;;; 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 elisp parser)
  #:use-module (language elisp lexer)
  #:export (read-elisp))

;;; The parser (reader) for elisp expressions. Is is hand-written (just
;;; as the lexer is) instead of using some parser generator because this
;;; allows easier transfer of source properties from the lexer ((text
;;; parse-lalr) seems not to allow access to the original lexer
;;; token-pair) and is easy enough anyways.

;;; Report a parse error. The first argument is some current lexer token
;;; where source information is available should it be useful.

(define (parse-error token msg . args)
  (apply error msg args))

;;; For parsing circular structures, we keep track of definitions in a
;;; hash-map that maps the id's to their values. When defining a new id,
;;; though, we immediatly fill the slot with a promise before parsing
;;; and setting the real value, because it must already be available at
;;; that time in case of a circular reference. The promise refers to a
;;; local variable that will be set when the real value is available
;;; through a closure. After parsing the expression is completed, we
;;; work through it again and force all promises we find. The
;;; definitions themselves are stored in a fluid and their scope is one
;;; call to read-elisp (but not only the currently parsed expression!).

(define circular-definitions (make-fluid))

(define (make-circular-definitions)
  (make-hash-table))

(define (circular-ref token)
  (if (not (eq? (car token) 'circular-ref))
      (error "invalid token for circular-ref" token))
  (let* ((id (cdr token))
         (value (hashq-ref (fluid-ref circular-definitions) id)))
    (if value
        value
        (parse-error token "undefined circular reference" id))))

;;; Returned is a closure that, when invoked, will set the final value.
;;; This means both the variable the promise will return and the
;;; hash-table slot so we don't generate promises any longer.

(define (circular-define! token)
  (if (not (eq? (car token) 'circular-def))
      (error "invalid token for circular-define!" token))
  (let ((value #f)
        (table (fluid-ref circular-definitions))
        (id (cdr token)))
    (hashq-set! table id (delay value))
    (lambda (real-value)
      (set! value real-value)
      (hashq-set! table id real-value))))

;;; Work through a parsed data structure and force the promises there.
;;; After a promise is forced, the resulting value must not be recursed
;;; on; this may lead to infinite recursion with a circular structure,
;;; and additionally this value was already processed when it was
;;; defined. All deep data structures that can be parsed must be handled
;;; here!

(define (force-promises! data)
  (cond
   ((pair? data)
    (begin
      (if (promise? (car data))
          (set-car! data (force (car data)))
          (force-promises! (car data)))
      (if (promise? (cdr data))
          (set-cdr! data (force (cdr data)))
          (force-promises! (cdr data)))))
   ((vector? data)
    (let ((len (vector-length data)))
      (let iterate ((i 0))
        (if (< i len)
            (let ((el (vector-ref data i)))
              (if (promise? el)
                  (vector-set! data i (force el))
                  (force-promises! el))
              (iterate (1+ i)))))))
   ;; Else nothing needs to be done.
   ))

;;; We need peek-functionality for the next lexer token, this is done
;;; with some single token look-ahead storage. This is handled by a
;;; closure which allows getting or peeking the next token. When one
;;; expression is fully parsed, we don't want a look-ahead stored here
;;; because it would miss from future parsing. This is verified by the
;;; finish action.

(define (make-lexer-buffer lex)
  (let ((look-ahead #f))
    (lambda (action)
      (if (eq? action 'finish)
          (if look-ahead
              (error "lexer-buffer is not empty when finished")
              #f)
          (begin
            (if (not look-ahead)
                (set! look-ahead (lex)))
            (case action
              ((peek) look-ahead)
              ((get)
               (let ((result look-ahead))
                 (set! look-ahead #f)
                 result))
              (else (error "invalid lexer-buffer action" action))))))))

;;; Get the contents of a list, where the opening parentheses has
;;; already been found. The same code is used for vectors and lists,
;;; where lists allow the dotted tail syntax and vectors not;
;;; additionally, the closing parenthesis must of course match. The
;;; implementation here is not tail-recursive, but I think it is clearer
;;; and simpler this way.

(define (get-list lex allow-dot close-square)
  (let* ((next (lex 'peek))
         (type (car next)))
    (cond
     ((eq? type (if close-square 'square-close 'paren-close))
      (begin
        (if (not (eq? (car (lex 'get)) type))
            (error "got different token than peeked"))
        '()))
     ((and allow-dot (eq? type 'dot))
      (begin
        (if (not (eq? (car (lex 'get)) type))
            (error "got different token than peeked"))
        (let ((tail (get-list lex #f close-square)))
          (if (not (= (length tail) 1))
              (parse-error next
                           "expected exactly one element after dot"))
          (car tail))))
     (else
      ;; Do both parses in exactly this sequence!
      (let* ((head (get-expression lex))
             (tail (get-list lex allow-dot close-square)))
        (cons head tail))))))

;;; Parse a single expression from a lexer-buffer. This is the main
;;; routine in our recursive-descent parser.

(define quotation-symbols '((quote . quote)
                            (backquote . #{`}#)
                            (unquote . #{,}#)
                            (unquote-splicing . #{,@}#)))

(define (get-expression lex)
  (let* ((token (lex 'get))
         (type (car token))
         (return (lambda (result)
                   (if (pair? result)
                       (set-source-properties!
                        result
                        (source-properties token)))
                   result)))
    (case type
      ((eof)
       (parse-error token "end of file during parsing"))
      ((integer float symbol character string)
       (return (cdr token)))
      ((function)
       (return `(function ,(get-expression lex))))
      ((quote backquote unquote unquote-splicing)
       (return (list (assq-ref quotation-symbols type)
                     (get-expression lex))))
      ((paren-open)
       (return (get-list lex #t #f)))
      ((square-open)
       (return (list->vector (get-list lex #f #t))))
      ((circular-ref)
       (circular-ref token))
      ((circular-def)
       ;; The order of definitions is important!
       (let* ((setter (circular-define! token))
              (expr (get-expression lex)))
         (setter expr)
         (force-promises! expr)
         expr))
      (else
       (parse-error token "expected expression, got" token)))))

;;; Define the reader function based on this; build a lexer, a
;;; lexer-buffer, and then parse a single expression to return. We also
;;; define a circular-definitions data structure to use.

(define (read-elisp port)
  (with-fluids ((circular-definitions (make-circular-definitions)))
    (let* ((lexer (get-lexer port))
           (lexbuf (make-lexer-buffer lexer))
           (next (lexbuf 'peek)))
      (if (eq? (car next) 'eof)
          (cdr next)
          (let ((result (get-expression lexbuf)))
            (lexbuf 'finish)
            result)))))


code:
;;; Guile Emacs Lisp

;;; 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 elisp runtime)
  #:export (nil-value
            t-value
            value-slot-module
            function-slot-module
            elisp-bool
            ensure-fluid!
            reference-variable
            set-variable!
            runtime-error
            macro-error)
  #:export-syntax (built-in-func built-in-macro defspecial prim))

;;; This module provides runtime support for the Elisp front-end.

;;; Values for t and nil. (FIXME remove this abstraction)

(define nil-value #nil)

(define t-value #t)

;;; Modules for the binding slots. Note: Naming those value-slot and/or
;;; function-slot clashes with the submodules of these names!

(define value-slot-module '(language elisp runtime value-slot))

(define function-slot-module '(language elisp runtime function-slot))

;;; Report an error during macro compilation, that means some special
;;; compilation (syntax) error; or report a simple runtime-error from a
;;; built-in function.

(define (macro-error msg . args)
  (apply error msg args))

(define runtime-error macro-error)

;;; Convert a scheme boolean to Elisp.

(define (elisp-bool b)
  (if b
      t-value
      nil-value))

;;; Routines for access to elisp dynamically bound symbols. This is used
;;; for runtime access using functions like symbol-value or set, where
;;; the symbol accessed might not be known at compile-time. These always
;;; access the dynamic binding and can not be used for the lexical!

(define (ensure-fluid! module sym)
  (let ((intf (resolve-interface module))
        (resolved (resolve-module module)))
    (if (not (module-defined? intf sym))
        (let ((fluid (make-undefined-fluid)))
          (module-define! resolved sym fluid)
          (module-export! resolved `(,sym))))))

(define (reference-variable module sym)
  (let ((resolved (resolve-module module)))
   (cond
    ((equal? module function-slot-module)
     (module-ref resolved sym))
    (else
     (ensure-fluid! module sym)
     (fluid-ref (module-ref resolved sym))))))

(define (set-variable! module sym value)
  (let ((intf (resolve-interface module))
        (resolved (resolve-module module)))
    (cond
     ((equal? module function-slot-module)
      (cond
       ((module-defined? intf sym)
        (module-set! resolved sym value))
      (else
       (module-define! resolved sym value)
       (module-export! resolved `(,sym)))))
    (else
     (ensure-fluid! module sym)
     (fluid-set! (module-ref resolved sym) value))))
  value)

;;; Define a predefined function or predefined macro for use in the
;;; function-slot and macro-slot modules, respectively.

(define-syntax built-in-func
  (syntax-rules ()
    ((_ name value)
     (begin
       (define-public name value)))))

(define (make-id template-id . data)
  (let ((append-symbols
         (lambda (symbols)
           (string->symbol
            (apply string-append (map symbol->string symbols))))))
    (datum->syntax template-id
                   (append-symbols
                    (map (lambda (datum)
                           ((if (identifier? datum)
                                syntax->datum
                                identity)
                            datum))
                         data)))))

(define-syntax built-in-macro
  (lambda (x)
    (syntax-case x ()
      ((_ name value)
       (with-syntax ((scheme-name (make-id #'name 'macro- #'name)))
        #'(begin
            (define-public scheme-name (make-fluid))
            (fluid-set! scheme-name (cons 'macro value))))))))

(define-syntax defspecial
  (lambda (x)
    (syntax-case x ()
      ((_ name args body ...)
       (with-syntax ((scheme-name (make-id #'name 'compile- #'name)))
         #'(begin
             (define scheme-name (make-fluid))
             (fluid-set! scheme-name
                         (cons 'special-operator
                               (lambda args body ...)))))))))

;;; Call a guile-primitive that may be rebound for elisp and thus needs
;;; absolute addressing.

(define-syntax prim
  (syntax-rules ()
    ((_ sym args ...)
     ((@ (guile) sym) args ...))))


code:
;;; Guile Emacs Lisp

;;; Copyright (C) 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

(define-module (language elisp runtime function-slot)
  #:use-module (language elisp runtime subrs)
  #:use-module ((language elisp runtime macros)
                #:select
                ((macro-lambda . lambda)
                 (macro-prog1 . prog1)
                 (macro-prog2 . prog2)
                 (macro-when . when)
                 (macro-unless . unless)
                 (macro-cond . cond)
                 (macro-and . and)
                 (macro-or . or)
                 (macro-dotimes . dotimes)
                 (macro-dolist . dolist)
                 (macro-catch . catch)
                 (macro-unwind-protect . unwind-protect)
                 (macro-pop . pop)
                 (macro-push . push)))
  #:use-module ((language elisp compile-tree-il)
                #:select
                ((compile-progn . progn)
                 (compile-if . if)
                 (compile-defconst . defconst)
                 (compile-defvar . defvar)
                 (compile-setq . setq)
                 (compile-let . let)
                 (compile-lexical-let . lexical-let)
                 (compile-flet . flet)
                 (compile-let* . let*)
                 (compile-lexical-let* . lexical-let*)
                 (compile-flet* . flet*)
                 (compile-with-always-lexical . with-always-lexical)
                 (compile-guile-ref . guile-ref)
                 (compile-guile-primitive . guile-primitive)
                 (compile-while . while)
                 (compile-function . function)
                 (compile-defun . defun)
                 (compile-defmacro . defmacro)
                 (#{compile-`}# . #{`}#)
                 (compile-quote . quote)))
  #:duplicates (last)
  ;; special operators
  #:re-export (progn
               if
               defconst
               defvar
               setq
               let
               lexical-let
               flet
               let*
               lexical-let*
               flet*
               with-always-lexical
               guile-ref
               guile-primitive
               while
               function
               defun
               defmacro
               #{`}#
               quote)
  ;; macros
  #:re-export (lambda
               prog1
               prog2
               when
               unless
               cond
               and
               or
               dotimes
               dolist
               catch
               unwind-protect
               pop
               push)
  ;; functions
  #:re-export (eq
               equal
               floatp
               integerp
               numberp
               wholenump
               zerop
               =
               /=
               <
               <=
               >
               >=
               max
               min
               abs
               float
               1+
               1-
               +
               -
               *
               %
               ffloor
               fceiling
               ftruncate
               fround
               consp
               atomp
               listp
               nlistp
               null
               car
               cdr
               car-safe
               cdr-safe
               nth
               nthcdr
               length
               cons
               list
               make-list
               append
               reverse
               copy-tree
               number-sequence
               setcar
               setcdr
               symbol-value
               symbol-function
               set
               fset
               makunbound
               fmakunbound
               boundp
               fboundp
               apply
               funcall
               throw
               not
               eval
               load))