Commit ab8b3af8 authored by Erick Gallesio's avatar Erick Gallesio

NOP

parent af624eae
......@@ -2,9 +2,9 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg)
# Last file update: 28-Feb-2007 21:45 (eg)
# Last file update: 5-Mar-2007 07:45 (eg)
SUBDIRS = Match.d SILex.d Lalr.d Snow.d ScmPkg.d @LURCDIR@
SUBDIRS = Match.d SILex.d Lalr.d ScmPkg.d @LURCDIR@
scheme_BOOT = assembler.stk \
bb.stk \
......
......@@ -18,7 +18,7 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg)
# Last file update: 28-Feb-2007 21:45 (eg)
# Last file update: 5-Mar-2007 07:45 (eg)
VPATH = @srcdir@
pkgdatadir = $(datadir)/@PACKAGE@
......@@ -196,7 +196,7 @@ sysconfdir = @sysconfdir@
target_alias = @target_alias@
top_builddir = @top_builddir@
top_srcdir = @top_srcdir@
SUBDIRS = Match.d SILex.d Lalr.d Snow.d ScmPkg.d @LURCDIR@
SUBDIRS = Match.d SILex.d Lalr.d ScmPkg.d @LURCDIR@
scheme_BOOT = assembler.stk \
bb.stk \
bonus.stk \
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 26-Feb-2000 10:47 (eg)
;;;; Last file update: 4-Mar-2007 21:02 (eg)
;;;; Last file update: 5-Mar-2007 00:20 (eg)
;;;;
(define-module STKLOS-COMPILER
......@@ -79,13 +79,13 @@
;; ----------------------------------------------------------------------
;; Debbugging support
;; ----------------------------------------------------------------------
(export %compiler-debug)
(define %compiler-debug (make-parameter #f))
(define (dprintf . args)
(when (%compiler-debug) (apply eprintf args)))
;;= (export %compiler-debug)
;;=
;;= (define %compiler-debug (make-parameter #f))
;;=
;;= (define (dprintf . args)
;;= (when (%compiler-debug) (apply eprintf args)))
;;=
;; ----------------------------------------------------------------------
;; Compiler parameters ...
......@@ -523,9 +523,8 @@ doc>
;; (param-ok? (cadr expr) '())))
;;
(define (compile-body body env epair tail?)
(define (rewrite-body body)
(define (rewrite-body body env)
(fluid-let ((*expander-list* *expander-list*))
(let Loop ((l body) (defs '()))
(cond
((and (pair? l) (pair? (car l)) (eq? (caar l) 'begin))
......@@ -537,31 +536,38 @@ 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
(eprintf "Internal macro ~S\n" (car l))
(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))
(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)))))))
(fluid-let ((*expander-list* (copy-tree *expander-list*)))
(compile (rewrite-body body) env epair tail?)))
`(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))))))))
(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-body body env body #t)
(compile (rewrite-body body env) env body #t)
(emit 'RETURN)
(emit-label lab)))
;;; EXTENDED LAMBDAS
;;;
;;; This code is an adaptation of the contribution of Ian Wild <imw@acm.org>
......@@ -1014,7 +1020,7 @@ doc>
(begin
(compile-args actuals env)
(emit kind len)))
(compile-body body new-env epair tail?)
(compile (rewrite-body body new-env) new-env epair tail?)
(emit (if tail? 'RETURN 'LEAVE-LET)))
(compiler-error 'lambda epair "bad number of parameters ~S" actuals))))
......@@ -1068,7 +1074,7 @@ doc>
(let ((bindings (cadr args))
(body (cddr args)))
(if (null? bindings)
(compile-body body env body tail?)
(compile (rewrite-body body env) 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)
......@@ -1106,7 +1112,7 @@ doc>
(compile-named-let bindings (car body) (cdr body) len args env tail?)
(when (valid-let-bindings? bindings #t)
(if (null? bindings)
(compile-body body env args tail?)
(compile (rewrite-body body env) env args tail?)
(compile `((lambda ,(map car bindings) ,@body)
,@(map cadr bindings))
env args tail?))))))))
......@@ -1164,7 +1170,10 @@ doc>
(if (null? l)
;; Compile body
(let ((new-env (extend-env env locals)))
(compile-body body new-env body tail?)
(compile (rewrite-body body new-env)
new-env
body
tail?)
(emit (if tail? 'RETURN 'LEAVE-LET)))
;; Compile an assignment
(let* ((var (caar l))
......
......@@ -21,9 +21,11 @@
;;;;
;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 20-Dec-2006 10:18 (eg)
;;;; Last file update: 11-Feb-2007 21:47 (eg)
;;;; Last file update: 4-Mar-2007 22:49 (eg)
;;;;
(require-for-syntax "match")
;; ======================================================================
;; The SNOW STklos module
;; ======================================================================
......
# Makefile for stklos-pkgman
# Author: Erick Gallesio [eg@essi.fr]
# Creation date: 22-Dec-2006 12:00 (eg)
# Last file update: 16-Feb-2007 23:34 (eg)
# Last file update: 5-Mar-2007 12:00 (eg)
makefiledir= $(prefix)/etc/stklos
......@@ -16,7 +16,8 @@ RM = /bin/rm
SCC = ../utils/stklos-compile
$(bin_SCRIPTS): $(SRC)
$(SCC) $(SFLAGS) -o $(bin_SCRIPTS) main.stk
../utils/tmpcomp main.stk $(bin_SCRIPTS)
# $(SCC) $(SFLAGS) -o $(bin_SCRIPTS) main.stk
clean:
$(RM) -f $(bin_SCRIPTS) *~
......
......@@ -17,7 +17,7 @@
# Makefile for stklos-pkgman
# Author: Erick Gallesio [eg@essi.fr]
# Creation date: 22-Dec-2006 12:00 (eg)
# Last file update: 16-Feb-2007 23:34 (eg)
# Last file update: 5-Mar-2007 12:00 (eg)
VPATH = @srcdir@
......@@ -392,7 +392,8 @@ uninstall-am: uninstall-binSCRIPTS uninstall-makefileDATA
$(bin_SCRIPTS): $(SRC)
$(SCC) $(SFLAGS) -o $(bin_SCRIPTS) main.stk
../utils/tmpcomp main.stk $(bin_SCRIPTS)
# $(SCC) $(SFLAGS) -o $(bin_SCRIPTS) main.stk
clean:
$(RM) -f $(bin_SCRIPTS) *~
......
This source diff could not be displayed because it is too large. You can view the blob instead.
This source diff could not be displayed because it is too large. You can view the blob instead.
......@@ -2,7 +2,7 @@
#
# tmpcomp -- A temporary script to bootstrap the system
#
# Copyright © 2002-2006 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
# Copyright © 2002-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
#
#
# This program is free software; you can redistribute it and/or modify
......@@ -22,7 +22,7 @@
#
# Author: Erick Gallesio [eg@unice.fr]
# Creation date: 1-Jan-2002 18:57 (eg)
# Last file update: 14-Apr-2006 23:30 (eg)
# Last file update: 5-Mar-2007 12:11 (eg)
#
# This script is only used to compile the different components of the
......@@ -50,7 +50,7 @@ STKLOS_LOAD_PATH="${prefix}/lib${sep}${prefix}/gtklos"
export STKLOS_LOAD_PATH
${prefix}/src/stklos -c -q -b ${prefix}/src/boot.img \
-f ${prefix}/utils/stklos-compile -- \
-f ${prefix}/utils/stklos-compile.stk -- \
--no-time --output=$out $in && chmod a+x $out
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