mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-15 10:10:21 +02:00
cd702346f2
* module/language/scheme/translate.scm (primitive-syntax-table): Translate the `else' clause of a cond as (begin ...). We used to use trans-body, which processes internal defines, which are not legal syntax here. * module/system/base/syntax.scm (define-record): Unfortunately, we can't unquote in the actual procedure for `%compute-initargs', because that doesn't work with compilation. So reference %compute-initargs by name, and export it. * module/system/il/ghil.scm (apopq!): Gaaaaar. The order of the arguments to assq-remove! was reversed, which was the badness, causing corruption to the env after calling call-with-ghil-bindings. Grrrrrr. (fix-ghil-mod!, ghil-lookup, ghil-define): As amply commented in the code, deal with compile-time side effects to the current module by lazily noticing and patching up the compile-time environment. A hacky solution until such a time as we special-case something for `define-module'.
330 lines
11 KiB
Scheme
330 lines
11 KiB
Scheme
;;; Guile Scheme specification
|
||
|
||
;; Copyright (C) 2001 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 2, 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 scheme translate)
|
||
:use-module (system base pmatch)
|
||
:use-module (system base language)
|
||
:use-module (system il ghil)
|
||
:use-module (ice-9 receive)
|
||
:use-module (srfi srfi-39)
|
||
:use-module ((system base compile) :select (syntax-error))
|
||
:export (translate))
|
||
|
||
|
||
(define (translate x e)
|
||
(call-with-ghil-environment (make-ghil-mod e) '()
|
||
(lambda (env vars)
|
||
(make-ghil-lambda env #f vars #f (trans env #f x)))))
|
||
|
||
|
||
;;;
|
||
;;; Translator
|
||
;;;
|
||
|
||
(define %scheme-primitives
|
||
'(not null? eq? eqv? equal? pair? list? cons car cdr set-car! set-cdr!))
|
||
|
||
(define %forbidden-primitives
|
||
;; Guile's `procedure->macro' family is evil because it crosses the
|
||
;; compilation boundary. One solution might be to evaluate calls to
|
||
;; `procedure->memoizing-macro' at compilation time, but it may be more
|
||
;; compicated than that.
|
||
'(procedure->syntax procedure->macro procedure->memoizing-macro))
|
||
|
||
(define (lookup-transformer e head retrans)
|
||
(let ((val (and=> (module-variable (ghil-mod-module (ghil-env-mod e)) head)
|
||
variable-ref)))
|
||
(cond
|
||
((or (primitive-macro? val) (eq? val eval-case))
|
||
(or (assq-ref primitive-syntax-table head)
|
||
(syntax-error #f "unhandled primitive macro" head)))
|
||
|
||
((defmacro? val)
|
||
(lambda (env loc exp)
|
||
(retrans (apply (defmacro-transformer val) (cdr exp)))))
|
||
|
||
((macro? val)
|
||
(syntax-error #f "unknown kind of macro" head))
|
||
|
||
(else #f))))
|
||
|
||
(define (trans e l x)
|
||
(define (retrans x) (trans e l x))
|
||
(cond ((pair? x)
|
||
(let ((head (car x)) (tail (cdr x)))
|
||
(cond
|
||
((lookup-transformer e head retrans)
|
||
=> (lambda (t) (t e l x)))
|
||
|
||
;; FIXME: lexical/module overrides of scheme primitives
|
||
((memq head %scheme-primitives)
|
||
(make-ghil-inline e l head (map retrans tail)))
|
||
|
||
;; FIXME: lexical/module overrides of forbidden primitives
|
||
((memq head %forbidden-primitives)
|
||
(syntax-error l (format #f "`~a' is forbidden" head)
|
||
(cons head tail)))
|
||
(else
|
||
(make-ghil-call e l (retrans head) (map retrans tail))))))
|
||
|
||
((symbol? x)
|
||
(make-ghil-ref e l (ghil-lookup e x)))
|
||
|
||
;; fixme: non-self-quoting objects like #<foo>
|
||
(else
|
||
(make-ghil-quote e l #:obj x))))
|
||
|
||
(define (valid-bindings? bindings . it-is-for-do)
|
||
(define (valid-binding? b)
|
||
(pmatch b
|
||
((,sym ,var) (guard (symbol? sym)) #t)
|
||
((,sym ,var ,update) (guard (pair? it-is-for-do) (symbol? sym)) #t)
|
||
(else #f)))
|
||
(and (list? bindings) (and-map valid-binding? bindings)))
|
||
|
||
(define-macro (make-pmatch-transformers env loc retranslate . body)
|
||
(define exp (gensym))
|
||
(define (make1 clause)
|
||
(let ((sym (car clause))
|
||
(clauses (cdr clause)))
|
||
`(cons ',sym
|
||
(lambda (,env ,loc ,exp)
|
||
(define (,retranslate x) (trans ,env ,loc x))
|
||
(pmatch (cdr ,exp)
|
||
,@clauses
|
||
(else (syntax-error ,loc (format #f "bad ~A" ',sym) ,exp)))))))
|
||
`(list ,@(map make1 body)))
|
||
|
||
(define *the-compile-toplevel-symbol* 'load-toplevel)
|
||
|
||
(define primitive-syntax-table
|
||
(make-pmatch-transformers
|
||
e l retrans
|
||
(quote
|
||
;; (quote OBJ)
|
||
((,obj) (make-ghil-quote e l obj)))
|
||
|
||
(quasiquote
|
||
;; (quasiquote OBJ)
|
||
((,obj) (make-ghil-quasiquote e l (trans-quasiquote e l obj))))
|
||
|
||
(define
|
||
;; (define NAME VAL)
|
||
((,name ,val) (guard (symbol? name) (ghil-env-toplevel? e))
|
||
(make-ghil-define e l (ghil-define (ghil-env-parent e) name)
|
||
(retrans val)))
|
||
;; (define (NAME FORMALS...) BODY...)
|
||
(((,name . ,formals) . ,body) (guard (symbol? name))
|
||
;; -> (define NAME (lambda FORMALS BODY...))
|
||
(retrans `(define ,name (lambda ,formals ,@body)))))
|
||
|
||
(set!
|
||
;; (set! NAME VAL)
|
||
((,name ,val) (guard (symbol? name))
|
||
(make-ghil-set e l (ghil-lookup e name) (retrans val)))
|
||
|
||
;; (set! (NAME ARGS...) VAL)
|
||
(((,name . ,args) ,val) (guard (symbol? name))
|
||
;; -> ((setter NAME) ARGS... VAL)
|
||
(retrans `((setter ,name) . (,@args ,val)))))
|
||
|
||
(if
|
||
;; (if TEST THEN [ELSE])
|
||
((,test ,then)
|
||
(make-ghil-if e l (retrans test) (retrans then) (retrans '(begin))))
|
||
((,test ,then ,else)
|
||
(make-ghil-if e l (retrans test) (retrans then) (retrans else))))
|
||
|
||
(and
|
||
;; (and EXPS...)
|
||
(,tail (make-ghil-and e l (map retrans tail))))
|
||
|
||
(or
|
||
;; (or EXPS...)
|
||
(,tail (make-ghil-or e l (map retrans tail))))
|
||
|
||
(begin
|
||
;; (begin EXPS...)
|
||
(,tail (make-ghil-begin e l (map retrans tail))))
|
||
|
||
(let
|
||
;; (let NAME ((SYM VAL) ...) BODY...)
|
||
((,name ,bindings . ,body) (guard (symbol? name)
|
||
(valid-bindings? bindings))
|
||
;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...))
|
||
(retrans `(letrec ((,name (lambda ,(map car bindings) ,@body)))
|
||
(,name ,@(map cadr bindings)))))
|
||
|
||
;; (let () BODY...)
|
||
((() . ,body)
|
||
;; Note: this differs from `begin'
|
||
(make-ghil-begin e l (list (trans-body e l body))))
|
||
|
||
;; (let ((SYM VAL) ...) BODY...)
|
||
((,bindings . ,body) (guard (valid-bindings? bindings))
|
||
(let ((vals (map retrans (map cadr bindings))))
|
||
(call-with-ghil-bindings e (map car bindings)
|
||
(lambda (vars)
|
||
(make-ghil-bind e l vars vals (trans-body e l body)))))))
|
||
|
||
(let*
|
||
;; (let* ((SYM VAL) ...) BODY...)
|
||
((() . ,body)
|
||
(retrans `(let () ,@body)))
|
||
((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym))
|
||
(retrans `(let ((,sym ,val)) (let* ,rest ,@body)))))
|
||
|
||
(letrec
|
||
;; (letrec ((SYM VAL) ...) BODY...)
|
||
((,bindings . ,body) (guard (valid-bindings? bindings))
|
||
(call-with-ghil-bindings e (map car bindings)
|
||
(lambda (vars)
|
||
(let ((vals (map retrans (map cadr bindings))))
|
||
(make-ghil-bind e l vars vals (trans-body e l body)))))))
|
||
|
||
(cond
|
||
;; (cond (CLAUSE BODY...) ...)
|
||
(() (retrans '(begin)))
|
||
(((else . ,body)) (retrans `(begin ,@body)))
|
||
(((,test) . ,rest) (retrans `(or ,test (cond ,@rest))))
|
||
(((,test => ,proc) . ,rest)
|
||
;; FIXME hygiene!
|
||
(retrans `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest)))))
|
||
(((,test . ,body) . ,rest)
|
||
(retrans `(if ,test (begin ,@body) (cond ,@rest)))))
|
||
|
||
(case
|
||
;; (case EXP ((KEY...) BODY...) ...)
|
||
((,exp . ,clauses)
|
||
(retrans
|
||
;; FIXME hygiene!
|
||
`(let ((_t ,exp))
|
||
,(let loop ((ls clauses))
|
||
(cond ((null? ls) '(begin))
|
||
((eq? (caar ls) 'else) `(begin ,@(cdar ls)))
|
||
(else `(if (memv _t ',(caar ls))
|
||
(begin ,@(cdar ls))
|
||
,(loop (cdr ls))))))))))
|
||
|
||
(do
|
||
;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...)
|
||
((,bindings (,test . ,result) . ,body)
|
||
(let ((sym (map car bindings))
|
||
(val (map cadr bindings))
|
||
(update (map cddr bindings)))
|
||
(define (next s x) (if (pair? x) (car x) s))
|
||
(retrans
|
||
;; FIXME hygiene!
|
||
`(letrec ((_l (lambda ,sym
|
||
(if ,test
|
||
(begin ,@result)
|
||
(begin ,@body
|
||
(_l ,@(map next sym update)))))))
|
||
(_l ,@val))))))
|
||
|
||
(lambda
|
||
;; (lambda FORMALS BODY...)
|
||
((,formals . ,body)
|
||
(receive (syms rest) (parse-formals formals)
|
||
(call-with-ghil-environment e syms
|
||
(lambda (env vars)
|
||
(make-ghil-lambda env l vars rest (trans-body env l body)))))))
|
||
|
||
(eval-case
|
||
(,clauses
|
||
(retrans
|
||
`(begin
|
||
,@(let ((toplevel? (ghil-env-toplevel? e)))
|
||
(let loop ((seen '()) (in clauses) (runtime '()))
|
||
(cond
|
||
((null? in) runtime)
|
||
(else
|
||
(pmatch (car in)
|
||
((else . ,body)
|
||
(if (and toplevel? (not (memq *the-compile-toplevel-symbol* seen)))
|
||
(primitive-eval `(begin ,@body)))
|
||
(if (memq (if toplevel? *the-compile-toplevel-symbol* 'evaluate) seen)
|
||
runtime
|
||
body))
|
||
((,keys . ,body) (guard (list? keys) (and-map symbol? keys))
|
||
(for-each (lambda (k)
|
||
(if (memq k seen)
|
||
(syntax-error l "eval-case condition seen twice" k)))
|
||
keys)
|
||
(if (and toplevel? (memq *the-compile-toplevel-symbol* keys))
|
||
(primitive-eval `(begin ,@body)))
|
||
(loop (append keys seen)
|
||
(cdr in)
|
||
(if (memq (if toplevel? 'load-toplevel 'evaluate) keys)
|
||
(append runtime body)
|
||
runtime)))
|
||
(else (syntax-error l "bad eval-case clause" (car in))))))))))))))
|
||
|
||
(define (trans-quasiquote e l x)
|
||
(cond ((not (pair? x)) x)
|
||
((memq (car x) '(unquote unquote-splicing))
|
||
(let ((l (location x)))
|
||
(pmatch (cdr x)
|
||
((,obj)
|
||
(if (eq? (car x) 'unquote)
|
||
(make-ghil-unquote e l (trans e l obj))
|
||
(make-ghil-unquote-splicing e l (trans e l obj))))
|
||
(else (syntax-error l (format #f "bad ~A" (car x)) x)))))
|
||
(else (cons (trans-quasiquote e l (car x))
|
||
(trans-quasiquote e l (cdr x))))))
|
||
|
||
(define (trans-body e l body)
|
||
(define (define->binding df)
|
||
(pmatch (cdr df)
|
||
((,name ,val) (guard (symbol? name)) (list name val))
|
||
(((,name . ,formals) . ,body) (guard (symbol? name))
|
||
(list name `(lambda ,formals ,@body)))
|
||
(else (syntax-error (location df) "bad define" df))))
|
||
;; main
|
||
(let loop ((ls body) (ds '()))
|
||
(pmatch ls
|
||
(() (syntax-error l "bad body" body))
|
||
(((define . _) . _)
|
||
(loop (cdr ls) (cons (car ls) ds)))
|
||
(else
|
||
(if (null? ds)
|
||
(trans e l `(begin ,@ls))
|
||
(trans e l `(letrec ,(map define->binding ds) ,@ls)))))))
|
||
|
||
(define (parse-formals formals)
|
||
(cond
|
||
;; (lambda x ...)
|
||
((symbol? formals) (values (list formals) #t))
|
||
;; (lambda (x y z) ...)
|
||
((list? formals) (values formals #f))
|
||
;; (lambda (x y . z) ...)
|
||
((pair? formals)
|
||
(let loop ((l formals) (v '()))
|
||
(if (pair? l)
|
||
(loop (cdr l) (cons (car l) v))
|
||
(values (reverse! (cons l v)) #t))))
|
||
(else (syntax-error (location formals) "bad formals" formals))))
|
||
|
||
(define (location x)
|
||
(and (pair? x)
|
||
(let ((props (source-properties x)))
|
||
(and (not (null? props))
|
||
(cons (assq-ref props 'line) (assq-ref props 'column))))))
|