;;; Guile Emacs Lisp
-;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 2013 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
#:use-module (srfi srfi-8)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
+ #:use-module (ice-9 format)
#:export (compile-tree-il
compile-progn
compile-eval-when-compile
compile-labels
compile-let*
compile-guile-ref
+ compile-guile-private-ref
compile-guile-primitive
+ compile-%function
compile-function
compile-defmacro
compile-defun
(define bindings-data (make-fluid))
-(define lexical-binding (make-fluid))
-
;;; Find the source properties of some parsed expression if there are
;;; any associated with it.
loc
symbol
(lambda (lexical)
- (make-lexical-ref loc lexical lexical))
+ (if (symbol? lexical)
+ (make-lexical-ref loc symbol lexical)
+ (make-call loc lexical '())))
(lambda ()
- (call-primitive loc
- 'fluid-ref
- (make-module-ref loc value-slot symbol #t)))))
+ (make-call loc
+ (make-module-ref loc runtime 'symbol-value #t)
+ (list (make-const loc symbol))))))
-(define (global? module symbol)
- (module-variable module symbol))
+(define (global? symbol)
+ (module-variable value-slot symbol))
(define (ensure-globals! loc names body)
- (if (and (every (cut global? (resolve-module value-slot) <>) names)
+ (if (and (every global? names)
(every symbol-interned? names))
body
(list->seq
loc
`(,@(map
(lambda (name)
- (ensure-fluid! value-slot name)
+ (symbol-desc name)
(make-call loc
- (make-module-ref loc runtime 'ensure-fluid! #t)
- (list (make-const loc value-slot)
- (make-const loc name))))
+ (make-module-ref loc runtime 'symbol-desc #t)
+ (list (make-const loc name))))
names)
,body))))
loc
symbol
(lambda (lexical)
- (make-lexical-set loc lexical lexical value))
+ (if (symbol? lexical)
+ (make-lexical-set loc symbol lexical value)
+ (make-call loc lexical (list value))))
(lambda ()
(ensure-globals!
loc
(list symbol)
- (call-primitive loc
- 'fluid-set!
- (make-module-ref loc value-slot symbol #t)
- value)))))
+ (make-call loc
+ (make-module-ref loc runtime 'set-symbol-value! #t)
+ (list (make-const loc symbol)
+ value))))))
(define (access-function loc symbol handle-lexical handle-global)
(cond
loc
symbol
(lambda (gensym) (make-lexical-ref loc symbol gensym))
- (lambda () (make-module-ref loc function-slot symbol #t))))
+ (lambda ()
+ (make-module-ref loc '(elisp-functions) symbol #t))))
(define (set-function! loc symbol value)
(access-function
(make-module-ref loc runtime 'set-symbol-function! #t)
(list (make-const loc symbol) value)))))
-(define (bind-lexically? sym module decls)
- (or (eq? module function-slot)
- (let ((decl (assq-ref decls sym)))
- (and (equal? module value-slot)
- (or
- (eq? decl 'lexical)
- (and
- (fluid-ref lexical-binding)
- (not (global? (resolve-module module) sym))))))))
+(define (bind-lexically? sym decls)
+ (let ((decl (assq-ref decls sym)))
+ (or (eq? decl 'lexical)
+ (and
+ (lexical-binding?)
+ (not (special? sym))))))
(define (parse-let-binding loc binding)
(pmatch binding
(pmatch lst
(((declare . ,x) . ,tail)
(loop tail (append-reverse x decls) intspec doc))
- (((interactive . ,x) . ,tail)
+ (((interactive) . ,tail)
(guard lambda? (not intspec))
- (loop tail decls x doc))
+ (loop tail decls (cons 'interactive-form #nil) doc))
+ (((interactive ,x) . ,tail)
+ (guard lambda? (not intspec))
+ (loop tail decls (cons 'interactive-form x) doc))
((,x . ,tail)
- (guard lambda? (string? x) (not doc) (not (null? tail)))
+ (guard lambda? (or (string? x) (lisp-string? x)) (not doc) (not (null? tail)))
(loop tail decls intspec x))
(else
(values (append-map parse-declaration decls)
;;; optional and rest arguments.
(define (parse-lambda-list lst)
- (define (%match lst null optional rest symbol)
+ (define (%match lst null optional rest symbol list*)
(pmatch lst
(() (null))
((&optional . ,tail) (optional tail))
((&rest . ,tail) (rest tail))
((,arg . ,tail) (guard (symbol? arg)) (symbol arg tail))
+ ((,arg . ,tail) (guard (list? arg)) (list* arg tail))
(else (fail))))
(define (return rreq ropt rest)
(values #t (reverse rreq) (reverse ropt) rest))
(lambda () (return rreq '() #f))
(lambda (tail) (parse-opt tail rreq '()))
(lambda (tail) (parse-rest tail rreq '()))
- (lambda (arg tail) (parse-req tail (cons arg rreq)))))
+ (lambda (arg tail) (parse-req tail (cons arg rreq)))
+ (lambda (arg tail) (fail))))
(define (parse-opt lst rreq ropt)
(%match lst
(lambda () (return rreq ropt #f))
(lambda (tail) (fail))
(lambda (tail) (parse-rest tail rreq ropt))
+ (lambda (arg tail) (parse-opt tail rreq (cons (list arg) ropt)))
(lambda (arg tail) (parse-opt tail rreq (cons arg ropt)))))
(define (parse-rest lst rreq ropt)
(%match lst
(lambda () (fail))
(lambda (tail) (fail))
(lambda (tail) (fail))
- (lambda (arg tail) (parse-post-rest tail rreq ropt arg))))
+ (lambda (arg tail) (parse-post-rest tail rreq ropt arg))
+ (lambda (arg tail) (fail))))
(define (parse-post-rest lst rreq ropt rest)
(%match lst
(lambda () (return rreq ropt rest))
(lambda () (fail))
(lambda () (fail))
+ (lambda (arg tail) (fail))
(lambda (arg tail) (fail))))
(parse-req lst '()))
meta
(make-lambda-case #f req opt rest #f init vars body #f)))
+(define (make-dynlet src fluids vals body)
+ (let ((f (map (lambda (x) (gensym "fluid ")) fluids))
+ (v (map (lambda (x) (gensym "valud ")) vals)))
+ (make-let src (map (lambda (_) 'fluid) fluids) f fluids
+ (make-let src (map (lambda (_) 'val) vals) v vals
+ (let lp ((f f) (v v))
+ (if (null? f)
+ body
+ (make-call src
+ (make-module-ref src runtime 'bind-symbol #t)
+ (list (make-lexical-ref #f 'fluid (car f))
+ (make-lexical-ref #f 'val (car v))
+ (make-lambda
+ src '()
+ (make-lambda-case
+ src '() #f #f #f '() '()
+ (lp (cdr f) (cdr v))
+ #f))))))))))
+
(define (compile-lambda loc meta args body)
- (receive (valid? req-ids opt-ids rest-id)
+ (receive (valid? req-ids opts rest-id)
(parse-lambda-list args)
(if valid?
(let* ((all-ids (append req-ids
- opt-ids
+ (and opts (map car opts))
(or (and=> rest-id list) '())))
(all-vars (map (lambda (ignore) (gensym)) all-ids)))
(let*-values (((decls intspec doc forms)
(parse-lambda-body body))
((lexical dynamic)
(partition
- (compose (cut bind-lexically? <> value-slot decls)
+ (compose (cut bind-lexically? <> decls)
car)
(map list all-ids all-vars)))
((lexical-ids lexical-vars) (unzip2 lexical))
tree-il
(make-dynlet
loc
- (map (cut make-module-ref loc value-slot <> #t)
- dynamic-ids)
+ (map (cut make-const loc <>) dynamic-ids)
(map (cut make-lexical-ref loc <> <>)
dynamic-ids
dynamic-vars)
tree-il))))
(make-simple-lambda loc
- meta
+ (append (if intspec
+ (list intspec)
+ '())
+ (if doc
+ (list (cons 'emacs-documentation doc))
+ '())
+ meta)
req-ids
- opt-ids
- (map (const (nil-value loc))
- opt-ids)
+ (map car opts)
+ (map (lambda (x)
+ (if (pair? (cdr x))
+ (compile-expr (car (cdr x)))
+ (make-const loc #nil)))
+ opts)
rest-id
all-vars
full-body)))))))))
(report-error "invalid function" `(lambda ,args ,@body)))))
-;;; 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 name type)
(and
(symbol? name)
- (module-defined? (resolve-interface function-slot) name)
- (let ((op (module-ref (resolve-module function-slot) name)))
+ (module-defined? function-slot name)
+ (let ((op (module-ref function-slot name)))
(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)))
(list->seq loc
(if (null? args)
(list (nil-value loc))
- (map compile-expr args))))
+ (map compile-expr-1 args))))
(defspecial eval-when-compile (loc args)
(make-const loc (compile `(progn ,@args) #:from 'elisp #:to 'value)))
+(define toplevel? (make-fluid))
+
+(define compile-time-too? (make-fluid))
+
+(defspecial eval-when (loc args)
+ (pmatch args
+ ((,situations . ,forms)
+ (let ((compile? (memq ':compile-toplevel situations))
+ (load? (memq ':load-toplevel situations))
+ (execute? (memq ':execute situations)))
+ (cond
+ ((not (fluid-ref toplevel?))
+ (if execute?
+ (compile-expr `(progn ,@forms))
+ (make-const loc #nil)))
+ (load?
+ (with-fluids ((compile-time-too?
+ (cond (compile? #t)
+ (execute? (fluid-ref compile-time-too?))
+ (else #f))))
+ (when (fluid-ref compile-time-too?)
+ (eval-elisp `(progn ,@forms)))
+ (compile-expr-1 `(progn ,@forms))))
+ ((or compile? (and execute? (fluid-ref compile-time-too?)))
+ (eval-elisp `(progn ,@forms))
+ (make-const loc #nil))
+ (else
+ (make-const loc #nil)))))))
+
(defspecial if (loc args)
(pmatch args
((,cond ,then . ,else)
(call-primitive loc 'not
(call-primitive loc 'nil? (compile-expr cond)))
(compile-expr then)
- (compile-expr `(progn ,@else))))))
+ (compile-expr `(progn ,@else))))
+ (else (report-error loc "Bad if" args))))
(defspecial defconst (loc args)
(pmatch args
((,sym ,value . ,doc)
- (if (handle-var-def loc sym doc)
- (make-seq loc
- (set-variable! loc sym (compile-expr value))
- (make-const loc sym))))))
+ (proclaim-special! sym)
+ (make-seq
+ loc
+ (make-call loc
+ (make-module-ref loc runtime 'proclaim-special! #t)
+ (list (make-const loc sym)))
+ (make-seq loc
+ (set-variable! loc sym (compile-expr value))
+ (make-const loc sym))))
+ (else (report-error loc "Bad defconst" args))))
(defspecial defvar (loc args)
(pmatch args
- ((,sym) (make-const loc sym))
+ ((,sym)
+ (proclaim-special! sym)
+ (make-seq loc
+ (make-call loc
+ (make-module-ref loc runtime 'proclaim-special! #t)
+ (list (make-const loc sym)))
+ (make-const loc sym)))
((,sym ,value . ,doc)
- (if (handle-var-def loc sym doc)
- (make-seq
- loc
- (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 (compile-expr value)))
- (make-const loc sym))))))
+ (proclaim-special! sym)
+ (make-seq
+ loc
+ (make-call loc
+ (make-module-ref loc runtime 'proclaim-special! #t)
+ (list (make-const loc sym)))
+ (make-seq
+ loc
+ (make-conditional
+ loc
+ (make-call loc
+ (make-module-ref loc runtime 'symbol-default-bound? #t)
+ (list (make-const loc sym)))
+ (make-void loc)
+ (make-call loc
+ (make-module-ref loc runtime 'set-symbol-default-value! #t)
+ (list (make-const loc sym)
+ (compile-expr value))))
+ (make-const loc sym))))
+ (else (report-error loc "Bad defvar" args))))
(defspecial setq (loc args)
(define (car* x) (if (null? x) '() (car x)))
(let ((sym (car args))
(val (compile-expr (cadr* args))))
(if (not (symbol? sym))
- (report-error loc "expected symbol in setq")
+ (report-error loc "expected symbol in setq" args)
(cons
(set-variable! loc sym val)
(loop (cddr* args)
(receive (decls forms) (parse-body body)
(receive (lexical dynamic)
(partition
- (compose (cut bind-lexically? <> value-slot decls)
+ (compose (cut bind-lexically? <> decls)
car)
bindings)
(let ((make-values (lambda (for)
loc
(map car dynamic)
(if (null? lexical)
- (make-dynlet loc
- (map (compose (cut make-module-ref
- loc
- value-slot
- <>
- #t)
- car)
- dynamic)
- (map (compose compile-expr cdr)
- dynamic)
- (make-body))
+ (if (null? dynamic)
+ (make-body)
+ (make-dynlet loc
+ (map (compose (cut make-const loc <>) car)
+ dynamic)
+ (map (compose compile-expr cdr)
+ 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))
(make-body)
(make-dynlet loc
(map
- (compose
- (cut make-module-ref
- loc
- value-slot
- <>
- #t)
- car)
+ (compose (cut make-const
+ loc
+ <>)
+ car)
dynamic)
(map
(lambda (sym)
sym
sym))
dynamic-syms)
- (make-body))))))))))))))))
+ (make-body))))))))))))))
+ (else (report-error loc "bad let args"))))
(defspecial let* (loc args)
(pmatch args
(compile-expr `(progn ,@forms))
(let ((sym (caar tail))
(value (compile-expr (cdar tail))))
- (if (bind-lexically? sym value-slot decls)
+ (if (bind-lexically? sym decls)
(let ((target (gensym)))
(make-let loc
`(,target)
loc
(list sym)
(make-dynlet loc
- (list (make-module-ref loc value-slot sym #t))
+ (list (make-const loc sym))
(list value)
- (iterate (cdr tail)))))))))))))
+ (iterate (cdr tail)))))))))))
+ (else (report-error loc "Bad let*" args))))
(defspecial flet (loc args)
(pmatch args
names
gensyms
(map compile-expr vals)
- (compile-expr `(progn ,@forms)))))))))))
+ (compile-expr `(progn ,@forms)))))))))
+ (else (report-error loc "bad flet" args))))
(defspecial labels (loc args)
(pmatch args
names
gensyms
(map compile-expr vals)
- (compile-expr `(progn ,@forms)))))))))))
+ (compile-expr `(progn ,@forms)))))))))
+ (else (report-error loc "bad labels" args))))
;;; guile-ref allows building TreeIL's module references from within
;;; elisp as a way to access data within the Guile universe. The module
(defspecial guile-ref (loc args)
(pmatch args
((,module ,sym) (guard (and (list? module) (symbol? sym)))
- (make-module-ref loc module sym #t))))
+ (make-module-ref loc module sym #t))
+ (else (report-error loc "bad guile-ref" args))))
+
+(defspecial guile-private-ref (loc args)
+ (pmatch args
+ ((,module ,sym) (guard (and (list? module) (symbol? sym)))
+ (make-module-ref loc module sym #f))
+ (else (report-error loc "bad guile-private-ref" args))))
;;; 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))))
+ (make-primitive-ref loc sym))
+ (else (report-error loc "bad guile-primitive" args))))
-(defspecial function (loc args)
+(defspecial %function (loc args)
(pmatch args
(((lambda ,args . ,body))
(compile-lambda loc '() args body))
+ (((closure ,env ,args . ,body))
+ (let ((bindings (map (lambda (x) (list (car x) (cdr x)))
+ (filter pair? env))))
+ (compile-expr
+ (let ((form `(let ,bindings
+ (declare ,@(map (lambda (x) (list 'lexical x))
+ bindings))
+ (function (lambda ,args
+ (declare
+ (lexical
+ ,@(filter-map
+ (lambda (x)
+ (cond
+ ((memq x '(&optional &rest))
+ #f)
+ ((symbol? x)
+ x)
+ ((list? x)
+ (car x))))
+ args)))
+ ,@body)))))
+ form))))
((,sym) (guard (symbol? sym))
- (reference-function loc sym))))
+ (reference-function loc sym))
+ ((,x)
+ (make-const loc x))
+ (else (report-error loc "bad function" args))))
+
+(defspecial function (loc args)
+ (pmatch args
+ ((,sym) (guard (symbol? sym))
+ (make-const loc sym))
+ (else ((cdr compile-%function) loc args))))
(defspecial defmacro (loc args)
(pmatch args
body))))
(make-const loc name))))
(compile 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-seq loc
- (set-function! loc
- name
- (compile-lambda loc
- `((name . ,name))
- args
- body))
- (make-const loc name))))))
+ tree-il)))
+ (else (report-error loc "bad defmacro" args))))
(defspecial #{`}# (loc args)
(pmatch args
((,val)
- (process-backquote loc val))))
+ (process-backquote loc val))
+ (else (report-error loc "bad backquote" args))))
(defspecial quote (loc args)
(pmatch args
((,val)
- (make-const loc val))))
+ (make-const loc val))
+ (else (report-error loc "bad quote" args))))
(defspecial %funcall (loc args)
(pmatch args
((,function . ,arguments)
(make-call loc
(compile-expr function)
- (map compile-expr arguments)))))
+ (map compile-expr arguments)))
+ (else (report-error loc "bad %funcall" args))))
(defspecial %set-lexical-binding-mode (loc args)
(pmatch args
((,val)
- (fluid-set! lexical-binding val)
- (make-void loc))))
+ (set-lexical-binding-mode val)
+ (make-void loc))
+ (else (report-error loc "bad %set-lexical-binding-mode" args))))
+
+(define (eget s p)
+ (if (symbol-fbound? 'get)
+ ((symbol-function 'get) s p)
+ #nil))
;;; Compile a compound expression to Tree-IL.
((find-operator operator 'macro)
=> (lambda (macro-function)
(compile-expr (apply macro-function arguments))))
+ ((and (symbol? operator)
+ (eget operator '%compiler-macro))
+ => (lambda (compiler-macro-function)
+ (let ((new (compiler-macro-function expr)))
+ (if (eq? new expr)
+ (compile-expr `(%funcall (%function ,operator) ,@arguments))
+ (compile-expr new)))))
(else
- (compile-expr `(%funcall (function ,operator) ,@arguments))))))
+ (compile-expr `(%funcall (%function ,operator) ,@arguments))))))
;;; Compile a symbol expression. This is a variable reference or maybe
;;; some special value like nil.
;;; Compile a single expression to TreeIL.
-(define (compile-expr expr)
+(define (compile-expr-1 expr)
(let ((loc (location expr)))
(cond
((symbol? 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)
- (else (report-error #f
- "Invalid compiler option"
- key)))))))
+(define (compile-expr expr)
+ (if (fluid-ref toplevel?)
+ (with-fluids ((toplevel? #f))
+ (compile-expr-1 expr))
+ (compile-expr-1 expr)))
(define (compile-tree-il expr env opts)
(values
- (with-fluids ((bindings-data (make-bindings)))
- (process-options! opts)
- (compile-expr expr))
+ (with-fluids ((bindings-data (make-bindings))
+ (toplevel? #t)
+ (compile-time-too? #f))
+ (compile-expr-1 expr))
env
env))
HCoop / bpt / guile.git / blobdiff