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 diff is collapsed.
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