Commit ab8b3af8 authored by Erick Gallesio's avatar Erick Gallesio

NOP

parent af624eae
...@@ -2,9 +2,9 @@ ...@@ -2,9 +2,9 @@
# #
# Author: Erick Gallesio [eg@unice.fr] # Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg) # 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 \ scheme_BOOT = assembler.stk \
bb.stk \ bb.stk \
......
...@@ -18,7 +18,7 @@ ...@@ -18,7 +18,7 @@
# #
# Author: Erick Gallesio [eg@unice.fr] # Author: Erick Gallesio [eg@unice.fr]
# Creation date: 11-Apr-2000 10:30 (eg) # 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@ VPATH = @srcdir@
pkgdatadir = $(datadir)/@PACKAGE@ pkgdatadir = $(datadir)/@PACKAGE@
...@@ -196,7 +196,7 @@ sysconfdir = @sysconfdir@ ...@@ -196,7 +196,7 @@ sysconfdir = @sysconfdir@
target_alias = @target_alias@ target_alias = @target_alias@
top_builddir = @top_builddir@ top_builddir = @top_builddir@
top_srcdir = @top_srcdir@ 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 \ scheme_BOOT = assembler.stk \
bb.stk \ bb.stk \
bonus.stk \ bonus.stk \
......
...@@ -21,7 +21,7 @@ ...@@ -21,7 +21,7 @@
;;;; ;;;;
;;;; Author: Erick Gallesio [eg@unice.fr] ;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 26-Feb-2000 10:47 (eg) ;;;; 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 (define-module STKLOS-COMPILER
...@@ -79,13 +79,13 @@ ...@@ -79,13 +79,13 @@
;; ---------------------------------------------------------------------- ;; ----------------------------------------------------------------------
;; Debbugging support ;; Debbugging support
;; ---------------------------------------------------------------------- ;; ----------------------------------------------------------------------
(export %compiler-debug) ;;= (export %compiler-debug)
;;=
(define %compiler-debug (make-parameter #f)) ;;= (define %compiler-debug (make-parameter #f))
;;=
(define (dprintf . args) ;;= (define (dprintf . args)
(when (%compiler-debug) (apply eprintf args))) ;;= (when (%compiler-debug) (apply eprintf args)))
;;=
;; ---------------------------------------------------------------------- ;; ----------------------------------------------------------------------
;; Compiler parameters ... ;; Compiler parameters ...
...@@ -523,9 +523,8 @@ doc> ...@@ -523,9 +523,8 @@ doc>
;; (param-ok? (cadr expr) '()))) ;; (param-ok? (cadr expr) '())))
;; ;;
(define (compile-body body env epair tail?) (define (rewrite-body body env)
(fluid-let ((*expander-list* *expander-list*))
(define (rewrite-body body)
(let Loop ((l body) (defs '())) (let Loop ((l body) (defs '()))
(cond (cond
((and (pair? l) (pair? (car l)) (eq? (caar l) 'begin)) ((and (pair? l) (pair? (car l)) (eq? (caar l) 'begin))
...@@ -537,31 +536,38 @@ doc> ...@@ -537,31 +536,38 @@ doc>
(Loop (cdr l) (cons (cdr (define->lambda (car l))) defs))) (Loop (cdr l) (cons (cdr (define->lambda (car l))) defs)))
((and (pair? l) (pair? (car l)) (eq? (caar l) 'define-macro)) ((and (pair? l) (pair? (car l)) (eq? (caar l) 'define-macro))
;; This is an internal define-macro. Add expander + skip expression ;; 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) (compile-internal-define-macro (car l) env #f)
(Loop (cdr l) defs)) (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 (else
;; We have parsed all the (starting) definitions ;; We have parsed all the (starting) definitions
(if (null? defs) (if (null? defs)
`(begin ,@l) `(begin ,@l)
(let ((defs (reverse! defs))) (let ((defs (reverse! defs)))
;; Generate "similar" to a letrec* ;; Generate "similar" to a letrec*
`(let ,(map (lambda (x) (list (car x) #f)) defs) `(let ,(map (lambda (x) (list (car x) #f)) defs)
,@(map (lambda (x) `(set! ,@x)) defs) ,@(map (lambda (x) `(set! ,@x)) defs)
,@l))))))) ,@l))))))))
(fluid-let ((*expander-list* (copy-tree *expander-list*)))
(compile (rewrite-body body) env epair tail?)))
(define (compile-user-lambda formals body arity env) ; i.e R5RS ones (define (compile-user-lambda formals body arity env) ; i.e R5RS ones
(let ((env (extend-env env formals)) (let ((env (extend-env env formals))
(lab (new-label))) (lab (new-label)))
(emit 'CREATE-CLOSURE lab arity) (emit 'CREATE-CLOSURE lab arity)
(compile-body body env body #t) (compile (rewrite-body body env) env body #t)
(emit 'RETURN) (emit 'RETURN)
(emit-label lab))) (emit-label lab)))
;;; EXTENDED LAMBDAS ;;; EXTENDED LAMBDAS
;;; ;;;
;;; This code is an adaptation of the contribution of Ian Wild <imw@acm.org> ;;; This code is an adaptation of the contribution of Ian Wild <imw@acm.org>
...@@ -1014,7 +1020,7 @@ doc> ...@@ -1014,7 +1020,7 @@ doc>
(begin (begin
(compile-args actuals env) (compile-args actuals env)
(emit kind len))) (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))) (emit (if tail? 'RETURN 'LEAVE-LET)))
(compiler-error 'lambda epair "bad number of parameters ~S" actuals)))) (compiler-error 'lambda epair "bad number of parameters ~S" actuals))))
...@@ -1068,7 +1074,7 @@ doc> ...@@ -1068,7 +1074,7 @@ doc>
(let ((bindings (cadr args)) (let ((bindings (cadr args))
(body (cddr args))) (body (cddr args)))
(if (null? bindings) (if (null? bindings)
(compile-body body env body tail?) (compile (rewrite-body body env) env body tail?)
(when (valid-let-bindings? bindings #t) (when (valid-let-bindings? bindings #t)
(let ((tmps (map (lambda (_) (gensym)) bindings))) (let ((tmps (map (lambda (_) (gensym)) bindings)))
(compile `(let ,(map (lambda (x) (list (car x) #f)) bindings) (compile `(let ,(map (lambda (x) (list (car x) #f)) bindings)
...@@ -1106,7 +1112,7 @@ doc> ...@@ -1106,7 +1112,7 @@ doc>
(compile-named-let bindings (car body) (cdr body) len args env tail?) (compile-named-let bindings (car body) (cdr body) len args env tail?)
(when (valid-let-bindings? bindings #t) (when (valid-let-bindings? bindings #t)
(if (null? bindings) (if (null? bindings)
(compile-body body env args tail?) (compile (rewrite-body body env) env args tail?)
(compile `((lambda ,(map car bindings) ,@body) (compile `((lambda ,(map car bindings) ,@body)
,@(map cadr bindings)) ,@(map cadr bindings))
env args tail?)))))))) env args tail?))))))))
...@@ -1164,7 +1170,10 @@ doc> ...@@ -1164,7 +1170,10 @@ doc>
(if (null? l) (if (null? l)
;; Compile body ;; Compile body
(let ((new-env (extend-env env locals))) (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))) (emit (if tail? 'RETURN 'LEAVE-LET)))
;; Compile an assignment ;; Compile an assignment
(let* ((var (caar l)) (let* ((var (caar l))
......
...@@ -21,9 +21,11 @@ ...@@ -21,9 +21,11 @@
;;;; ;;;;
;;;; Author: Erick Gallesio [eg@essi.fr] ;;;; Author: Erick Gallesio [eg@essi.fr]
;;;; Creation date: 20-Dec-2006 10:18 (eg) ;;;; 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 ;; The SNOW STklos module
;; ====================================================================== ;; ======================================================================
......
# Makefile for stklos-pkgman # Makefile for stklos-pkgman
# Author: Erick Gallesio [eg@essi.fr] # Author: Erick Gallesio [eg@essi.fr]
# Creation date: 22-Dec-2006 12:00 (eg) # 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 makefiledir= $(prefix)/etc/stklos
...@@ -16,7 +16,8 @@ RM = /bin/rm ...@@ -16,7 +16,8 @@ RM = /bin/rm
SCC = ../utils/stklos-compile SCC = ../utils/stklos-compile
$(bin_SCRIPTS): $(SRC) $(bin_SCRIPTS): $(SRC)
$(SCC) $(SFLAGS) -o $(bin_SCRIPTS) main.stk ../utils/tmpcomp main.stk $(bin_SCRIPTS)
# $(SCC) $(SFLAGS) -o $(bin_SCRIPTS) main.stk
clean: clean:
$(RM) -f $(bin_SCRIPTS) *~ $(RM) -f $(bin_SCRIPTS) *~
......
...@@ -17,7 +17,7 @@ ...@@ -17,7 +17,7 @@
# Makefile for stklos-pkgman # Makefile for stklos-pkgman
# Author: Erick Gallesio [eg@essi.fr] # Author: Erick Gallesio [eg@essi.fr]
# Creation date: 22-Dec-2006 12:00 (eg) # 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@ VPATH = @srcdir@
...@@ -392,7 +392,8 @@ uninstall-am: uninstall-binSCRIPTS uninstall-makefileDATA ...@@ -392,7 +392,8 @@ uninstall-am: uninstall-binSCRIPTS uninstall-makefileDATA
$(bin_SCRIPTS): $(SRC) $(bin_SCRIPTS): $(SRC)
$(SCC) $(SFLAGS) -o $(bin_SCRIPTS) main.stk ../utils/tmpcomp main.stk $(bin_SCRIPTS)
# $(SCC) $(SFLAGS) -o $(bin_SCRIPTS) main.stk
clean: clean:
$(RM) -f $(bin_SCRIPTS) *~ $(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 @@ ...@@ -2,7 +2,7 @@
# #
# tmpcomp -- A temporary script to bootstrap the system # 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 # This program is free software; you can redistribute it and/or modify
...@@ -22,7 +22,7 @@ ...@@ -22,7 +22,7 @@
# #
# Author: Erick Gallesio [eg@unice.fr] # Author: Erick Gallesio [eg@unice.fr]
# Creation date: 1-Jan-2002 18:57 (eg) # 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 # This script is only used to compile the different components of the
...@@ -50,7 +50,7 @@ STKLOS_LOAD_PATH="${prefix}/lib${sep}${prefix}/gtklos" ...@@ -50,7 +50,7 @@ STKLOS_LOAD_PATH="${prefix}/lib${sep}${prefix}/gtklos"
export STKLOS_LOAD_PATH export STKLOS_LOAD_PATH
${prefix}/src/stklos -c -q -b ${prefix}/src/boot.img \ ${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 --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