Commit 3cb6ba56 authored by Erick Gallesio's avatar Erick Gallesio

Fixed a bug with internal macros

parent ab8b3af8
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 11-Dec-2006 14:39 (eg)
;;;; Last file update: 4-Mar-2007 16:15 (eg)
;;;; Last file update: 7-Mar-2007 20:36 (eg)
;;;;
......@@ -58,7 +58,7 @@
(define *ignored-interface-clauses*
'(maintainer authors description categories license snow))
'(maintainer author description keyword license homepage snow))
;; ======================================================================
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 7-Feb-2007 11:03 (eg)
;;;; Last file update: 28-Feb-2007 22:34 (eg)
;;;; Last file update: 5-Mar-2007 23:34 (eg)
;;;;
......
......@@ -21,10 +21,10 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 01-Jan-2000 15:04 (eg)
;;;; Last file update: 28-Feb-2007 21:45 (eg)
;;;; Last file update: 8-Mar-2007 13:57 (eg)
;;;;
(include "runtime.stk") ; Definition necessary for the bootstrap
(include "runtime.stk") ; Definition necessary for the bootstrap
(include "module.stk") ; All the macros for defining modules
(include "r5rs.stk") ; R5RS stuff written in Scheme
(include "boot-callcc.stk") ; Call/cc support
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 26-Feb-2000 10:47 (eg)
;;;; Last file update: 5-Mar-2007 00:20 (eg)
;;;; Last file update: 8-Mar-2007 14:01 (eg)
;;;;
(define-module STKLOS-COMPILER
......@@ -364,9 +364,10 @@ doc>
(name (cadr l))
(proc (caddr l))
(expander `(lambda (form e) (apply ,proc (cdr form)))))
;; Install expander for further compilation
(install-expander! name (eval expander) #f)))))
;; Push expander for further compilation (shadowing global macro)
(push-expander! name (eval expander))
;; return the name of the defined macro
name))))
;;;;
;;;; WHEN/UNLESS
......@@ -523,8 +524,11 @@ doc>
;; (param-ok? (cadr expr) '())))
;;
(define (rewrite-body body env)
(fluid-let ((*expander-list* *expander-list*))
(define (compile-body body env epair tail?)
(define internal-macros '())
(define (rewrite-body body)
(let Loop ((l body) (defs '()))
(cond
((and (pair? l) (pair? (car l)) (eq? (caar l) 'begin))
......@@ -536,38 +540,36 @@ doc>
(Loop (cdr l) (cons (cdr (define->lambda (car l))) defs)))
((and (pair? l) (pair? (car l)) (eq? (caar l) 'define-macro))
;; This is an internal define-macro. Add expander + skip expression
(compile-internal-define-macro (car l) env #f)
(Loop (cdr l) defs))
((and (pair? l)
(pair? (car l))
(symbol? (caar l))
(not (symbol-in-env? (caar l) env))
(expander? (caar l)))
;; Macro-call: expand it
(Loop (cons (macro-expand (car l))
(cdr l))
defs))
(let ((name (compile-internal-define-macro (car l) env #f)))
(eprintf "Internal macro ~S\n" name)
(set! internal-macros (cons name internal-macros))
(Loop (cdr l) defs)))
(else
;; We have parsed all the (starting) definitions
(if (null? defs)
`(begin ,@l)
(let ((defs (reverse! defs)))
;; Generate "similar" to a letrec*
`(let ,(map (lambda (x) (list (car x) #f)) defs)
,@(map (lambda (x) `(set! ,@x)) defs)
,@l))))))))
`(begin ,@l)
(let ((defs (reverse! defs)))
;; Generate "similar" to a letrec*
`(let ,(map (lambda (x) (list (car x) #f)) defs)
,@(map (lambda (x) `(set! ,@x)) defs)
,@l)))))))
;; rewrite the body to transform internal define to letrec
(compile (rewrite-body body) env epair tail?)
;; delete all the internal macros from the list of expanders
(for-each delete-expander! internal-macros))
(define (compile-user-lambda formals body arity env) ; i.e R5RS ones
(let ((env (extend-env env formals))
(lab (new-label)))
(emit 'CREATE-CLOSURE lab arity)
(compile (rewrite-body body env) env body #t)
(compile-body body env body #t)
(emit 'RETURN)
(emit-label lab)))
;;; EXTENDED LAMBDAS
;;;
;;; This code is an adaptation of the contribution of Ian Wild <imw@acm.org>
......@@ -1020,7 +1022,7 @@ doc>
(begin
(compile-args actuals env)
(emit kind len)))
(compile (rewrite-body body new-env) new-env epair tail?)
(compile-body body new-env epair tail?)
(emit (if tail? 'RETURN 'LEAVE-LET)))
(compiler-error 'lambda epair "bad number of parameters ~S" actuals))))
......@@ -1074,7 +1076,7 @@ doc>
(let ((bindings (cadr args))
(body (cddr args)))
(if (null? bindings)
(compile (rewrite-body body env) env body tail?)
(compile-body body env body tail?)
(when (valid-let-bindings? bindings #t)
(let ((tmps (map (lambda (_) (gensym)) bindings)))
(compile `(let ,(map (lambda (x) (list (car x) #f)) bindings)
......@@ -1112,7 +1114,7 @@ doc>
(compile-named-let bindings (car body) (cdr body) len args env tail?)
(when (valid-let-bindings? bindings #t)
(if (null? bindings)
(compile (rewrite-body body env) env args tail?)
(compile-body body env args tail?)
(compile `((lambda ,(map car bindings) ,@body)
,@(map cadr bindings))
env args tail?))))))))
......@@ -1170,10 +1172,7 @@ doc>
(if (null? l)
;; Compile body
(let ((new-env (extend-env env locals)))
(compile (rewrite-body body new-env)
new-env
body
tail?)
(compile-body body new-env body tail?)
(emit (if tail? 'RETURN 'LEAVE-LET)))
;; Compile an assignment
(let* ((var (caar l))
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 15-Mar-2001 22:49 (eg)
;;;; Last file update: 1-Feb-2007 22:39 (eg)
;;;; Last file update: 8-Mar-2007 14:00 (eg)
;;;;
......@@ -66,10 +66,35 @@
(define (install-expander! id proc code)
(set! *expander-list* (cons (cons id proc) *expander-list*))
(when code
;; Global macro: Keep the macro code to save it in byte-code header
(set! *expander-list-src* (cons (cons id code) *expander-list-src*))))
;; Add the new macro to the expander list
(let ((old (assq id *expander-list*)))
(if old
(set-cdr! old proc)
(set! *expander-list* (cons (cons id proc) *expander-list*))))
;; Global macro: Keep the macro code to eventually save it in byte-code header
(let ((old (assq id *expander-list-src*)))
(if old
(set-cdr! old code)
(set! *expander-list-src* (cons (cons id code) *expander-list-src*)))))
(define (push-expander! id proc)
;; Used by internal macro. Macro is pushed on the list to shadow the global one
(set! *expander-list* (cons (cons id proc) *expander-list*)))
(define (delete-expander! id)
(let loop ((lst *expander-list*)
(prv #f))
(cond
((null? lst)
(void))
((eq? (caar lst) id)
(if prv
(set-cdr! prv (cdr lst))
(set! *expander-list* (cdr lst))))
(else
(loop (cdr lst) lst)))))
;;;
;;; Expander-list-src management
......
......@@ -21,9 +21,12 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 22-Dec-2006 11:32 (eg)
;;;; Last file update: 16-Feb-2007 19:22 (eg)
;;;; Last file update: 5-Mar-2007 22:11 (eg)
;;;;
(require "getopt")
(require "match")
(include "types.stk")
(include "params.stk")
(include "http.stk")
......
This diff is collapsed.
This source diff could not be displayed because it is too large. You can view the blob instead.
......@@ -21,9 +21,12 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 4-Dec-2001 18:12 (eg)
;;;; Last file update: 1-Feb-2007 13:34 (eg)
;;;; Last file update: 7-Mar-2007 16:01 (eg)
;;;;
;(require "match")
;(require "getopt")
(define *output* "a.out")
(define *c-code* #f)
(define *expr* #f)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment