mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-17 09:10:22 +02:00
Code Activity

Merge branch 'syncase-in-boot-9'

Browse source 
Conflicts:
	module/Makefile.am
This commit is contained in:
Andy Wingo 2009-05-29 16:01:43 +02:00
commit 938d46a35d
92 changed files with 4522 additions and 3330 deletions
Download patch file Download diff file Expand all files Collapse all files

46
module/Makefile.am
View file

@ -31,22 +31,15 @@ modpath =
# putting these core modules first.
SOURCES = \
ice-9/psyntax-pp.scm \
ice-9/psyntax-pp.scm \
system/base/pmatch.scm system/base/syntax.scm \
system/base/compile.scm system/base/language.scm \
\
system/vm/debug.scm system/vm/frame.scm system/vm/instruction.scm \
system/vm/objcode.scm system/vm/profile.scm system/vm/program.scm \
system/vm/trace.scm system/vm/vm.scm \
\
system/xref.scm \
\
system/repl/repl.scm system/repl/common.scm \
system/repl/command.scm \
\
language/tree-il.scm \
language/ghil.scm language/glil.scm language/assembly.scm \
\
$(SCHEME_LANG_SOURCES) $(ECMASCRIPT_LANG_SOURCES) \
$(SCHEME_LANG_SOURCES) \
$(TREE_IL_LANG_SOURCES) \
$(GHIL_LANG_SOURCES) $(GLIL_LANG_SOURCES) \
$(ASSEMBLY_LANG_SOURCES) $(BYTECODE_LANG_SOURCES) \
$(OBJCODE_LANG_SOURCES) $(VALUE_LANG_SOURCES) \
@ -55,7 +48,8 @@ SOURCES = \
$(SRFI_SOURCES) \
$(RNRS_SOURCES) \
$(OOP_SOURCES) \
\
$(SYSTEM_SOURCES) \
$(ECMASCRIPT_LANG_SOURCES) \
$(SCRIPTS_SOURCES)
## test.scm is not currently installed.
@ -72,10 +66,19 @@ ice-9/psyntax-pp.scm: ice-9/psyntax.scm
$(srcdir)/ice-9/psyntax.scm $(srcdir)/ice-9/psyntax-pp.scm
SCHEME_LANG_SOURCES = \
language/scheme/amatch.scm language/scheme/expand.scm \
language/scheme/compile-ghil.scm language/scheme/spec.scm \
language/scheme/compile-ghil.scm \
language/scheme/spec.scm \
language/scheme/compile-tree-il.scm \
language/scheme/decompile-tree-il.scm \
language/scheme/inline.scm
TREE_IL_LANG_SOURCES = \
language/tree-il/primitives.scm \
language/tree-il/optimize.scm \
language/tree-il/analyze.scm \
language/tree-il/compile-glil.scm \
language/tree-il/spec.scm
GHIL_LANG_SOURCES = \
language/ghil/spec.scm language/ghil/compile-glil.scm
@ -141,7 +144,6 @@ ICE_9_SOURCES = \
ice-9/debugger.scm \
ice-9/documentation.scm \
ice-9/emacs.scm \
ice-9/expand-support.scm \
ice-9/expect.scm \
ice-9/format.scm \
ice-9/getopt-long.scm \
@ -199,6 +201,7 @@ SRFI_SOURCES = \
srfi/srfi-14.scm \
srfi/srfi-16.scm \
srfi/srfi-17.scm \
srfi/srfi-18.scm \
srfi/srfi-19.scm \
srfi/srfi-26.scm \
srfi/srfi-31.scm \
@ -231,6 +234,16 @@ OOP_SOURCES = \
oop/goops/accessors.scm \
oop/goops/simple.scm
SYSTEM_SOURCES = \
system/vm/debug.scm system/vm/frame.scm system/vm/instruction.scm \
system/vm/objcode.scm system/vm/profile.scm system/vm/program.scm \
system/vm/trace.scm system/vm/vm.scm \
\
system/xref.scm \
\
system/repl/repl.scm system/repl/common.scm \
system/repl/command.scm
EXTRA_DIST += oop/ChangeLog-2008
NOCOMP_SOURCES = \
@ -247,5 +260,4 @@ NOCOMP_SOURCES = \
ice-9/debugging/steps.scm \
ice-9/debugging/trace.scm \
ice-9/debugging/traps.scm \
ice-9/debugging/trc.scm \
srfi/srfi-18.scm
ice-9/debugging/trc.scm

542
module/ice-9/boot-9.scm
View file

@ -33,6 +33,13 @@
;; Before compiling, make sure any symbols are resolved in the (guile)
;; module, the primary location of those symbols, rather than in
;; (guile-user), the default module that we compile in.
(eval-when (compile)
(set-current-module (resolve-module '(guile))))
;;; {R4RS compliance}
;;;
@ -86,6 +93,42 @@
(define (provided? feature)
(and (memq feature *features*) #t))
;;; {and-map and or-map}
;;;
;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)
;;; (or-map fn lst) is like (or (fn (car lst)) (fn (cadr lst)) (fn...) ...)
;;;
;; and-map f l
;;
;; Apply f to successive elements of l until exhaustion or f returns #f.
;; If returning early, return #f. Otherwise, return the last value returned
;; by f. If f has never been called because l is empty, return #t.
;;
(define (and-map f lst)
(let loop ((result #t)
(l lst))
(and result
(or (and (null? l)
result)
(loop (f (car l)) (cdr l))))))
;; or-map f l
;;
;; Apply f to successive elements of l until exhaustion or while f returns #f.
;; If returning early, return the return value of f.
;;
(define (or-map f lst)
(let loop ((result #f)
(l lst))
(or result
(and (not (null? l))
(loop (f (car l)) (cdr l))))))
;; let format alias simple-format until the more complete version is loaded
(define format simple-format)
@ -125,97 +168,181 @@
;; Before the module system boots, there are no module names. But
;; psyntax does want a module-name definition, so give it one.
;; Define a minimal stub of the module API for psyntax, before modules
;; have booted.
(define (module-name x)
'(guile))
(define (module-define! module sym val)
(let ((v (hashq-ref (%get-pre-modules-obarray) sym)))
(if v
(variable-set! v val)
(hashq-set! (%get-pre-modules-obarray) sym
(make-variable val)))))
(define (module-ref module sym)
(let ((v (module-variable module sym)))
(if v (variable-ref v) (error "badness!" (pk module) (pk sym)))))
(define (resolve-module . args)
#f)
;; (eval-when (situation...) form...)
;;
;; Evaluate certain code based on the situation that eval-when is used
;; in. There are three situations defined.
;;
;; `load' triggers when a file is loaded via `load', or when a compiled
;; file is loaded.
;;
;; `compile' triggers when an expression is compiled.
;;
;; `eval' triggers when code is evaluated interactively, as at the REPL
;; or via the `compile' or `eval' procedures.
;; Input hook to syncase -- so that we might be able to pass annotated
;; expressions in. Currently disabled. Maybe we should just use
;; source-properties directly.
(define (annotation? x) #f)
;; NB: this macro is only ever expanded by the interpreter. The compiler
;; notices it and interprets the situations differently.
(define eval-when
(procedure->memoizing-macro
(lambda (exp env)
(let ((situations (cadr exp))
(body (cddr exp)))
(if (or (memq 'load situations)
(memq 'eval situations))
`(begin . ,body))))))
;; API provided by psyntax
(define syntax-violation #f)
(define datum->syntax #f)
(define syntax->datum #f)
(define identifier? #f)
(define generate-temporaries #f)
(define bound-identifier=? #f)
(define free-identifier=? #f)
(define sc-expand #f)
;; $sc-expand is an implementation detail of psyntax. It is used by
;; expanded macros, to dispatch an input against a set of patterns.
(define $sc-dispatch #f)
;; Load it up!
(primitive-load-path "ice-9/psyntax-pp")
;; %pre-modules-transformer is the Scheme expander from now until the
;; module system has booted up.
(define %pre-modules-transformer sc-expand)
(define-syntax and
(syntax-rules ()
((_) #t)
((_ x) x)
((_ x y ...) (if x (and y ...) #f))))
(define-syntax or
(syntax-rules ()
((_) #f)
((_ x) x)
((_ x y ...) (let ((t x)) (if t t (or y ...))))))
;; The "maybe-more" bits are something of a hack, so that we can support
;; SRFI-61. Rewrites into a standalone syntax-case macro would be
;; appreciated.
(define-syntax cond
(syntax-rules (=> else)
((_ "maybe-more" test consequent)
(if test consequent))
((_ "maybe-more" test consequent clause ...)
(if test consequent (cond clause ...)))
((_ (else else1 else2 ...))
(begin else1 else2 ...))
((_ (test => receiver) more-clause ...)
(let ((t test))
(cond "maybe-more" t (receiver t) more-clause ...)))
((_ (generator guard => receiver) more-clause ...)
(call-with-values (lambda () generator)
(lambda t
(cond "maybe-more"
(apply guard t) (apply receiver t) more-clause ...))))
((_ (test => receiver ...) more-clause ...)
(syntax-violation 'cond "wrong number of receiver expressions"
'(test => receiver ...)))
((_ (generator guard => receiver ...) more-clause ...)
(syntax-violation 'cond "wrong number of receiver expressions"
'(generator guard => receiver ...)))
((_ (test) more-clause ...)
(let ((t test))
(cond "maybe-more" t t more-clause ...)))
((_ (test body1 body2 ...) more-clause ...)
(cond "maybe-more"
test (begin body1 body2 ...) more-clause ...))))
(define-syntax case
(syntax-rules (else)
((case (key ...)
clauses ...)
(let ((atom-key (key ...)))
(case atom-key clauses ...)))
((case key
(else result1 result2 ...))
(begin result1 result2 ...))
((case key
((atoms ...) result1 result2 ...))
(if (memv key '(atoms ...))
(begin result1 result2 ...)))
((case key
((atoms ...) result1 result2 ...)
clause clauses ...)
(if (memv key '(atoms ...))
(begin result1 result2 ...)
(case key clause clauses ...)))))
(define-syntax do
(syntax-rules ()
((do ((var init step ...) ...)
(test expr ...)
command ...)
(letrec
((loop
(lambda (var ...)
(if test
(begin
(if #f #f)
expr ...)
(begin
command
...
(loop (do "step" var step ...)
...))))))
(loop init ...)))
((do "step" x)
x)
((do "step" x y)
y)))
(define-syntax delay
(syntax-rules ()
((_ exp) (make-promise (lambda () exp)))))
;; Before compiling, make sure any symbols are resolved in the (guile)
;; module, the primary location of those symbols, rather than in
;; (guile-user), the default module that we compile in.
(eval-when (compile)
(set-current-module (resolve-module '(guile))))
;;; {Defmacros}
;;;
;;; Depends on: features, eval-case
;;;
(define macro-table (make-weak-key-hash-table 61))
(define xformer-table (make-weak-key-hash-table 61))
(define-syntax define-macro
(lambda (x)
"Define a defmacro."
(syntax-case x ()
((_ (macro . args) doc body1 body ...)
(string? (syntax->datum (syntax doc)))
(syntax (define-macro macro doc (lambda args body1 body ...))))
((_ (macro . args) body ...)
(syntax (define-macro macro #f (lambda args body ...))))
((_ macro doc transformer)
(or (string? (syntax->datum (syntax doc)))
(not (syntax->datum (syntax doc))))
(syntax
(define-syntax macro
(lambda (y)
doc
(syntax-case y ()
((_ . args)
(let ((v (syntax->datum (syntax args))))
(datum->syntax y (apply transformer v))))))))))))
(define (defmacro? m) (hashq-ref macro-table m))
(define (assert-defmacro?! m) (hashq-set! macro-table m #t))
(define (defmacro-transformer m) (hashq-ref xformer-table m))
(define (set-defmacro-transformer! m t) (hashq-set! xformer-table m t))
(define defmacro:transformer
(lambda (f)
(let* ((xform (lambda (exp env)
(copy-tree (apply f (cdr exp)))))
(a (procedure->memoizing-macro xform)))
(assert-defmacro?! a)
(set-defmacro-transformer! a f)
a)))
(define defmacro
(let ((defmacro-transformer
(lambda (name parms . body)
(let ((transformer `(lambda ,parms ,@body)))
`(eval-when
(eval load compile)
(define ,name (defmacro:transformer ,transformer)))))))
(defmacro:transformer defmacro-transformer)))
;; XXX - should the definition of the car really be looked up in the
;; current module?
(define (macroexpand-1 e)
(cond
((pair? e) (let* ((a (car e))
(val (and (symbol? a) (local-ref (list a)))))
(if (defmacro? val)
(apply (defmacro-transformer val) (cdr e))
e)))
(#t e)))
(define (macroexpand e)
(cond
((pair? e) (let* ((a (car e))
(val (and (symbol? a) (local-ref (list a)))))
(if (defmacro? val)
(macroexpand (apply (defmacro-transformer val) (cdr e)))
e)))
(#t e)))
(define-syntax defmacro
(lambda (x)
"Define a defmacro, with the old lispy defun syntax."
(syntax-case x ()
((_ macro args doc body1 body ...)
(string? (syntax->datum (syntax doc)))
(syntax (define-macro macro doc (lambda args body1 body ...))))
((_ macro args body ...)
(syntax (define-macro macro #f (lambda args body ...)))))))
(provide 'defmacro)
@ -477,40 +604,6 @@
;;; {and-map and or-map}
;;;
;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)
;;; (or-map fn lst) is like (or (fn (car lst)) (fn (cadr lst)) (fn...) ...)
;;;
;; and-map f l
;;
;; Apply f to successive elements of l until exhaustion or f returns #f.
;; If returning early, return #f. Otherwise, return the last value returned
;; by f. If f has never been called because l is empty, return #t.
;;
(define (and-map f lst)
(let loop ((result #t)
(l lst))
(and result
(or (and (null? l)
result)
(loop (f (car l)) (cdr l))))))
;; or-map f l
;;
;; Apply f to successive elements of l until exhaustion or while f returns #f.
;; If returning early, return the return value of f.
;;
(define (or-map f lst)
(let loop ((result #f)
(l lst))
(or result
(and (not (null? l))
(loop (f (car l)) (cdr l))))))
(if (provided? 'posix)
(primitive-load-path "ice-9/posix"))
@ -757,6 +850,26 @@
(start-stack 'load-stack
(primitive-load-path name)))
(define %load-verbosely #f)
(define (assert-load-verbosity v) (set! %load-verbosely v))
(define (%load-announce file)
(if %load-verbosely
(with-output-to-port (current-error-port)
(lambda ()
(display ";;; ")
(display "loading ")
(display file)
(newline)
(force-output)))))
(set! %load-hook %load-announce)
(define (load name . reader)
(with-fluid* current-reader (and (pair? reader) (car reader))
(lambda ()
(start-stack 'load-stack
(primitive-load name)))))
@ -848,9 +961,6 @@
;;; Reader code for various "#c" forms.
;;;
(read-hash-extend #\' (lambda (c port)
(read port)))
(define read-eval? (make-fluid))
(fluid-set! read-eval? #f)
(read-hash-extend #\.
@ -1133,11 +1243,8 @@
(define (%print-module mod port) ; unused args: depth length style table)
(display "#<" port)
(display (or (module-kind mod) "module") port)
(let ((name (module-name mod)))
(if name
(begin
(display " " port)
(display name port))))
(display " " port)
(display (module-name mod) port)
(display " " port)
(display (number->string (object-address mod) 16) port)
(display ">" port))
@ -1194,7 +1301,8 @@
"Lazy-binder expected to be a procedure or #f." binder))
(let ((module (module-constructor (make-hash-table size)
uses binder #f #f #f #f #f
uses binder #f %pre-modules-transformer
#f #f #f
(make-hash-table %default-import-size)
'()
(make-weak-key-hash-table 31))))
@ -1219,7 +1327,7 @@
(define module-transformer (record-accessor module-type 'transformer))
(define set-module-transformer! (record-modifier module-type 'transformer))
(define module-name (record-accessor module-type 'name))
;; (define module-name (record-accessor module-type 'name)) wait until mods are booted
(define set-module-name! (record-modifier module-type 'name))
(define module-kind (record-accessor module-type 'kind))
(define set-module-kind! (record-modifier module-type 'kind))
@ -1363,7 +1471,9 @@
;; or its uses?
;;
(define (module-bound? m v)
(module-search module-locally-bound? m v))
(let ((var (module-variable m v)))
(and var
(variable-bound? var))))
;;; {Is a symbol interned in a module?}
;;;
@ -1799,7 +1909,7 @@
val
(let ((m (make-module 31)))
(set-module-kind! m 'directory)
(set-module-name! m (append (or (module-name module) '())
(set-module-name! m (append (module-name module)
(list (car name))))
(module-define! module (car name) m)
m)))
@ -1853,22 +1963,31 @@
(define default-duplicate-binding-procedures #f)
(define %app (make-module 31))
(set-module-name! %app '(%app))
(define app %app) ;; for backwards compatability
(local-define '(%app modules) (make-module 31))
(let ((m (make-module 31)))
(set-module-name! m '())
(local-define '(%app modules) m))
(local-define '(%app modules guile) the-root-module)
;; This boots the module system. All bindings needed by modules.c
;; must have been defined by now.
;;
(set-current-module the-root-module)
;; definition deferred for syncase's benefit.
(define module-name
(let ((accessor (record-accessor module-type 'name)))
(lambda (mod)
(or (accessor mod)
(begin
(set-module-name! mod (list (gensym)))
(accessor mod))))))
;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module)))
(define (try-load-module name)
(or (begin-deprecated (try-module-linked name))
(try-module-autoload name)
(begin-deprecated (try-module-dynamic-link name))))
(try-module-autoload name))
(define (purify-module! module)
"Removes bindings in MODULE which are inherited from the (guile) module."
@ -2002,23 +2121,34 @@
((#:use-module #:use-syntax)
(or (pair? (cdr kws))
(unrecognized kws))
(let* ((interface-args (cadr kws))
(interface (apply resolve-interface interface-args)))
(and (eq? (car kws) #:use-syntax)
(or (symbol? (caar interface-args))
(error "invalid module name for use-syntax"
(car interface-args)))
(set-module-transformer!
module
(module-ref interface
(car (last-pair (car interface-args)))
#f)))
(cond
((equal? (caadr kws) '(ice-9 syncase))
(issue-deprecation-warning
"(ice-9 syncase) is deprecated. Support for syntax-case is now in Guile core.")
(loop (cddr kws)
(cons interface reversed-interfaces)
reversed-interfaces
exports
re-exports
replacements
autoloads)))
autoloads))
(else
(let* ((interface-args (cadr kws))
(interface (apply resolve-interface interface-args)))
(and (eq? (car kws) #:use-syntax)
(or (symbol? (caar interface-args))
(error "invalid module name for use-syntax"
(car interface-args)))
(set-module-transformer!
module
(module-ref interface
(car (last-pair (car interface-args)))
#f)))
(loop (cddr kws)
(cons interface reversed-interfaces)
exports
re-exports
replacements
autoloads)))))
((#:autoload)
(or (and (pair? (cdr kws)) (pair? (cddr kws)))
(unrecognized kws))
@ -2310,11 +2440,12 @@ module '(ice-9 q) '(make-q q-length))}."
(define (set-repl-prompt! v) (set! scm-repl-prompt v))
(define (default-pre-unwind-handler key . args)
(save-stack pre-unwind-handler-dispatch)
(save-stack 1)
(apply throw key args))
(define (pre-unwind-handler-dispatch key . args)
(apply default-pre-unwind-handler key args))
(begin-deprecated
(define (pre-unwind-handler-dispatch key . args)
(apply default-pre-unwind-handler key args)))
(define abort-hook (make-hook))
@ -2391,15 +2522,7 @@ module '(ice-9 q) '(make-q q-length))}."
(else
(apply bad-throw key args)))))))
;; Note that having just `pre-unwind-handler-dispatch'
;; here is connected with the mechanism that
;; produces a nice backtrace upon error. If, for
;; example, this is replaced with (lambda args
;; (apply pre-unwind-handler-dispatch args)), the stack
;; cutting (in save-stack) goes wrong and ends up
;; saving no stack at all, so there is no
;; backtrace.
pre-unwind-handler-dispatch)))
default-pre-unwind-handler)))
(if next (loop next) status)))
(set! set-batch-mode?! (lambda (arg)
@ -2674,32 +2797,6 @@ module '(ice-9 q) '(make-q q-length))}."
`(with-fluids* (list ,@fluids) (list ,@values)
(lambda () ,@body)))))
;;; {Macros}
;;;
;; actually....hobbit might be able to hack these with a little
;; coaxing
;;
(define (primitive-macro? m)
(and (macro? m)
(not (macro-transformer m))))
(defmacro define-macro (first . rest)
(let ((name (if (symbol? first) first (car first)))
(transformer
(if (symbol? first)
(car rest)
`(lambda ,(cdr first) ,@rest))))
`(eval-when
(eval load compile)
(define ,name (defmacro:transformer ,transformer)))))
;;; {While}
;;;
;;; with `continue' and `break'.
@ -2839,50 +2936,33 @@ module '(ice-9 q) '(make-q q-length))}."
(defmacro use-syntax (spec)
`(eval-when
(eval load compile)
,@(if (pair? spec)
`((process-use-modules (list
(list ,@(compile-interface-spec spec))))
(set-module-transformer! (current-module)
,(car (last-pair spec))))
`((set-module-transformer! (current-module) ,spec)))
*unspecified*))
(issue-deprecation-warning
"`use-syntax' is deprecated. Please contact guile-devel for more info.")
(process-use-modules (list (list ,@(compile-interface-spec spec))))
*unspecified*))
;; Dirk:FIXME:: This incorrect (according to R5RS) syntax needs to be changed
;; as soon as guile supports hygienic macros.
(define define-private define)
(define-syntax define-private
(syntax-rules ()
((_ foo bar)
(define foo bar))))
(defmacro define-public args
(define (syntax)
(error "bad syntax" (list 'define-public args)))
(define (defined-name n)
(cond
((symbol? n) n)
((pair? n) (defined-name (car n)))
(else (syntax))))
(cond
((null? args)
(syntax))
(#t
(let ((name (defined-name (car args))))
`(begin
(define-private ,@args)
(export ,name))))))
(define-syntax define-public
(syntax-rules ()
((_ (name . args) . body)
(define-public name (lambda args . body)))
((_ name val)
(begin
(define name val)
(export name)))))
(defmacro defmacro-public args
(define (syntax)
(error "bad syntax" (list 'defmacro-public args)))
(define (defined-name n)
(cond
((symbol? n) n)
(else (syntax))))
(cond
((null? args)
(syntax))
(#t
(let ((name (defined-name (car args))))
`(begin
(export-syntax ,name)
(defmacro ,@args))))))
(define-syntax defmacro-public
(syntax-rules ()
((_ name args . body)
(begin
(defmacro name args . body)
(export-syntax name)))))
;; Export a local variable
@ -2936,19 +3016,6 @@ module '(ice-9 q) '(make-q q-length))}."
(define load load-module)
;;; {Compiler interface}
;;;
;;; The full compiler interface can be found in (system). Here we put a
;;; few useful procedures into the global namespace.
(module-autoload! the-scm-module
'(system base compile)
'(compile
compile-time-environment))
;;; {Parameters}
@ -3371,6 +3438,13 @@ module '(ice-9 q) '(make-q q-length))}."
;;; Place the user in the guile-user module.
;;;
(define-module (guile-user))
;;; FIXME: annotate ?
;; (define (syncase exp)
;; (with-fluids ((expansion-eval-closure
;; (module-eval-closure (current-module))))
;; (deannotate/source-properties (sc-expand (annotate exp)))))
(define-module (guile-user)
#:autoload (system base compile) (compile))
;;; boot-9.scm ends here

47
module/ice-9/compile-psyntax.scm
View file

@ -1,27 +1,20 @@
(use-modules (ice-9 syncase))
;; XXX - We need to be inside (ice-9 syncase) since psyntax.ss calls
;; `eval' int he `interaction-environment' aka the current module and
;; it expects to have `andmap' there. The reason for this escapes me
;; at the moment.
;;
(define-module (ice-9 syncase))
(define source (list-ref (command-line) 1))
(define target (list-ref (command-line) 2))
(let ((in (open-input-file source))
(out (open-output-file (string-append target ".tmp"))))
(let loop ((x (read in)))
(if (eof-object? x)
(begin
(close-port out)
(close-port in))
(begin
(write (strip-expansion-structures
(sc-expand3 x 'c '(compile load eval)))
out)
(newline out)
(loop (read in))))))
(system (format #f "mv -f ~s.tmp ~s" target target))
(use-modules (language tree-il))
(let ((source (list-ref (command-line) 1))
(target (list-ref (command-line) 2)))
(let ((in (open-input-file source))
(out (open-output-file (string-append target ".tmp"))))
(write '(eval-when (compile) (set-current-module (resolve-module '(guile))))
out)
(newline out)
(let loop ((x (read in)))
(if (eof-object? x)
(begin
(close-port out)
(close-port in))
(begin
(write (tree-il->scheme
(sc-expand x 'c '(compile load eval)))
out)
(newline out)
(loop (read in))))))
(system (format #f "mv -f ~s.tmp ~s" target target)))

8
module/ice-9/documentation.scm
View file

@ -195,15 +195,11 @@ OBJECT can be a procedure, macro or any object that has its
`documentation' property set."
(or (and (procedure? object)
(proc-doc object))
(and (defmacro? object)
(proc-doc (defmacro-transformer object)))
(and (macro? object)
(let ((transformer (macro-transformer object)))
(and transformer
(proc-doc transformer))))
(object-property object 'documentation)
(and (program? object)
(program-documentation object))
(and (macro? object)
(object-documentation (macro-transformer object)))
(and (procedure? object)
(not (closure? object))
(procedure-name object)

169
module/ice-9/expand-support.scm
View file

@ -1,169 +0,0 @@
;;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
(define-module (ice-9 expand-support)
:export (<annotation> annotation? annotate deannotate make-annotation
annotation-expression annotation-source annotation-stripped
set-annotation-stripped!
deannotate/source-properties
<module-ref> make-module-ref
module-ref-symbol module-ref-modname module-ref-public?
<lexical> make-lexical
lexical-name lexical-gensym
strip-expansion-structures))
(define <annotation>
(make-vtable "prprpw"
(lambda (struct port)
(display "#<annotated " port)
(display (struct-ref struct 0) port)
(display ">" port))))
(define (annotation? x)
(and (struct? x) (eq? (struct-vtable x) <annotation>)))
(define (make-annotation e s . stripped?)
(if (null? stripped?)
(make-struct <annotation> 0 e s #f)
(apply make-struct <annotation> 0 e s stripped?)))
(define (annotation-expression a)
(struct-ref a 0))
(define (annotation-source a)
(struct-ref a 1))
(define (annotation-stripped a)
(struct-ref a 2))
(define (set-annotation-stripped! a stripped?)
(struct-set! a 2 stripped?))
(define (annotate e)
(let ((p (if (pair? e) (source-properties e) #f))
(out (cond ((and (list? e) (not (null? e)))
(map annotate e))
((pair? e)
(cons (annotate (car e)) (annotate (cdr e))))
(else e))))
(if (pair? p)
(make-annotation out p #f)
out)))
(define (deannotate e)
(cond ((list? e)
(map deannotate e))
((pair? e)
(cons (deannotate (car e)) (deannotate (cdr e))))
((annotation? e) (deannotate (annotation-expression e)))
(else e)))
(define (deannotate/source-properties e)
(cond ((list? e)
(map deannotate/source-properties e))
((pair? e)
(cons (deannotate/source-properties (car e))
(deannotate/source-properties (cdr e))))
((annotation? e)
(let ((e (deannotate/source-properties (annotation-expression e)))
(source (annotation-source e)))
(if (pair? e)
(set-source-properties! e source))
e))
(else e)))
(define <module-ref>
(make-vtable "prprpr"
(lambda (struct port)
(display "#<" port)
(display (if (module-ref-public? struct) "@ " "@@ ") port)
(display (module-ref-modname struct) port)
(display " " port)
(display (module-ref-symbol struct) port)
(display ">" port))))
(define (module-ref? x)
(and (struct? x) (eq? (struct-vtable x) <module-ref>)))
(define (make-module-ref modname symbol public?)
(make-struct <module-ref> 0 modname symbol public?))
(define (module-ref-modname a)
(struct-ref a 0))
(define (module-ref-symbol a)
(struct-ref a 1))
(define (module-ref-public? a)
(struct-ref a 2))
(define <lexical>
(make-vtable "prpr"
(lambda (struct port)
(display "#<lexical " port)
(display (lexical-name struct) port)
(display "/" port)
(display (lexical-gensym struct) port)
(display ">" port))))
(define (lexical? x)
(and (struct? x) (eq? (struct-vtable x) <lexical>)))
(define (make-lexical name gensym)
(make-struct <lexical> 0 name gensym))
(define (lexical-name a)
(struct-ref a 0))
(define (lexical-gensym a)
(struct-ref a 1))
(define (strip-expansion-structures e)
(cond ((list? e)
(map strip-expansion-structures e))
((pair? e)
(cons (strip-expansion-structures (car e))
(strip-expansion-structures (cdr e))))
((annotation? e)
(let ((e (strip-expansion-structures (annotation-expression e)))
(source (annotation-source e)))
(if (pair? e)
(set-source-properties! e source))
e))
((module-ref? e)
(cond
((or (not (module-ref-modname e))
(eq? (module-ref-modname e)
(module-name (current-module)))
(and (not (module-ref-public? e))
(not (module-variable
(resolve-module (module-ref-modname e))
(module-ref-symbol e)))))
(module-ref-symbol e))
(else
`(,(if (module-ref-public? e) '@ '@@)
,(module-ref-modname e)
,(module-ref-symbol e)))))
((lexical? e)
(lexical-gensym e))
((record? e)
(error "unexpected record in expansion" e))
(else e)))

4
module/ice-9/match.scm
View file

@ -194,6 +194,6 @@
(define match:runtime-structures #f)
(define match:set-runtime-structures (lambda (v) (set! match:runtime-structures v)))
(define match:primitive-vector? vector?)
(defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lambda () #t)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda () #t)) ((lambda () #f)))))) (selector-name (lambda (x) (if (symbol? x) ((lambda () x)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))) ((lambda (s) s) (car x)) (match:error x))))) (mutator-name (lambda (x) (if (symbol? x) ((lambda () #f)) (if (and (pair? x) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda (s) s) (cadr x)) (match:error x))))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1))))) (let ((g296 (lambda () (match:syntax-err (quasiquote ((unquote defstruct) (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (symbol? (car args)) (pair? (cdr args)) (symbol? (cadr args)) (pair? (cddr args)) (symbol? (caddr args)) (list? (cdddr args))) (let g298 ((g299 (cdddr args)) (g297 (quote ()))) (if (null? g299) ((lambda (name constructor predicate fields) (let* ((selectors (map selector-name fields)) (mutators (map mutator-name fields)) (tag (if match:runtime-structures (gensym) (quasiquote (quote (unquote (match:make-structure-tag name)))))) (vectorP (cond ((eq? match:structure-control (quote disjoint)) (quote match:primitive-vector?)) ((eq? match:structure-control (quote vector)) (quote vector?))))) (cond ((eq? match:structure-control (quote disjoint)) (if (eq? vector? match:primitive-vector?) (set! vector? (lambda (v) (and (match:primitive-vector? v) (or (zero? (vector-length v)) (not (symbol? (vector-ref v 0))) (not (match:structure? (vector-ref v 0)))))))) (if (not (memq predicate match:disjoint-predicates)) (set! match:disjoint-predicates (cons predicate match:disjoint-predicates)))) ((eq? match:structure-control (quote vector)) (if (not (memq predicate match:vector-structures)) (set! match:vector-structures (cons predicate match:vector-structures)))) (else (match:syntax-err (quote (vector disjoint)) "invalid value for match:structure-control, legal values are"))) (quasiquote (begin (unquote-splicing (if match:runtime-structures (quasiquote ((define (unquote tag) (match:make-structure-tag (quote (unquote name)))))) (quote ()))) (define (unquote constructor) (lambda (unquote selectors) (vector (unquote tag) (unquote-splicing selectors)))) (define (unquote predicate) (lambda (obj) (and ((unquote vectorP) obj) (= (vector-length obj) (unquote (+ 1 (length selectors)))) (eq? (vector-ref obj 0) (unquote tag))))) (unquote-splicing (filter-map-with-index (lambda (n i) (quasiquote (define (unquote n) (lambda (obj) (vector-ref obj (unquote i)))))) selectors)) (unquote-splicing (filter-map-with-index (lambda (n i) (and n (quasiquote (define (unquote n) (lambda (obj newval) (vector-set! obj (unquote i) newval)))))) mutators)))))) (car args) (cadr args) (caddr args) (reverse g297)) (if (field? (car g299)) (g298 (cdr g299) (cons (car g299) g297)) (g296)))) (g296)))))
(defmacro defstruct args (let ((field? (lambda (x) (if (symbol? x) ((lambda () #t)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda () #t)) ((lambda () #f)))))) (selector-name (lambda (x) (if (symbol? x) ((lambda () x)) (if (and (pair? x) (symbol? (car x)) (pair? (cdr x)) (null? (cddr x))) ((lambda (s) s) (car x)) (match:error x))))) (mutator-name (lambda (x) (if (symbol? x) ((lambda () #f)) (if (and (pair? x) (pair? (cdr x)) (symbol? (cadr x)) (null? (cddr x))) ((lambda (s) s) (cadr x)) (match:error x))))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1))))) (let ((g296 (lambda () (match:syntax-err (quasiquote (defstruct (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (symbol? (car args)) (pair? (cdr args)) (symbol? (cadr args)) (pair? (cddr args)) (symbol? (caddr args)) (list? (cdddr args))) (let g298 ((g299 (cdddr args)) (g297 (quote ()))) (if (null? g299) ((lambda (name constructor predicate fields) (let* ((selectors (map selector-name fields)) (mutators (map mutator-name fields)) (tag (if match:runtime-structures (gensym) (quasiquote (quote (unquote (match:make-structure-tag name)))))) (vectorP (cond ((eq? match:structure-control (quote disjoint)) (quote match:primitive-vector?)) ((eq? match:structure-control (quote vector)) (quote vector?))))) (cond ((eq? match:structure-control (quote disjoint)) (if (eq? vector? match:primitive-vector?) (set! vector? (lambda (v) (and (match:primitive-vector? v) (or (zero? (vector-length v)) (not (symbol? (vector-ref v 0))) (not (match:structure? (vector-ref v 0)))))))) (if (not (memq predicate match:disjoint-predicates)) (set! match:disjoint-predicates (cons predicate match:disjoint-predicates)))) ((eq? match:structure-control (quote vector)) (if (not (memq predicate match:vector-structures)) (set! match:vector-structures (cons predicate match:vector-structures)))) (else (match:syntax-err (quote (vector disjoint)) "invalid value for match:structure-control, legal values are"))) (quasiquote (begin (unquote-splicing (if match:runtime-structures (quasiquote ((define (unquote tag) (match:make-structure-tag (quote (unquote name)))))) (quote ()))) (define (unquote constructor) (lambda (unquote selectors) (vector (unquote tag) (unquote-splicing selectors)))) (define (unquote predicate) (lambda (obj) (and ((unquote vectorP) obj) (= (vector-length obj) (unquote (+ 1 (length selectors)))) (eq? (vector-ref obj 0) (unquote tag))))) (unquote-splicing (filter-map-with-index (lambda (n i) (quasiquote (define (unquote n) (lambda (obj) (vector-ref obj (unquote i)))))) selectors)) (unquote-splicing (filter-map-with-index (lambda (n i) (and n (quasiquote (define (unquote n) (lambda (obj newval) (vector-set! obj (unquote i) newval)))))) mutators)))))) (car args) (cadr args) (caddr args) (reverse g297)) (if (field? (car g299)) (g298 (cdr g299) (cons (car g299) g297)) (g296)))) (g296)))))
(defmacro define-structure args (let ((g311 (lambda () (match:syntax-err (quasiquote (define-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (and (pair? (cdr args)) (list? (cadr args))) (let g308 ((g309 (cadr args)) (g307 (quote ())) (g306 (quote ()))) (if (null? g309) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let ((mk-id (lambda (id) (if (and (pair? id) (equal? (car id) (quote @)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda (x) x) (cadr id)) ((lambda () (quasiquote (! (unquote id))))))))) (quasiquote (define-const-structure ((unquote name) (unquote-splicing (map mk-id id1))) (unquote (map (lambda (id v) (quasiquote ((unquote (mk-id id)) (unquote v)))) id2 val)))))) (caar args) (cdar args) (reverse g306) (reverse g307)) (g311)) (if (and (pair? (car g309)) (pair? (cdar g309)) (null? (cddar g309))) (g308 (cdr g309) (cons (cadar g309) g307) (cons (caar g309) g306)) (g311)))) (g311))) (g311))))
(defmacro define-const-structure args (let ((field? (lambda (id) (if (symbol? id) ((lambda () #t)) (if (and (pair? id) (equal? (car id) (quote !)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda () #t)) ((lambda () #f)))))) (field-name (lambda (x) (if (symbol? x) x (cadr x)))) (has-mutator? (lambda (x) (not (symbol? x)))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l)))))) (let ((g335 (lambda () (match:syntax-err (quasiquote (define-const-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-const-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (symbol? (caar args)) (let g328 ((g329 (cdar args)) (g327 (quote ()))) (if (null? g329) (if (and (pair? (cdr args)) (list? (cadr args))) (let g332 ((g333 (cadr args)) (g331 (quote ())) (g330 (quote ()))) (if (null? g333) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let* ((id1id2 (append id1 id2)) (raw-constructor (symbol-append (quote make-raw-) name)) (constructor (symbol-append (quote make-) name)) (predicate (symbol-append name (quote ?)))) (quasiquote (begin ((unquote defstruct) (unquote name) (unquote raw-constructor) (unquote predicate) (unquote-splicing (filter-map-with-index (lambda (arg i) (if (has-mutator? arg) (quasiquote ((unquote (symbol-append name (quote -) i)) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))) (symbol-append name (quote -) i))) id1id2))) (unquote (if (null? id2) (quasiquote (define (unquote constructor) (unquote raw-constructor))) (let* ((make-fresh (lambda (x) (if (eq? (quote _) x) (gensym) x))) (names1 (map make-fresh (map field-name id1))) (names2 (map make-fresh (map field-name id2)))) (quasiquote (define (unquote constructor) (lambda (unquote names1) (let* (unquote (map list names2 val)) ((unquote raw-constructor) (unquote-splicing names1) (unquote-splicing names2))))))))) (unquote-splicing (filter-map-with-index (lambda (field i) (if (eq? (field-name field) (quote _)) #f (quasiquote (define (unquote (symbol-append name (quote -) (field-name field))) (unquote (symbol-append name (quote -) i)))))) id1id2)) (unquote-splicing (filter-map-with-index (lambda (field i) (if (or (eq? (field-name field) (quote _)) (not (has-mutator? field))) #f (quasiquote (define (unquote (symbol-append (quote set-) name (quote -) (field-name field) (quote !))) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))))) id1id2)))))) (caar args) (reverse g327) (reverse g330) (reverse g331)) (g335)) (if (and (pair? (car g333)) (field? (caar g333)) (pair? (cdar g333)) (null? (cddar g333))) (g332 (cdr g333) (cons (cadar g333) g331) (cons (caar g333) g330)) (g335)))) (g335)) (if (field? (car g329)) (g328 (cdr g329) (cons (car g329) g327)) (g335)))) (g335))) (g335)))))
(defmacro define-const-structure args (let ((field? (lambda (id) (if (symbol? id) ((lambda () #t)) (if (and (pair? id) (equal? (car id) (quote !)) (pair? (cdr id)) (symbol? (cadr id)) (null? (cddr id))) ((lambda () #t)) ((lambda () #f)))))) (field-name (lambda (x) (if (symbol? x) x (cadr x)))) (has-mutator? (lambda (x) (not (symbol? x)))) (filter-map-with-index (lambda (f l) (letrec ((mapi (lambda (l i) (cond ((null? l) (quote ())) ((f (car l) i) => (lambda (x) (cons x (mapi (cdr l) (+ 1 i))))) (else (mapi (cdr l) (+ 1 i))))))) (mapi l 1)))) (symbol-append (lambda l (string->symbol (apply string-append (map (lambda (x) (cond ((symbol? x) (symbol->string x)) ((number? x) (number->string x)) (else x))) l)))))) (let ((g335 (lambda () (match:syntax-err (quasiquote (define-const-structure (unquote-splicing args))) "syntax error in")))) (if (and (pair? args) (pair? (car args)) (list? (cdar args))) (if (null? (cdr args)) ((lambda (name id1) (quasiquote (define-const-structure ((unquote name) (unquote-splicing id1)) ()))) (caar args) (cdar args)) (if (symbol? (caar args)) (let g328 ((g329 (cdar args)) (g327 (quote ()))) (if (null? g329) (if (and (pair? (cdr args)) (list? (cadr args))) (let g332 ((g333 (cadr args)) (g331 (quote ())) (g330 (quote ()))) (if (null? g333) (if (null? (cddr args)) ((lambda (name id1 id2 val) (let* ((id1id2 (append id1 id2)) (raw-constructor (symbol-append (quote make-raw-) name)) (constructor (symbol-append (quote make-) name)) (predicate (symbol-append name (quote ?)))) (quasiquote (begin (defstruct (unquote name) (unquote raw-constructor) (unquote predicate) (unquote-splicing (filter-map-with-index (lambda (arg i) (if (has-mutator? arg) (quasiquote ((unquote (symbol-append name (quote -) i)) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))) (symbol-append name (quote -) i))) id1id2))) (unquote (if (null? id2) (quasiquote (define (unquote constructor) (unquote raw-constructor))) (let* ((make-fresh (lambda (x) (if (eq? (quote _) x) (gensym) x))) (names1 (map make-fresh (map field-name id1))) (names2 (map make-fresh (map field-name id2)))) (quasiquote (define (unquote constructor) (lambda (unquote names1) (let* (unquote (map list names2 val)) ((unquote raw-constructor) (unquote-splicing names1) (unquote-splicing names2))))))))) (unquote-splicing (filter-map-with-index (lambda (field i) (if (eq? (field-name field) (quote _)) #f (quasiquote (define (unquote (symbol-append name (quote -) (field-name field))) (unquote (symbol-append name (quote -) i)))))) id1id2)) (unquote-splicing (filter-map-with-index (lambda (field i) (if (or (eq? (field-name field) (quote _)) (not (has-mutator? field))) #f (quasiquote (define (unquote (symbol-append (quote set-) name (quote -) (field-name field) (quote !))) (unquote (symbol-append (quote set-) name (quote -) i (quote !))))))) id1id2)))))) (caar args) (reverse g327) (reverse g330) (reverse g331)) (g335)) (if (and (pair? (car g333)) (field? (caar g333)) (pair? (cdar g333)) (null? (cddar g333))) (g332 (cdr g333) (cons (cadar g333) g331) (cons (caar g333) g330)) (g335)))) (g335)) (if (field? (car g329)) (g328 (cdr g329) (cons (car g329) g327)) (g335)))) (g335))) (g335)))))

3
module/ice-9/networking.scm
View file

@ -17,6 +17,9 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
(eval-when (compile)
(set-current-module (resolve-module '(guile))))
(define (gethostbyaddr addr) (gethost addr))
(define (gethostbyname name) (gethost name))

1
module/ice-9/null.scm
View file

@ -18,7 +18,6 @@
;;;; The null environment - only syntactic bindings
(define-module (ice-9 null)
:use-module (ice-9 syncase)
:re-export-syntax (define quote lambda if set!
cond case and or

1
module/ice-9/occam-channel.scm
View file

@ -17,7 +17,6 @@
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (ice-9 occam-channel)
#:use-syntax (ice-9 syncase)
#:use-module (oop goops)
#:use-module (ice-9 threads)
#:export-syntax (alt

3
module/ice-9/posix.scm
View file

@ -17,6 +17,9 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
(eval-when (compile)
(set-current-module (resolve-module '(guile))))
(define (stat:dev f) (vector-ref f 0))
(define (stat:ino f) (vector-ref f 1))
(define (stat:mode f) (vector-ref f 2))

24
module/ice-9/psyntax-pp.scm
View file

File diff suppressed because one or more lines are too long

987
module/ice-9/psyntax.scm
View file

File diff suppressed because it is too large Load diff

28
module/ice-9/r4rs.scm
View file

@ -17,6 +17,9 @@
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(eval-when (compile)
(set-current-module (resolve-module '(guile))))
;;;; apply and call-with-current-continuation
@ -186,28 +189,3 @@ procedures, their behavior is implementation dependent."
(lambda (p) (with-error-to-port p thunk))))
(define the-eof-object (call-with-input-string "" (lambda (p) (read-char p))))
;;;; Loading
(if (not (defined? '%load-verbosely))
(define %load-verbosely #f))
(define (assert-load-verbosity v) (set! %load-verbosely v))
(define (%load-announce file)
(if %load-verbosely
(with-output-to-port (current-error-port)
(lambda ()
(display ";;; ")
(display "loading ")
(display file)
(newline)
(force-output)))))
(set! %load-hook %load-announce)
(define (load name . reader)
(with-fluid* current-reader (and (pair? reader) (car reader))
(lambda ()
(start-stack 'load-stack
(primitive-load name)))))

2
module/ice-9/stack-catch.scm
View file

@ -40,4 +40,4 @@ this call to @code{catch}."
(catch key
thunk
handler
pre-unwind-handler-dispatch))
default-pre-unwind-handler))

200
module/ice-9/syncase.scm
View file

@ -17,197 +17,15 @@
(define-module (ice-9 syncase)
:use-module (ice-9 expand-support)
:use-module (ice-9 debug)
:use-module (ice-9 threads)
:export-syntax (sc-macro define-syntax define-syntax-public
fluid-let-syntax
identifier-syntax let-syntax
letrec-syntax syntax syntax-case syntax-rules
with-syntax
include)
:export (sc-expand sc-expand3 install-global-transformer
syntax-dispatch syntax-error bound-identifier=?
datum->syntax-object free-identifier=?
generate-temporaries identifier? syntax-object->datum
void syncase)
:replace (eval eval-when))
)
(define (annotation? x) #f)
(define sc-macro
(procedure->memoizing-macro
(lambda (exp env)
(save-module-excursion
(lambda ()
;; Because memoization happens lazily, env's module isn't
;; necessarily the current module.
(set-current-module (eval-closure-module (car (last-pair env))))
(strip-expansion-structures (sc-expand exp)))))))
;;; Exported variables
(define sc-expand #f)
(define sc-expand3 #f)
(define sc-chi #f)
(define install-global-transformer #f)
(define syntax-dispatch #f)
(define syntax-error #f)
(define bound-identifier=? #f)
(define datum->syntax-object #f)
(define free-identifier=? #f)
(define generate-temporaries #f)
(define identifier? #f)
(define syntax-object->datum #f)
(define primitive-syntax '(quote lambda letrec if set! begin define or
and let let* cond do quasiquote unquote
unquote-splicing case @ @@))
(for-each (lambda (symbol)
(set-symbol-property! symbol 'primitive-syntax #t))
primitive-syntax)
;;; Hooks needed by the syntax-case macro package
(define (void) *unspecified*)
(define andmap
(lambda (f first . rest)
(or (null? first)
(if (null? rest)
(let andmap ((first first))
(let ((x (car first)) (first (cdr first)))
(if (null? first)
(f x)
(and (f x) (andmap first)))))
(let andmap ((first first) (rest rest))
(let ((x (car first))
(xr (map car rest))
(first (cdr first))
(rest (map cdr rest)))
(if (null? first)
(apply f (cons x xr))
(and (apply f (cons x xr)) (andmap first rest)))))))))
(define (error who format-string why what)
(start-stack 'syncase-stack
(scm-error 'misc-error
who
"~A ~S"
(list why what)
'())))
(define the-syncase-module (current-module))
(define guile-macro
(cons 'external-macro
(lambda (e r w s mod)
(let ((e (syntax-object->datum e)))
(if (symbol? e)
;; pass the expression through
e
(let* ((mod (resolve-module mod))
(m (module-ref mod (car e))))
(if (eq? (macro-type m) 'syntax)
;; pass the expression through
e
;; perform Guile macro transform
(let ((e ((macro-transformer m)
(strip-expansion-structures e)
(append r (list (module-eval-closure mod))))))
(if (variable? e)
e
(if (null? r)
(sc-expand e)
(sc-chi e r w (module-name mod))))))))))))
(define generated-symbols (make-weak-key-hash-table 1019))
;; We define our own gensym here because the Guile built-in one will
;; eventually produce uninterned and unreadable symbols (as needed for
;; safe macro expansions) and will the be inappropriate for dumping to
;; pssyntax.pp.
;;
;; syncase is supposed to only require that gensym produce unique
;; readable symbols, and they only need be unique with respect to
;; multiple calls to gensym, not globally unique.
;;
(define gensym
(let ((counter 0))
(define next-id
(if (provided? 'threads)
(let ((symlock (make-mutex)))
(lambda ()
(let ((result #f))
(with-mutex symlock
(set! result counter)
(set! counter (+ counter 1)))
result)))
;; faster, non-threaded case.
(lambda ()
(let ((result counter))
(set! counter (+ counter 1))
result))))
;; actual gensym body code.
(lambda (. rest)
(let* ((next-val (next-id))
(valstr (number->string next-val)))
(cond
((null? rest)
(string->symbol (string-append "syntmp-" valstr)))
((null? (cdr rest))
(string->symbol (string-append "syntmp-" (car rest) "-" valstr)))
(else
(error
(string-append
"syncase's gensym expected 0 or 1 arguments, got "
(length rest)))))))))
;;; Load the preprocessed code
(let ((old-debug #f)
(old-read #f))
(dynamic-wind (lambda ()
(set! old-debug (debug-options))
(set! old-read (read-options)))
(lambda ()
(debug-disable 'debug 'procnames)
(read-disable 'positions)
(load-from-path "ice-9/psyntax-pp"))
(lambda ()
(debug-options old-debug)
(read-options old-read))))
(define internal-eval (nested-ref the-scm-module '(%app modules guile eval)))
(define (eval x environment)
(internal-eval (if (and (pair? x)
(equal? (car x) "noexpand"))
(strip-expansion-structures (cadr x))
(strip-expansion-structures (sc-expand x)))
environment))
(issue-deprecation-warning
"Syntax-case macros are now a part of Guile core; importing (ice-9 syncase) is no longer necessary.")
;;; Hack to make syncase macros work in the slib module
(let ((m (nested-ref the-root-module '(%app modules ice-9 slib))))
(if m
(set-object-property! (module-local-variable m 'define)
'*sc-expander*
'(define))))
(define (syncase exp)
(strip-expansion-structures (sc-expand exp)))
(set-module-transformer! the-syncase-module syncase)
(define-syntax define-syntax-public
(syntax-rules ()
((_ name rules ...)
(begin
;(eval-case ((load-toplevel) (export-syntax name)))
(define-syntax name rules ...)))))
;; FIXME wingo is this still necessary?
;; (let ((m (nested-ref the-root-module '(%app modules ice-9 slib))))
;; (if m
;; (set-object-property! (module-local-variable m 'define)
;; '*sc-expander*
;; '(define))))

114
module/ice-9/threads.scm
View file

@ -32,21 +32,71 @@
;;; Code:
(define-module (ice-9 threads)
:export (par-map
:export (begin-thread
parallel
letpar
make-thread
with-mutex
monitor
par-map
par-for-each
n-par-map
n-par-for-each
n-for-each-par-map
%thread-handler)
:export-syntax (begin-thread
parallel
letpar
make-thread
with-mutex
monitor))
%thread-handler))
;;; Macros first, so that the procedures expand correctly.
(define-syntax begin-thread
(syntax-rules ()
((_ e0 e1 ...)
(call-with-new-thread
(lambda () e0 e1 ...)
%thread-handler))))
(define-syntax parallel
(lambda (x)
(syntax-case x ()
((_ e0 ...)
(with-syntax (((tmp0 ...) (generate-temporaries (syntax (e0 ...)))))
(syntax
(let ((tmp0 (begin-thread e0))
...)
(values (join-thread tmp0) ...))))))))
(define-syntax letpar
(syntax-rules ()
((_ ((v e) ...) b0 b1 ...)
(call-with-values
(lambda () (parallel e ...))
(lambda (v ...)
b0 b1 ...)))))
(define-syntax make-thread
(syntax-rules ()
((_ proc arg ...)
(call-with-new-thread
(lambda () (proc arg ...))
%thread-handler))))
(define-syntax with-mutex
(syntax-rules ()
((_ m e0 e1 ...)
(let ((x m))
(dynamic-wind
(lambda () (lock-mutex x))
(lambda () (begin e0 e1 ...))
(lambda () (unlock-mutex x)))))))
(define-syntax monitor
(syntax-rules ()
((_ first rest ...)
(with-mutex (make-mutex)
first rest ...))))
(define (par-mapper mapper)
(lambda (proc . arglists)
(mapper join-thread
@ -171,52 +221,4 @@ of applying P-PROC on ARGLISTS."
;;; Set system thread handler
(define %thread-handler thread-handler)
; --- MACROS -------------------------------------------------------
(define-macro (begin-thread . forms)
(if (null? forms)
'(begin)
`(call-with-new-thread
(lambda ()
,@forms)
%thread-handler)))
(define-macro (parallel . forms)
(cond ((null? forms) '(values))
((null? (cdr forms)) (car forms))
(else
(let ((vars (map (lambda (f)
(make-symbol "f"))
forms)))
`((lambda ,vars
(values ,@(map (lambda (v) `(join-thread ,v)) vars)))
,@(map (lambda (form) `(begin-thread ,form)) forms))))))
(define-macro (letpar bindings . body)
(cond ((or (null? bindings) (null? (cdr bindings)))
`(let ,bindings ,@body))
(else
(let ((vars (map car bindings)))
`((lambda ,vars
((lambda ,vars ,@body)
,@(map (lambda (v) `(join-thread ,v)) vars)))
,@(map (lambda (b) `(begin-thread ,(cadr b))) bindings))))))
(define-macro (make-thread proc . args)
`(call-with-new-thread
(lambda ()
(,proc ,@args))
%thread-handler))
(define-macro (with-mutex m . body)
`(dynamic-wind
(lambda () (lock-mutex ,m))
(lambda () (begin ,@body))
(lambda () (unlock-mutex ,m))))
(define-macro (monitor first . rest)
`(with-mutex ,(make-mutex)
(begin
,first ,@rest)))
;;; threads.scm ends here

2
module/ice-9/time.scm
View file

@ -53,6 +53,6 @@
result))
(define-macro (time exp)
`(,time-proc (lambda () ,exp)))
`((@@ (ice-9 time) time-proc) (lambda () ,exp)))
;;; time.scm ends here

2
module/language/assembly/disassemble.scm
View file

@ -82,7 +82,7 @@
(if (program? x)
(begin (display "----------------------------------------\n")
(disassemble x))))
(cddr (vector->list objs))))))
(cdr (vector->list objs))))))
(else
(error "bad load-program form" asm))))

1
module/language/ecmascript/spec.scm
View file

@ -33,7 +33,6 @@
#:title "Guile ECMAScript"
#:version "3.0"
#:reader (lambda () (read-ecmascript/1 (current-input-port)))
#:read-file read-ecmascript
#:compilers `((ghil . ,compile-ghil))
;; a pretty-printer would be interesting.
#:printer write

14
module/language/ghil/compile-glil.scm
View file

@ -187,7 +187,7 @@
(define (make-glil-var op env var)
(case (ghil-var-kind var)
((argument)
(make-glil-argument op (ghil-var-index var)))
(make-glil-local op (ghil-var-index var)))
((local)
(make-glil-local op (ghil-var-index var)))
((external)
@ -217,7 +217,9 @@
(set! stack (cons code stack))
(if loc (set! stack (cons (make-glil-source loc) stack))))
(define (var->binding var)
(list (ghil-var-name var) (ghil-var-kind var) (ghil-var-index var)))
(list (ghil-var-name var) (let ((kind (ghil-var-kind var)))
(case kind ((argument) 'local) (else kind)))
(ghil-var-index var)))
(define (push-bindings! loc vars)
(if (not (null? vars))
(push-code! loc (make-glil-bind (map var->binding vars)))))
@ -496,7 +498,7 @@
(locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars))
(exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars))
(nargs (allocate-indices-linearly! vars))
(nlocs (allocate-locals! locs body))
(nlocs (allocate-locals! locs body nargs))
(nexts (allocate-indices-linearly! exts)))
;; meta bindings
(push-bindings! #f vars)
@ -509,7 +511,7 @@
(let ((v (car l)))
(case (ghil-var-kind v)
((external)
(push-code! #f (make-glil-argument 'ref n))
(push-code! #f (make-glil-local 'ref n))
(push-code! #f (make-glil-external 'set 0 (ghil-var-index v)))))))
;; compile body
(comp body #t #f)
@ -523,8 +525,8 @@
((null? l) n)
(let ((v (car l))) (set! (ghil-var-index v) n))))
(define (allocate-locals! vars body)
(let ((free '()) (nlocs 0))
(define (allocate-locals! vars body nargs)
(let ((free '()) (nlocs nargs))
(define (allocate! var)
(cond
((pair? free)

9
module/language/glil.scm
View file

@ -44,9 +44,6 @@
<glil-const> make-glil-const glil-const?
glil-const-obj
<glil-argument> make-glil-argument glil-argument?
glil-argument-op glil-argument-index
<glil-local> make-glil-local glil-local?
glil-local-op glil-local-index
@ -87,7 +84,6 @@
(<glil-void>)
(<glil-const> obj)
;; Variables
(<glil-argument> op index)
(<glil-local> op index)
(<glil-external> op depth index)
(<glil-toplevel> op name)
@ -125,13 +121,12 @@
((source ,props) (make-glil-source props))
((void) (make-glil-void))
((const ,obj) (make-glil-const obj))
((argument ,op ,index) (make-glil-argument op index))
((local ,op ,index) (make-glil-local op index))
((external ,op ,depth ,index) (make-glil-external op depth index))
((toplevel ,op ,name) (make-glil-toplevel op name))
((module public ,op ,mod ,name) (make-glil-module op mod name #t))
((module private ,op ,mod ,name) (make-glil-module op mod name #f))
((label ,label) (make-label ,label))
((label ,label) (make-label label))
((branch ,inst ,label) (make-glil-branch inst label))
((call ,inst ,nargs) (make-glil-call inst nargs))
((mv-call ,nargs ,ra) (make-glil-mv-call nargs ra))
@ -150,8 +145,6 @@
((<glil-void>) `(void))
((<glil-const> obj) `(const ,obj))
;; variables
((<glil-argument> op index)
`(argument ,op ,index))
((<glil-local> op index)
`(local ,op ,index))
((<glil-external> op depth index)

31
module/language/glil/compile-assembly.scm
View file

@ -83,16 +83,15 @@
(define (make-closed-binding open-binding start end)
(make-binding (car open-binding) (cadr open-binding)
(caddr open-binding) start end))
(define (open-binding bindings vars nargs start)
(define (open-binding bindings vars start)
(cons
(acons start
(map
(lambda (v)
(pmatch v
((,name argument ,i) (make-open-binding name #f i))
((,name local ,i) (make-open-binding name #f (+ nargs i)))
((,name local ,i) (make-open-binding name #f i))
((,name external ,i) (make-open-binding name #t i))
(else (error "unknown binding type" name type))))
(else (error "unknown binding type" v))))
vars)
(car bindings))
(cdr bindings)))
@ -129,13 +128,13 @@
(define (compile-assembly glil)
(receive (code . _)
(glil->assembly glil 0 '() '(()) '() '() #f -1)
(glil->assembly glil '() '(()) '() '() #f -1)
(car code)))
(define (make-object-table objects)
(and (not (null? objects))
(list->vector (cons #f objects))))
(define (glil->assembly glil nargs nexts-stack bindings
(define (glil->assembly glil nexts-stack bindings
source-alist label-alist object-alist addr)
(define (emit-code x)
(values (map assembly-pack x) bindings source-alist label-alist object-alist))
@ -159,7 +158,7 @@
addr))
(else
(receive (subcode bindings source-alist label-alist object-alist)
(glil->assembly (car body) nargs nexts-stack bindings
(glil->assembly (car body) nexts-stack bindings
source-alist label-alist object-alist addr)
(lp (cdr body) (append (reverse subcode) code)
bindings source-alist label-alist object-alist
@ -196,14 +195,14 @@
((<glil-bind> vars)
(values '()
(open-binding bindings vars nargs addr)
(open-binding bindings vars addr)
source-alist
label-alist
object-alist))
((<glil-mv-bind> vars rest)
(values `((truncate-values ,(length vars) ,(if rest 1 0)))
(open-binding bindings vars nargs addr)
(open-binding bindings vars addr)
source-alist
label-alist
object-alist))
@ -238,16 +237,11 @@
(emit-code/object `((object-ref ,i))
object-alist)))))
((<glil-argument> op index)
((<glil-local> op index)
(emit-code (if (eq? op 'ref)
`((local-ref ,index))
`((local-set ,index)))))
((<glil-local> op index)
(emit-code (if (eq? op 'ref)
`((local-ref ,(+ nargs index)))
`((local-set ,(+ nargs index))))))
((<glil-external> op depth index)
(emit-code (let lp ((d depth) (n 0) (stack nexts-stack))
(if (> d 0)
@ -318,7 +312,12 @@
(error "Unknown instruction:" inst))
(let ((pops (instruction-pops inst)))
(cond ((< pops 0)
(emit-code `((,inst ,nargs))))
(case (instruction-length inst)
((1) (emit-code `((,inst ,nargs))))
((2) (emit-code `((,inst ,(quotient nargs 256)
,(modulo nargs 256)))))
(else (error "Unknown length for variable-arg instruction:"
inst (instruction-length inst)))))
((= pops nargs)
(emit-code `((,inst))))
(else

8
module/language/glil/decompile-assembly.scm
View file

@ -175,15 +175,11 @@
(1+ pos)))
((local-ref ,n)
(lp (cdr in) (cons *placeholder* stack)
(cons (if (< n nargs)
(make-glil-argument 'ref n)
(make-glil-local 'ref (- n nargs)))
(cons (make-glil-local 'ref n)
out) (+ pos 2)))
((local-set ,n)
(lp (cdr in) (cdr stack)
(cons (if (< n nargs)
(make-glil-argument 'set n)
(make-glil-local 'set (- n nargs)))
(cons (make-glil-local 'set n)
(emit-constants (list-head stack 1) out))
(+ pos 2)))
((br-if-not ,l)

37
module/language/scheme/amatch.scm
View file

@ -1,37 +0,0 @@
(define-module (language scheme amatch)
#:use-module (ice-9 syncase)
#:export (amatch apat))
;; FIXME: shouldn't have to export apat...
;; This is exactly the same as pmatch except that it unpacks annotations
;; as needed.
(define-syntax amatch
(syntax-rules (else guard)
((_ (op arg ...) cs ...)
(let ((v (op arg ...)))
(amatch v cs ...)))
((_ v) (if #f #f))
((_ v (else e0 e ...)) (begin e0 e ...))
((_ v (pat (guard g ...) e0 e ...) cs ...)
(let ((fk (lambda () (amatch v cs ...))))
(apat v pat
(if (and g ...) (begin e0 e ...) (fk))
(fk))))
((_ v (pat e0 e ...) cs ...)
(let ((fk (lambda () (amatch v cs ...))))
(apat v pat (begin e0 e ...) (fk))))))
(define-syntax apat
(syntax-rules (_ quote unquote)
((_ v _ kt kf) kt)
((_ v () kt kf) (if (null? v) kt kf))
((_ v (quote lit) kt kf)
(if (equal? v (quote lit)) kt kf))
((_ v (unquote var) kt kf) (let ((var v)) kt))
((_ v (x . y) kt kf)
(if (apair? v)
(let ((vx (acar v)) (vy (acdr v)))
(apat vx x (apat vy y kt kf) kf))
kf))
((_ v lit kt kf) (if (eq? v (quote lit)) kt kf))))

48
module/language/scheme/compile-ghil.scm
View file

@ -27,13 +27,11 @@
#:use-module (system vm objcode)
#:use-module (ice-9 receive)
#:use-module (ice-9 optargs)
#:use-module (ice-9 expand-support)
#:use-module ((ice-9 syncase) #:select (sc-macro))
#:use-module (language tree-il)
#:use-module ((system base compile) #:select (syntax-error))
#:export (compile-ghil translate-1
*translate-table* define-scheme-translator))
;;; environment := #f
;;; | MODULE
;;; | COMPILE-ENV
@ -70,12 +68,14 @@
(and=> (cenv-module e) set-current-module)
(call-with-ghil-environment (cenv-ghil-env e) '()
(lambda (env vars)
(let ((x (make-ghil-lambda env #f vars #f '()
(translate-1 env #f x)))
(cenv (make-cenv (current-module)
(ghil-env-parent env)
(if e (cenv-externals e) '()))))
(values x cenv cenv)))))))
(let ((x (tree-il->scheme
(sc-expand x 'c '(compile load eval)))))
(let ((x (make-ghil-lambda env #f vars #f '()
(translate-1 env #f x)))
(cenv (make-cenv (current-module)
(ghil-env-parent env)
(if e (cenv-externals e) '()))))
(values x cenv cenv))))))))
;;;
@ -104,9 +104,6 @@
(let* ((mod (current-module))
(val (cond
((symbol? head) (module-ref/safe mod head))
;; allow macros to be unquoted into the output of a macro
;; expansion
((macro? head) head)
((pmatch head
((@ ,modname ,sym)
(module-ref/safe (resolve-interface modname) sym))
@ -117,21 +114,6 @@
(cond
((hashq-ref *translate-table* val))
((defmacro? val)
(lambda (env loc exp)
(retrans (apply (defmacro-transformer val) (cdr exp)))))
((eq? val sc-macro)
;; syncase!
(let ((sc-expand3 (@@ (ice-9 syncase) sc-expand3)))
(lambda (env loc exp)
(retrans
(strip-expansion-structures
(sc-expand3 exp 'c '(compile load eval)))))))
((primitive-macro? val)
(syntax-error #f "unhandled primitive macro" head))
((macro? val)
(syntax-error #f "unknown kind of macro" head))
@ -180,7 +162,7 @@
(define-macro (define-scheme-translator sym . clauses)
`(hashq-set! (@ (language scheme compile-ghil) *translate-table*)
,sym
(module-ref (current-module) ',sym)
(lambda (e l exp)
(define (retrans x)
((@ (language scheme compile-ghil) translate-1)
@ -432,16 +414,6 @@
(,args
(-> (values (map retrans args)))))
(define-scheme-translator compile-time-environment
;; (compile-time-environment)
;; => (MODULE LEXICALS . EXTERNALS)
(()
(-> (inline 'cons
(list (retrans '(current-module))
(-> (inline 'cons
(list (-> (reified-env))
(-> (inline 'externals '()))))))))))
(define (lookup-apply-transformer proc)
(cond ((eq? proc values)
(lambda (e l args)

64
module/language/scheme/compile-tree-il.scm Normal file
View file

@ -0,0 +1,64 @@
;;; 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 compile-tree-il)
#:use-module (language tree-il)
#:export (compile-tree-il))
;;; environment := #f
;;; | MODULE
;;; | COMPILE-ENV
;;; compile-env := (MODULE LEXICALS . EXTERNALS)
(define (cenv-module env)
(cond ((not env) #f)
((module? env) env)
((and (pair? env) (module? (car env))) (car env))
(else (error "bad environment" env))))
(define (cenv-lexicals env)
(cond ((not env) '())
((module? env) '())
((pair? env) (cadr env))
(else (error "bad environment" env))))
(define (cenv-externals env)
(cond ((not env) '())
((module? env) '())
((pair? env) (cddr env))
(else (error "bad environment" env))))
(define (make-cenv module lexicals externals)
(cons module (cons lexicals externals)))
(define (location x)
(and (pair? x)
(let ((props (source-properties x)))
(and (not (null? props))
props))))
(define (compile-tree-il x e opts)
(save-module-excursion
(lambda ()
(and=> (cenv-module e) set-current-module)
(let* ((x (sc-expand x 'c '(compile load eval)))
(cenv (make-cenv (current-module)
(cenv-lexicals e) (cenv-externals e))))
(values x cenv cenv)))))

27
module/language/scheme/decompile-tree-il.scm Normal file
View file

@ -0,0 +1,27 @@
;;; Guile VM code converters
;; Copyright (C) 2001,2009 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 decompile-tree-il)
#:use-module (language tree-il)
#:export (decompile-tree-il))
(define (decompile-tree-il x env opts)
(values (tree-il->scheme x) env))

307
module/language/scheme/expand.scm
View file

@ -1,307 +0,0 @@
;;; 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 expand)
#:use-module (language scheme amatch)
#:use-module (ice-9 expand-support)
#:use-module (ice-9 optargs)
#:use-module ((ice-9 syncase) #:select (sc-macro))
#:use-module ((system base compile) #:select (syntax-error))
#:export (expand *expand-table* define-scheme-expander))
(define (aref x) (if (annotation? x) (annotation-expression x) x))
(define (apair? x) (pair? (aref x)))
(define (acar x) (car (aref x)))
(define (acdr x) (cdr (aref x)))
(define (acaar x) (acar (acar x)))
(define (acdar x) (acdr (acar x)))
(define (acadr x) (acar (acdr x)))
(define (acddr x) (acdr (acdr x)))
(define (aloc x) (and (annotation? x) (annotation-source x)))
(define (re-annotate x y)
(if (and (annotation? x) (not (annotation? y)))
(make-annotation y (annotation-source x))
y))
(define-macro (-> exp) `(re-annotate x ,exp))
(define* (expand x #:optional (mod (current-module)) (once? #f))
(define re-expand
(if once?
(lambda (x) x)
(lambda (x) (expand x mod once?))))
(let ((exp (if (annotation? x) (annotation-expression x) x)))
(cond
((pair? exp)
(let ((head (car exp)) (tail (cdr exp)))
(cond
;; allow macros to be unquoted into the output of a macro
;; expansion
((or (symbol? head) (macro? head))
(let ((val (cond
((macro? head) head)
((module-variable mod head)
=> (lambda (var)
;; unbound vars can happen if the module
;; definition forward-declared them
(and (variable-bound? var) (variable-ref var))))
(else #f))))
(cond
((hashq-ref *expand-table* val)
=> (lambda (expand1) (expand1 x re-expand)))
((defmacro? val)
(re-expand (-> (apply (defmacro-transformer val)
(deannotate tail)))))
((eq? val sc-macro)
;; syncase!
(let* ((eec (@@ (ice-9 syncase) expansion-eval-closure))
(sc-expand3 (@@ (ice-9 syncase) sc-expand3)))
(re-expand
(with-fluids ((eec (module-eval-closure mod)))
;; fixme -- use ewes fluid?
(sc-expand3 exp 'c '(compile load eval))))))
((primitive-macro? val)
(syntax-error (aloc x) "unhandled primitive macro" head))
((macro? val)
(syntax-error (aloc x) "unknown kind of macro" head))
(else
(-> (cons head (map re-expand tail)))))))
(else
(-> (map re-expand exp))))))
(else x))))
(define *expand-table* (make-hash-table))
(define-macro (define-scheme-expander sym . clauses)
`(hashq-set! (@ (language scheme expand) *expand-table*)
,sym
(lambda (x re-expand)
(define syntax-error (@ (system base compile) syntax-error))
(amatch (acdr x)
,@clauses
,@(if (assq 'else clauses) '()
`((else
(syntax-error (aloc x) (format #f "bad ~A" ',sym) x))))))))
(define-scheme-expander quote
;; (quote OBJ)
((,obj) x))
(define-scheme-expander quasiquote
;; (quasiquote OBJ)
((,obj)
(-> `(,'quasiquote
,(let lp ((x obj) (level 0))
(cond ((not (apair? x)) x)
;; FIXME: hygiene regarding imported , / ,@ rebinding
((memq (acar x) '(unquote unquote-splicing))
(amatch (acdr x)
((,obj)
(cond
((zero? level)
(-> `(,(acar x) ,(re-expand obj))))
(else
(-> `(,(acar x) ,(lp obj (1- level)))))))
(else (syntax-error (aloc x) (format #f "bad ~A" (acar x)) x))))
((eq? (acar x) 'quasiquote)
(amatch (acdr x)
((,obj) (-> `(,'quasiquote ,(lp obj (1+ level)))))
(else (syntax-error (aloc x) "bad quasiquote" x))))
(else (-> (cons (lp (acar x) level) (lp (acdr x) level))))))))))
(define-scheme-expander define
;; (define NAME VAL)
((,name ,val) (guard (symbol? name))
(-> `(define ,name ,(re-expand val))))
;; (define (NAME FORMALS...) BODY...)
(((,name . ,formals) . ,body) (guard (symbol? name))
;; -> (define NAME (lambda FORMALS BODY...))
(re-expand (-> `(define ,name (lambda ,formals . ,body))))))
(define-scheme-expander set!
;; (set! (NAME ARGS...) VAL)
(((,name . ,args) ,val) (guard (symbol? name)
(not (eq? name '@)) (not (eq? name '@@)))
;; -> ((setter NAME) ARGS... VAL)
(re-expand (-> `((setter ,name) ,@args ,val))))
;; (set! NAME VAL)
((,name ,val) (guard (symbol? name))
(-> `(set! ,name ,(re-expand val)))))
(define-scheme-expander if
;; (if TEST THEN [ELSE])
((,test ,then)
(-> `(if ,(re-expand test) ,(re-expand then))))
((,test ,then ,else)
(-> `(if ,(re-expand test) ,(re-expand then) ,(re-expand else)))))
(define-scheme-expander and
;; (and EXPS...)
(,tail
(-> `(and . ,(map re-expand tail)))))
(define-scheme-expander or
;; (or EXPS...)
(,tail
(-> `(or . ,(map re-expand tail)))))
(define-scheme-expander begin
;; (begin EXPS...)
((,single-exp)
(-> (re-expand single-exp)))
(,tail
(-> `(begin . ,(map re-expand tail)))))
(define (valid-bindings? bindings . it-is-for-do)
(define (valid-binding? b)
(amatch b
((,sym ,var) (guard (symbol? sym)) #t)
((,sym ,var ,update) (guard (pair? it-is-for-do) (symbol? sym)) #t)
(else #f)))
(and (list? (aref bindings))
(and-map valid-binding? (aref bindings))))
(define-scheme-expander let
;; (let NAME ((SYM VAL) ...) BODY...)
((,name ,bindings . ,body) (guard (symbol? name)
(valid-bindings? bindings))
;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...))
(re-expand (-> `(letrec ((,name (lambda ,(map acar (aref bindings))
. ,body)))
(,name . ,(map acadr (aref bindings)))))))
((() . ,body)
(re-expand (expand-internal-defines body)))
;; (let ((SYM VAL) ...) BODY...)
((,bindings . ,body) (guard (valid-bindings? bindings))
(-> `(let ,(map (lambda (x)
;; nb, relies on -> non-hygiene
(-> `(,(acar x) ,(re-expand (acadr x)))))
(aref bindings))
,(expand-internal-defines (map re-expand body))))))
(define-scheme-expander let*
;; (let* ((SYM VAL) ...) BODY...)
((() . ,body)
(re-expand (-> `(let () . ,body))))
((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym))
(re-expand (-> `(let ((,sym ,val)) (let* ,rest . ,body))))))
(define-scheme-expander letrec
;; (letrec ((SYM VAL) ...) BODY...)
((,bindings . ,body) (guard (valid-bindings? bindings))
(-> `(letrec ,(map (lambda (x)
;; nb, relies on -> non-hygiene
(-> `(,(acar x) ,(re-expand (acadr x)))))
(aref bindings))
,(expand-internal-defines (map re-expand body))))))
(define-scheme-expander cond
;; (cond (CLAUSE BODY...) ...)
(() (-> '(begin)))
(((else . ,body)) (re-expand (-> `(begin ,@body))))
(((,test) . ,rest) (re-expand (-> `(or ,test (cond ,@rest)))))
(((,test => ,proc) . ,rest)
;; FIXME hygiene!
(re-expand (-> `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest))))))
(((,test . ,body) . ,rest)
(re-expand (-> `(if ,test (begin ,@body) (cond ,@rest))))))
(define-scheme-expander case
;; (case EXP ((KEY...) BODY...) ...)
((,exp . ,clauses)
;; FIXME hygiene!
(re-expand
(->`(let ((_t ,exp))
,(let loop ((ls clauses))
(cond ((null? ls) '(begin))
((eq? (acaar ls) 'else) `(begin ,@(acdar ls)))
(else `(if (memv _t ',(acaar ls))
(begin ,@(acdar ls))
,(loop (acdr ls)))))))))))
(define-scheme-expander do
;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...)
((,bindings (,test . ,result) . ,body) (guard (valid-bindings? bindings #t))
(let ((sym (map acar (aref bindings)))
(val (map acadr (aref bindings)))
(update (map acddr (aref bindings))))
(define (next s x) (if (pair? x) (car x) s))
(re-expand
;; FIXME hygiene!
(-> `(letrec ((_l (lambda ,sym
(if ,test
(begin ,@result)
(begin ,@body
(_l ,@(map next sym update)))))))
(_l ,@val)))))))
(define-scheme-expander lambda
;; (lambda FORMALS BODY...)
((,formals ,docstring ,body1 . ,body) (guard (string? docstring))
(-> `(lambda ,formals ,docstring ,(expand-internal-defines
(map re-expand (cons body1 body))))))
((,formals . ,body)
(-> `(lambda ,formals ,(expand-internal-defines (map re-expand body))))))
(define-scheme-expander delay
;; FIXME not hygienic
((,expr)
(re-expand `(make-promise (lambda () ,expr)))))
(define-scheme-expander @
((,modname ,sym)
x))
(define-scheme-expander @@
((,modname ,sym)
x))
(define-scheme-expander eval-when
((,when . ,body) (guard (list? when) (and-map symbol? when))
(if (memq 'compile when)
(primitive-eval `(begin . ,body)))
(if (memq 'load when)
(-> `(begin . ,body))
(-> `(begin)))))
;;; Hum, I don't think this takes imported modifications to `define'
;;; properly into account. (Lexical bindings are OK because of alpha
;;; renaming.)
(define (expand-internal-defines body)
(let loop ((ls body) (ds '()))
(amatch ls
(() (syntax-error l "bad body" body))
(((define ,name ,val) . _)
(loop (acdr ls) (cons (list name val) ds)))
(else
(if (null? ds)
(if (null? (cdr ls)) (car ls) `(begin ,@ls))
`(letrec ,ds ,(if (null? (cdr ls)) (car ls) `(begin ,@ls))))))))

13
module/language/scheme/spec.scm
View file

@ -22,6 +22,8 @@
(define-module (language scheme spec)
#:use-module (system base language)
#:use-module (language scheme compile-ghil)
#:use-module (language scheme compile-tree-il)
#:use-module (language scheme decompile-tree-il)
#:export (scheme))
;;;
@ -30,12 +32,6 @@
(read-enable 'positions)
(define (read-file port)
(do ((x (read port) (read port))
(l '() (cons x l)))
((eof-object? x)
(cons 'begin (reverse! l)))))
;;;
;;; Language definition
;;;
@ -44,8 +40,9 @@
#:title "Guile Scheme"
#:version "0.5"
#:reader read
#:read-file read-file
#:compilers `((ghil . ,compile-ghil))
#:compilers `((tree-il . ,compile-tree-il)
(ghil . ,compile-ghil))
#:decompilers `((tree-il . ,decompile-tree-il))
#:evaluator (lambda (x module) (primitive-eval x))
#:printer write
)

359
module/language/tree-il.scm Normal file
View file

@ -0,0 +1,359 @@
;;;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later version.
;;;;
;;;; This library 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
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;;
(define-module (language tree-il)
#:use-module (system base pmatch)
#:use-module (system base syntax)
#:export (tree-il-src
<void> void? make-void void-src
<const> const? make-const const-src const-exp
<primitive-ref> primitive-ref? make-primitive-ref primitive-ref-src primitive-ref-name
<lexical-ref> lexical-ref? make-lexical-ref lexical-ref-src lexical-ref-name lexical-ref-gensym
<lexical-set> lexical-set? make-lexical-set lexical-set-src lexical-set-name lexical-set-gensym lexical-set-exp
<module-ref> module-ref? make-module-ref module-ref-src module-ref-mod module-ref-name module-ref-public?
<module-set> module-set? make-module-set module-set-src module-set-mod module-set-name module-set-public? module-set-exp
<toplevel-ref> toplevel-ref? make-toplevel-ref toplevel-ref-src toplevel-ref-name
<toplevel-set> toplevel-set? make-toplevel-set toplevel-set-src toplevel-set-name toplevel-set-exp
<toplevel-define> toplevel-define? make-toplevel-define toplevel-define-src toplevel-define-name toplevel-define-exp
<conditional> conditional? make-conditional conditional-src conditional-test conditional-then conditional-else
<application> application? make-application application-src application-proc application-args
<sequence> sequence? make-sequence sequence-src sequence-exps
<lambda> lambda? make-lambda lambda-src lambda-names lambda-vars lambda-meta lambda-body
<let> let? make-let let-src let-names let-vars let-vals let-exp
<letrec> letrec? make-letrec letrec-src letrec-names letrec-vars letrec-vals letrec-exp
parse-tree-il
unparse-tree-il
tree-il->scheme
post-order!
pre-order!))
(define-type (<tree-il> #:common-slots (src))
(<void>)
(<const> exp)
(<primitive-ref> name)
(<lexical-ref> name gensym)
(<lexical-set> name gensym exp)
(<module-ref> mod name public?)
(<module-set> mod name public? exp)
(<toplevel-ref> name)
(<toplevel-set> name exp)
(<toplevel-define> name exp)
(<conditional> test then else)
(<application> proc args)
(<sequence> exps)
(<lambda> names vars meta body)
(<let> names vars vals exp)
(<letrec> names vars vals exp))
(define (location x)
(and (pair? x)
(let ((props (source-properties x)))
(and (pair? props) props))))
(define (parse-tree-il exp)
(let ((loc (location exp))
(retrans (lambda (x) (parse-tree-il x))))
(pmatch exp
((void)
(make-void loc))
((apply ,proc . ,args)
(make-application loc (retrans proc) (map retrans args)))
((if ,test ,then ,else)
(make-conditional loc (retrans test) (retrans then) (retrans else)))
((primitive ,name) (guard (symbol? name))
(make-primitive-ref loc name))
((lexical ,name) (guard (symbol? name))
(make-lexical-ref loc name name))
((lexical ,name ,sym) (guard (symbol? name) (symbol? sym))
(make-lexical-ref loc name sym))
((set! (lexical ,name ,sym) ,exp) (guard (symbol? name) (symbol? sym))
(make-lexical-set loc name sym (retrans exp)))
((@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
(make-module-ref loc mod name #t))
((set! (@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
(make-module-set loc mod name #t (retrans exp)))
((@@ ,mod ,name) (guard (and-map symbol? mod) (symbol? name))
(make-module-ref loc mod name #f))
((set! (@@ ,mod ,name) ,exp) (guard (and-map symbol? mod) (symbol? name))
(make-module-set loc mod name #f (retrans exp)))
((toplevel ,name) (guard (symbol? name))
(make-toplevel-ref loc name))
((set! (toplevel ,name) ,exp) (guard (symbol? name))
(make-toplevel-set loc name (retrans exp)))
((define ,name ,exp) (guard (symbol? name))
(make-toplevel-define loc name (retrans exp)))
((lambda ,names ,vars ,exp)
(make-lambda loc names vars '() (retrans exp)))
((lambda ,names ,vars ,meta ,exp)
(make-lambda loc names vars meta (retrans exp)))
((const ,exp)
(make-const loc exp))
((begin . ,exps)
(make-sequence loc (map retrans exps)))
((let ,names ,vars ,vals ,exp)
(make-let loc names vars (map retrans vals) (retrans exp)))
((letrec ,names ,vars ,vals ,exp)
(make-letrec loc names vars (map retrans vals) (retrans exp)))
(else
(error "unrecognized tree-il" exp)))))
(define (unparse-tree-il tree-il)
(record-case tree-il
((<void>)
'(void))
((<application> proc args)
`(apply ,(unparse-tree-il proc) ,@(map unparse-tree-il args)))
((<conditional> test then else)
`(if ,(unparse-tree-il test) ,(unparse-tree-il then) ,(unparse-tree-il else)))
((<primitive-ref> name)
`(primitive ,name))
((<lexical-ref> name gensym)
`(lexical ,name ,gensym))
((<lexical-set> name gensym exp)
`(set! (lexical ,name ,gensym) ,(unparse-tree-il exp)))
((<module-ref> mod name public?)
`(,(if public? '@ '@@) ,mod ,name))
((<module-set> mod name public? exp)
`(set! (,(if public? '@ '@@) ,mod ,name) ,(unparse-tree-il exp)))
((<toplevel-ref> name)
`(toplevel ,name))
((<toplevel-set> name exp)
`(set! (toplevel ,name) ,(unparse-tree-il exp)))
((<toplevel-define> name exp)
`(define ,name ,(unparse-tree-il exp)))
((<lambda> names vars meta body)
`(lambda ,names ,vars ,meta ,(unparse-tree-il body)))
((<const> exp)
`(const ,exp))
((<sequence> exps)
`(begin ,@(map unparse-tree-il exps)))
((<let> names vars vals exp)
`(let ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp)))
((<letrec> names vars vals exp)
`(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il exp)))))
(define (tree-il->scheme e)
(cond ((list? e)
(map tree-il->scheme e))
((pair? e)
(cons (tree-il->scheme (car e))
(tree-il->scheme (cdr e))))
((record? e)
(record-case e
((<void>)
'(if #f #f))
((<application> proc args)
`(,(tree-il->scheme proc) ,@(map tree-il->scheme args)))
((<conditional> test then else)
(if (void? else)
`(if ,(tree-il->scheme test) ,(tree-il->scheme then))
`(if ,(tree-il->scheme test) ,(tree-il->scheme then) ,(tree-il->scheme else))))
((<primitive-ref> name)
name)
((<lexical-ref> name gensym)
gensym)
((<lexical-set> name gensym exp)
`(set! ,gensym ,(tree-il->scheme exp)))
((<module-ref> mod name public?)
`(,(if public? '@ '@@) ,mod ,name))
((<module-set> mod name public? exp)
`(set! (,(if public? '@ '@@) ,mod ,name) ,(tree-il->scheme exp)))
((<toplevel-ref> name)
name)
((<toplevel-set> name exp)
`(set! ,name ,(tree-il->scheme exp)))
((<toplevel-define> name exp)
`(define ,name ,(tree-il->scheme exp)))
((<lambda> vars meta body)
`(lambda ,vars
,@(cond ((assq-ref meta 'documentation) => list) (else '()))
,(tree-il->scheme body)))
((<const> exp)
(if (and (self-evaluating? exp) (not (vector? exp)))
exp
(list 'quote exp)))
((<sequence> exps)
`(begin ,@(map tree-il->scheme exps)))
((<let> vars vals exp)
`(let ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme exp)))
((<letrec> vars vals exp)
`(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme exp)))))
(else e)))
(define (post-order! f x)
(let lp ((x x))
(record-case x
((<void>)
(or (f x) x))
((<application> proc args)
(set! (application-proc x) (lp proc))
(set! (application-args x) (map lp args))
(or (f x) x))
((<conditional> test then else)
(set! (conditional-test x) (lp test))
(set! (conditional-then x) (lp then))
(set! (conditional-else x) (lp else))
(or (f x) x))
((<primitive-ref> name)
(or (f x) x))
((<lexical-ref> name gensym)
(or (f x) x))
((<lexical-set> name gensym exp)
(set! (lexical-set-exp x) (lp exp))
(or (f x) x))
((<module-ref> mod name public?)
(or (f x) x))
((<module-set> mod name public? exp)
(set! (module-set-exp x) (lp exp))
(or (f x) x))
((<toplevel-ref> name)
(or (f x) x))
((<toplevel-set> name exp)
(set! (toplevel-set-exp x) (lp exp))
(or (f x) x))
((<toplevel-define> name exp)
(set! (toplevel-define-exp x) (lp exp))
(or (f x) x))
((<lambda> vars meta body)
(set! (lambda-body x) (lp body))
(or (f x) x))
((<const> exp)
(or (f x) x))
((<sequence> exps)
(set! (sequence-exps x) (map lp exps))
(or (f x) x))
((<let> vars vals exp)
(set! (let-vals x) (map lp vals))
(set! (let-exp x) (lp exp))
(or (f x) x))
((<letrec> vars vals exp)
(set! (letrec-vals x) (map lp vals))
(set! (letrec-exp x) (lp exp))
(or (f x) x)))))
(define (pre-order! f x)
(let lp ((x x))
(let ((x (or (f x) x)))
(record-case x
((<application> proc args)
(set! (application-proc x) (lp proc))
(set! (application-args x) (map lp args)))
((<conditional> test then else)
(set! (conditional-test x) (lp test))
(set! (conditional-then x) (lp then))
(set! (conditional-else x) (lp else)))
((<lexical-set> name gensym exp)
(set! (lexical-set-exp x) (lp exp)))
((<module-set> mod name public? exp)
(set! (module-set-exp x) (lp exp)))
((<toplevel-set> name exp)
(set! (toplevel-set-exp x) (lp exp)))
((<toplevel-define> name exp)
(set! (toplevel-define-exp x) (lp exp)))
((<lambda> vars meta body)
(set! (lambda-body x) (lp body)))
((<sequence> exps)
(set! (sequence-exps x) (map lp exps)))
((<let> vars vals exp)
(set! (let-vals x) (map lp vals))
(set! (let-exp x) (lp exp)))
((<letrec> vars vals exp)
(set! (letrec-vals x) (map lp vals))
(set! (letrec-exp x) (lp exp)))
(else #f))
x)))

235
module/language/tree-il/analyze.scm Normal file
View file

@ -0,0 +1,235 @@
;;; TREE-IL -> GLIL compiler
;; Copyright (C) 2001,2008,2009 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 tree-il analyze)
#:use-module (system base syntax)
#:use-module (language tree-il)
#:export (analyze-lexicals))
;; allocation: the process of assigning a type and index to each var
;; a var is external if it is heaps; assigning index is easy
;; args are assigned in order
;; locals are indexed as their linear position in the binding path
;; (let (0 1)
;; (let (2 3) ...)
;; (let (2) ...))
;; (let (2 3 4) ...))
;; etc.
;;
;; This algorithm has the problem that variables are only allocated
;; indices at the end of the binding path. If variables bound early in
;; the path are not used in later portions of the path, their indices
;; will not be recycled. This problem is particularly egregious in the
;; expansion of `or':
;;
;; (or x y z)
;; -> (let ((a x)) (if a a (let ((b y)) (if b b z))))
;;
;; As you can see, the `a' binding is only used in the ephemeral `then'
;; clause of the first `if', but its index would be reserved for the
;; whole of the `or' expansion. So we have a hack for this specific
;; case. A proper solution would be some sort of liveness analysis, and
;; not our linear allocation algorithm.
;;
;; allocation:
;; sym -> (local . index) | (heap level . index)
;; lambda -> (nlocs . nexts)
(define (analyze-lexicals x)
;; parents: lambda -> parent
;; useful when we see a closed-over var, so we can calculate its
;; coordinates (depth and index).
;; bindings: lambda -> (sym ...)
;; useful for two reasons: one, so we know how much space to allocate
;; when we go into a lambda; and two, so that we know when to stop,
;; when looking for closed-over vars.
;; heaps: sym -> lambda
;; allows us to heapify vars in an O(1) fashion
;; refcounts: sym -> count
;; allows us to detect the or-expansion an O(1) time
(define (find-heap sym parent)
;; fixme: check displaced lexicals here?
(if (memq sym (hashq-ref bindings parent))
parent
(find-heap sym (hashq-ref parents parent))))
(define (analyze! x parent level)
(define (step y) (analyze! y parent level))
(define (recur x parent) (analyze! x parent (1+ level)))
(record-case x
((<application> proc args)
(step proc) (for-each step args))
((<conditional> test then else)
(step test) (step then) (step else))
((<lexical-ref> name gensym)
(hashq-set! refcounts gensym (1+ (hashq-ref refcounts gensym 0)))
(if (and (not (memq gensym (hashq-ref bindings parent)))
(not (hashq-ref heaps gensym)))
(hashq-set! heaps gensym (find-heap gensym parent))))
((<lexical-set> name gensym exp)
(step exp)
(if (not (hashq-ref heaps gensym))
(hashq-set! heaps gensym (find-heap gensym parent))))
((<module-set> mod name public? exp)
(step exp))
((<toplevel-set> name exp)
(step exp))
((<toplevel-define> name exp)
(step exp))
((<sequence> exps)
(for-each step exps))
((<lambda> vars meta body)
(hashq-set! parents x parent)
(hashq-set! bindings x
(let rev* ((vars vars) (out '()))
(cond ((null? vars) out)
((pair? vars) (rev* (cdr vars)
(cons (car vars) out)))
(else (cons vars out)))))
(recur body x)
(hashq-set! bindings x (reverse! (hashq-ref bindings x))))
((<let> vars vals exp)
(for-each step vals)
(hashq-set! bindings parent
(append (reverse vars) (hashq-ref bindings parent)))
(step exp))
((<letrec> vars vals exp)
(hashq-set! bindings parent
(append (reverse vars) (hashq-ref bindings parent)))
(for-each step vals)
(step exp))
(else #f)))
(define (allocate-heap! binder)
(hashq-set! heap-indexes binder
(1+ (hashq-ref heap-indexes binder -1))))
(define (allocate! x level n)
(define (recur y) (allocate! y level n))
(record-case x
((<application> proc args)
(apply max (recur proc) (map recur args)))
((<conditional> test then else)
(max (recur test) (recur then) (recur else)))
((<lexical-set> name gensym exp)
(recur exp))
((<module-set> mod name public? exp)
(recur exp))
((<toplevel-set> name exp)
(recur exp))
((<toplevel-define> name exp)
(recur exp))
((<sequence> exps)
(apply max (map recur exps)))
((<lambda> vars meta body)
(let lp ((vars vars) (n 0))
(if (null? vars)
(hashq-set! allocation x
(let ((nlocs (- (allocate! body (1+ level) n) n)))
(cons nlocs (1+ (hashq-ref heap-indexes x -1)))))
(let ((v (if (pair? vars) (car vars) vars)))
(let ((binder (hashq-ref heaps v)))
(hashq-set!
allocation v
(if binder
(cons* 'heap (1+ level) (allocate-heap! binder))
(cons 'stack n))))
(lp (if (pair? vars) (cdr vars) '()) (1+ n)))))
n)
((<let> vars vals exp)
(let ((nmax (apply max (map recur vals))))
(cond
;; the `or' hack
((and (conditional? exp)
(= (length vars) 1)
(let ((v (car vars)))
(and (not (hashq-ref heaps v))
(= (hashq-ref refcounts v 0) 2)
(lexical-ref? (conditional-test exp))
(eq? (lexical-ref-gensym (conditional-test exp)) v)
(lexical-ref? (conditional-then exp))
(eq? (lexical-ref-gensym (conditional-then exp)) v))))
(hashq-set! allocation (car vars) (cons 'stack n))
;; the 1+ for this var
(max nmax (1+ n) (allocate! (conditional-else exp) level n)))
(else
(let lp ((vars vars) (n n))
(if (null? vars)
(max nmax (allocate! exp level n))
(let ((v (car vars)))
(let ((binder (hashq-ref heaps v)))
(hashq-set!
allocation v
(if binder
(cons* 'heap level (allocate-heap! binder))
(cons 'stack n)))
(lp (cdr vars) (if binder n (1+ n)))))))))))
((<letrec> vars vals exp)
(let lp ((vars vars) (n n))
(if (null? vars)
(let ((nmax (apply max
(map (lambda (x)
(allocate! x level n))
vals))))
(max nmax (allocate! exp level n)))
(let ((v (car vars)))
(let ((binder (hashq-ref heaps v)))
(hashq-set!
allocation v
(if binder
(cons* 'heap level (allocate-heap! binder))
(cons 'stack n)))
(lp (cdr vars) (if binder n (1+ n))))))))
(else n)))
(define parents (make-hash-table))
(define bindings (make-hash-table))
(define heaps (make-hash-table))
(define refcounts (make-hash-table))
(define allocation (make-hash-table))
(define heap-indexes (make-hash-table))
(analyze! x #f -1)
(allocate! x -1 0)
allocation)

448
module/language/tree-il/compile-glil.scm Normal file
View file

@ -0,0 +1,448 @@
;;; TREE-IL -> GLIL compiler
;; Copyright (C) 2001,2008,2009 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 tree-il compile-glil)
#:use-module (system base syntax)
#:use-module (ice-9 receive)
#:use-module (language glil)
#:use-module (language tree-il)
#:use-module (language tree-il optimize)
#:use-module (language tree-il analyze)
#:export (compile-glil))
;;; TODO:
;;
;; call-with-values -> mv-bind
;; basic degenerate-case reduction
;; allocation:
;; sym -> (local . index) | (heap level . index)
;; lambda -> (nlocs . nexts)
(define *comp-module* (make-fluid))
(define (compile-glil x e opts)
(let* ((x (make-lambda (tree-il-src x) '() '() '() x))
(x (optimize! x e opts))
(allocation (analyze-lexicals x)))
(with-fluid* *comp-module* (or (and e (car e)) (current-module))
(lambda ()
(values (flatten-lambda x -1 allocation)
(and e (cons (car e) (cddr e)))
e)))))
(define *primcall-ops* (make-hash-table))
(for-each
(lambda (x) (hash-set! *primcall-ops* (car x) (cdr x)))
'(((eq? . 2) . eq?)
((eqv? . 2) . eqv?)
((equal? . 2) . equal?)
((= . 2) . ee?)
((< . 2) . lt?)
((> . 2) . gt?)
((<= . 2) . le?)
((>= . 2) . ge?)
((+ . 2) . add)
((- . 2) . sub)
((* . 2) . mul)
((/ . 2) . div)
((quotient . 2) . quo)
((remainder . 2) . rem)
((modulo . 2) . mod)
((not . 1) . not)
((pair? . 1) . pair?)
((cons . 2) . cons)
((car . 1) . car)
((cdr . 1) . cdr)
((set-car! . 2) . set-car!)
((set-cdr! . 2) . set-cdr!)
((null? . 1) . null?)
((list? . 1) . list?)
(list . list)
(vector . vector)
((@slot-ref . 2) . slot-ref)
((@slot-set! . 3) . slot-set)))
(define (make-label) (gensym ":L"))
(define (vars->bind-list ids vars allocation)
(map (lambda (id v)
(let ((loc (hashq-ref allocation v)))
(case (car loc)
((stack) (list id 'local (cdr loc)))
((heap) (list id 'external (cddr loc)))
(else (error "badness" id v loc)))))
ids
vars))
(define (emit-bindings src ids vars allocation emit-code)
(if (pair? vars)
(emit-code src (make-glil-bind
(vars->bind-list ids vars allocation)))))
(define (with-output-to-code proc)
(let ((out '()))
(define (emit-code src x)
(set! out (cons x out))
(if src
(set! out (cons (make-glil-source src) out))))
(proc emit-code)
(reverse out)))
(define (flatten-lambda x level allocation)
(receive (ids vars nargs nrest)
(let lp ((ids (lambda-names x)) (vars (lambda-vars x))
(oids '()) (ovars '()) (n 0))
(cond ((null? vars) (values (reverse oids) (reverse ovars) n 0))
((pair? vars) (lp (cdr ids) (cdr vars)
(cons (car ids) oids) (cons (car vars) ovars)
(1+ n)))
(else (values (reverse (cons ids oids))
(reverse (cons vars ovars))
(1+ n) 1))))
(let ((nlocs (car (hashq-ref allocation x)))
(nexts (cdr (hashq-ref allocation x))))
(make-glil-program
nargs nrest nlocs nexts (lambda-meta x)
(with-output-to-code
(lambda (emit-code)
;; write bindings and source debugging info
(emit-bindings #f ids vars allocation emit-code)
(if (lambda-src x)
(emit-code #f (make-glil-source (lambda-src x))))
;; copy args to the heap if necessary
(let lp ((in vars) (n 0))
(if (not (null? in))
(let ((loc (hashq-ref allocation (car in))))
(case (car loc)
((heap)
(emit-code #f (make-glil-local 'ref n))
(emit-code #f (make-glil-external 'set 0 (cddr loc)))))
(lp (cdr in) (1+ n)))))
;; and here, here, dear reader: we compile.
(flatten (lambda-body x) (1+ level) allocation emit-code)))))))
(define (flatten x level allocation emit-code)
(define (emit-label label)
(emit-code #f (make-glil-label label)))
(define (emit-branch src inst label)
(emit-code src (make-glil-branch inst label)))
(let comp ((x x) (context 'tail))
(define (comp-tail tree) (comp tree context))
(define (comp-push tree) (comp tree 'push))
(define (comp-drop tree) (comp tree 'drop))
(record-case x
((<void>)
(case context
((push) (emit-code #f (make-glil-void)))
((tail)
(emit-code #f (make-glil-void))
(emit-code #f (make-glil-call 'return 1)))))
((<const> src exp)
(case context
((push) (emit-code src (make-glil-const exp)))
((tail)
(emit-code src (make-glil-const exp))
(emit-code #f (make-glil-call 'return 1)))))
;; FIXME: should represent sequence as exps tail
((<sequence> src exps)
(let lp ((exps exps))
(if (null? (cdr exps))
(comp-tail (car exps))
(begin
(comp-drop (car exps))
(lp (cdr exps))))))
((<application> src proc args)
;; FIXME: need a better pattern-matcher here
(cond
((and (primitive-ref? proc)
(eq? (primitive-ref-name proc) '@apply)
(>= (length args) 1))
(let ((proc (car args))
(args (cdr args)))
(cond
((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
(not (eq? context 'push)))
;; tail: (lambda () (apply values '(1 2)))
;; drop: (lambda () (apply values '(1 2)) 3)
;; push: (lambda () (list (apply values '(10 12)) 1))
(case context
((drop) (for-each comp-drop args))
((tail)
(for-each comp-push args)
(emit-code src (make-glil-call 'return/values* (length args))))))
(else
(case context
((tail)
(comp-push proc)
(for-each comp-push args)
(emit-code src (make-glil-call 'goto/apply (1+ (length args)))))
((push)
(comp-push proc)
(for-each comp-push args)
(emit-code src (make-glil-call 'apply (1+ (length args)))))
((drop)
;; Well, shit. The proc might return any number of
;; values (including 0), since it's in a drop context,
;; yet apply does not create a MV continuation. So we
;; mv-call out to our trampoline instead.
(comp-drop
(make-application src (make-primitive-ref #f 'apply)
(cons proc args)))))))))
((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
(not (eq? context 'push)))
;; tail: (lambda () (values '(1 2)))
;; drop: (lambda () (values '(1 2)) 3)
;; push: (lambda () (list (values '(10 12)) 1))
(case context
((drop) (for-each comp-drop args))
((tail)
(for-each comp-push args)
(emit-code src (make-glil-call 'return/values (length args))))))
((and (primitive-ref? proc)
(eq? (primitive-ref-name proc) '@call-with-values)
(= (length args) 2))
;; CONSUMER
;; PRODUCER
;; (mv-call MV)
;; ([tail]-call 1)
;; goto POST
;; MV: [tail-]call/nargs
;; POST: (maybe-drop)
(let ((MV (make-label)) (POST (make-label))
(producer (car args)) (consumer (cadr args)))
(comp-push consumer)
(comp-push producer)
(emit-code src (make-glil-mv-call 0 MV))
(case context
((tail) (emit-code src (make-glil-call 'goto/args 1)))
(else (emit-code src (make-glil-call 'call 1))
(emit-branch #f 'br POST)))
(emit-label MV)
(case context
((tail) (emit-code src (make-glil-call 'goto/nargs 0)))
(else (emit-code src (make-glil-call 'call/nargs 0))
(emit-label POST)
(if (eq? context 'drop)
(emit-code #f (make-glil-call 'drop 1)))))))
((and (primitive-ref? proc)
(eq? (primitive-ref-name proc) '@call-with-current-continuation)
(= (length args) 1))
(case context
((tail)
(comp-push (car args))
(emit-code src (make-glil-call 'goto/cc 1)))
((push)
(comp-push (car args))
(emit-code src (make-glil-call 'call/cc 1)))
((drop)
;; Crap. Just like `apply' in drop context.
(comp-drop
(make-application
src (make-primitive-ref #f 'call-with-current-continuation)
args)))))
((and (primitive-ref? proc)
(or (hash-ref *primcall-ops*
(cons (primitive-ref-name proc) (length args)))
(hash-ref *primcall-ops* (primitive-ref-name proc))))
=> (lambda (op)
(for-each comp-push args)
(emit-code src (make-glil-call op (length args)))
(case context
((tail) (emit-code #f (make-glil-call 'return 1)))
((drop) (emit-code #f (make-glil-call 'drop 1))))))
(else
(comp-push proc)
(for-each comp-push args)
(let ((len (length args)))
(case context
((tail) (emit-code src (make-glil-call 'goto/args len)))
((push) (emit-code src (make-glil-call 'call len)))
((drop)
(let ((MV (make-label)) (POST (make-label)))
(emit-code src (make-glil-mv-call len MV))
(emit-code #f (make-glil-call 'drop 1))
(emit-branch #f 'br POST)
(emit-label MV)
(emit-code #f (make-glil-mv-bind '() #f))
(emit-code #f (make-glil-unbind))
(emit-label POST))))))))
((<conditional> src test then else)
;; TEST
;; (br-if-not L1)
;; THEN
;; (br L2)
;; L1: ELSE
;; L2:
(let ((L1 (make-label)) (L2 (make-label)))
(comp-push test)
(emit-branch src 'br-if-not L1)
(comp-tail then)
(if (not (eq? context 'tail))
(emit-branch #f 'br L2))
(emit-label L1)
(comp-tail else)
(if (not (eq? context 'tail))
(emit-label L2))))
((<primitive-ref> src name)
(cond
((eq? (module-variable (fluid-ref *comp-module*) name)
(module-variable the-root-module name))
(case context
((push)
(emit-code src (make-glil-toplevel 'ref name)))
((tail)
(emit-code src (make-glil-toplevel 'ref name))
(emit-code #f (make-glil-call 'return 1)))))
(else
(pk 'ew-the-badness x (current-module) (fluid-ref *comp-module*))
(case context
((push)
(emit-code src (make-glil-module 'ref '(guile) name #f)))
((tail)
(emit-code src (make-glil-module 'ref '(guile) name #f))
(emit-code #f (make-glil-call 'return 1)))))))
((<lexical-ref> src name gensym)
(case context
((push tail)
(let ((loc (hashq-ref allocation gensym)))
(case (car loc)
((stack)
(emit-code src (make-glil-local 'ref (cdr loc))))
((heap)
(emit-code src (make-glil-external
'ref (- level (cadr loc)) (cddr loc))))
(else (error "badness" x loc)))
(if (eq? context 'tail)
(emit-code #f (make-glil-call 'return 1)))))))
((<lexical-set> src name gensym exp)
(comp-push exp)
(let ((loc (hashq-ref allocation gensym)))
(case (car loc)
((stack)
(emit-code src (make-glil-local 'set (cdr loc))))
((heap)
(emit-code src (make-glil-external
'set (- level (cadr loc)) (cddr loc))))
(else (error "badness" x loc))))
(case context
((push)
(emit-code #f (make-glil-void)))
((tail)
(emit-code #f (make-glil-void))
(emit-code #f (make-glil-call 'return 1)))))
((<module-ref> src mod name public?)
(emit-code src (make-glil-module 'ref mod name public?))
(case context
((drop) (emit-code #f (make-glil-call 'drop 1)))
((tail) (emit-code #f (make-glil-call 'return 1)))))
((<module-set> src mod name public? exp)
(comp-push exp)
(emit-code src (make-glil-module 'set mod name public?))
(case context
((push)
(emit-code #f (make-glil-void)))
((tail)
(emit-code #f (make-glil-void))
(emit-code #f (make-glil-call 'return 1)))))
((<toplevel-ref> src name)
(emit-code src (make-glil-toplevel 'ref name))
(case context
((drop) (emit-code #f (make-glil-call 'drop 1)))
((tail) (emit-code #f (make-glil-call 'return 1)))))
((<toplevel-set> src name exp)
(comp-push exp)
(emit-code src (make-glil-toplevel 'set name))
(case context
((push)
(emit-code #f (make-glil-void)))
((tail)
(emit-code #f (make-glil-void))
(emit-code #f (make-glil-call 'return 1)))))
((<toplevel-define> src name exp)
(comp-push exp)
(emit-code src (make-glil-toplevel 'define name))
(case context
((push)
(emit-code #f (make-glil-void)))
((tail)
(emit-code #f (make-glil-void))
(emit-code #f (make-glil-call 'return 1)))))
((<lambda>)
(case context
((push)
(emit-code #f (flatten-lambda x level allocation)))
((tail)
(emit-code #f (flatten-lambda x level allocation))
(emit-code #f (make-glil-call 'return 1)))))
((<let> src names vars vals exp)
(for-each comp-push vals)
(emit-bindings src names vars allocation emit-code)
(for-each (lambda (v)
(let ((loc (hashq-ref allocation v)))
(case (car loc)
((stack)
(emit-code src (make-glil-local 'set (cdr loc))))
((heap)
(emit-code src (make-glil-external 'set 0 (cddr loc))))
(else (error "badness" x loc)))))
(reverse vars))
(comp-tail exp)
(emit-code #f (make-glil-unbind)))
((<letrec> src names vars vals exp)
(for-each comp-push vals)
(emit-bindings src names vars allocation emit-code)
(for-each (lambda (v)
(let ((loc (hashq-ref allocation v)))
(case (car loc)
((stack)
(emit-code src (make-glil-local 'set (cdr loc))))
((heap)
(emit-code src (make-glil-external 'set 0 (cddr loc))))
(else (error "badness" x loc)))))
(reverse vars))
(comp-tail exp)
(emit-code #f (make-glil-unbind))))))

42
module/language/tree-il/optimize.scm Normal file
View file

@ -0,0 +1,42 @@
;;; Tree-il optimizer
;; Copyright (C) 2009 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 tree-il optimize)
#:use-module (language tree-il)
#:use-module (language tree-il primitives)
#:export (optimize!))
(define (env-module e)
(if e (car e) (current-module)))
(define (optimize! x env opts)
(expand-primitives! (resolve-primitives! x (env-module env))))
;; Possible optimizations:
;; * constant folding, propagation
;; * procedure inlining
;; * always when single call site
;; * always for "trivial" procs
;; * otherwise who knows
;; * dead code elimination
;; * degenerate case optimizations
;; * "fixing letrec"

206
module/language/tree-il/primitives.scm Normal file
View file

@ -0,0 +1,206 @@
;;; GHIL macros
;; 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 tree-il primitives)
#:use-module (system base syntax)
#:use-module (language tree-il)
#:use-module (srfi srfi-16)
#:export (resolve-primitives! add-interesting-primitive!
expand-primitives!))
(define *interesting-primitive-names*
'(apply @apply
call-with-values @call-with-values
call-with-current-continuation @call-with-current-continuation
call/cc
values
eq? eqv? equal?
= < > <= >= zero?
+ * - / 1- 1+ quotient remainder modulo
not
pair? null? list? acons cons cons*
list vector
car cdr
set-car! set-cdr!
caar cadr cdar cddr
caaar caadr cadar caddr cdaar cdadr cddar cdddr
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr))
(define (add-interesting-primitive! name)
(hashq-set! *interesting-primitive-vars*
(module-variable (current-module) name) name))
(define *interesting-primitive-vars* (make-hash-table))
(for-each add-interesting-primitive! *interesting-primitive-names*)
(define (resolve-primitives! x mod)
(post-order!
(lambda (x)
(record-case x
((<toplevel-ref> src name)
(and (hashq-ref *interesting-primitive-vars*
(module-variable mod name))
(make-primitive-ref src name)))
((<module-ref> src mod name public?)
;; for the moment, we're disabling primitive resolution for
;; public refs because resolve-interface can raise errors.
(let ((m (and (not public?) (resolve-module mod))))
(and m (hashq-ref *interesting-primitive-vars*
(module-variable m name))
(make-primitive-ref src name))))
(else #f)))
x))
(define *primitive-expand-table* (make-hash-table))
(define (expand-primitives! x)
(pre-order!
(lambda (x)
(record-case x
((<application> src proc args)
(and (primitive-ref? proc)
(let ((expand (hashq-ref *primitive-expand-table*
(primitive-ref-name proc))))
(and expand (apply expand src args)))))
(else #f)))
x))
;;; I actually did spend about 10 minutes trying to redo this with
;;; syntax-rules. Patches appreciated.
;;;
(define-macro (define-primitive-expander sym . clauses)
(define (inline-args args)
(let lp ((in args) (out '()))
(cond ((null? in) `(list ,@(reverse out)))
((symbol? in) `(cons* ,@(reverse out) ,in))
((pair? (car in))
(lp (cdr in)
(cons `(make-application src (make-primitive-ref src ',(caar in))
,(inline-args (cdar in)))
out)))
((symbol? (car in))
;; assume it's locally bound
(lp (cdr in) (cons (car in) out)))
((number? (car in))
(lp (cdr in) (cons `(make-const src ,(car in)) out)))
(else
(error "what what" (car in))))))
(define (consequent exp)
(cond
((pair? exp)
`(make-application src (make-primitive-ref src ',(car exp))
,(inline-args (cdr exp))))
((symbol? exp)
;; assume locally bound
exp)
((number? exp)
`(make-const src ,exp))
(else (error "bad consequent yall" exp))))
`(hashq-set! *primitive-expand-table*
',sym
(case-lambda
,@(let lp ((in clauses) (out '()))
(if (null? in)
(reverse (cons '(else #f) out))
(lp (cddr in)
(cons `((src . ,(car in))
,(consequent (cadr in))) out)))))))
(define-primitive-expander +
() 0
(x) x
(x y z . rest) (+ x (+ y z . rest)))
(define-primitive-expander *
() 1
(x) x
(x y z . rest) (* x (* y z . rest)))
(define-primitive-expander -
(x) (- 0 x)
(x y z . rest) (- x (+ y z . rest)))
(define-primitive-expander 1-
(x) (- x 1))
(define-primitive-expander /
(x) (/ 1 x)
(x y z . rest) (/ x (* y z . rest)))
(define-primitive-expander caar (x) (car (car x)))
(define-primitive-expander cadr (x) (car (cdr x)))
(define-primitive-expander cdar (x) (cdr (car x)))
(define-primitive-expander cddr (x) (cdr (cdr x)))
(define-primitive-expander caaar (x) (car (car (car x))))
(define-primitive-expander caadr (x) (car (car (cdr x))))
(define-primitive-expander cadar (x) (car (cdr (car x))))
(define-primitive-expander caddr (x) (car (cdr (cdr x))))
(define-primitive-expander cdaar (x) (cdr (car (car x))))
(define-primitive-expander cdadr (x) (cdr (car (cdr x))))
(define-primitive-expander cddar (x) (cdr (cdr (car x))))
(define-primitive-expander cdddr (x) (cdr (cdr (cdr x))))
(define-primitive-expander caaaar (x) (car (car (car (car x)))))
(define-primitive-expander caaadr (x) (car (car (car (cdr x)))))
(define-primitive-expander caadar (x) (car (car (cdr (car x)))))
(define-primitive-expander caaddr (x) (car (car (cdr (cdr x)))))
(define-primitive-expander cadaar (x) (car (cdr (car (car x)))))
(define-primitive-expander cadadr (x) (car (cdr (car (cdr x)))))
(define-primitive-expander caddar (x) (car (cdr (cdr (car x)))))
(define-primitive-expander cadddr (x) (car (cdr (cdr (cdr x)))))
(define-primitive-expander cdaaar (x) (cdr (car (car (car x)))))
(define-primitive-expander cdaadr (x) (cdr (car (car (cdr x)))))
(define-primitive-expander cdadar (x) (cdr (car (cdr (car x)))))
(define-primitive-expander cdaddr (x) (cdr (car (cdr (cdr x)))))
(define-primitive-expander cddaar (x) (cdr (cdr (car (car x)))))
(define-primitive-expander cddadr (x) (cdr (cdr (car (cdr x)))))
(define-primitive-expander cdddar (x) (cdr (cdr (cdr (car x)))))
(define-primitive-expander cddddr (x) (cdr (cdr (cdr (cdr x)))))
(define-primitive-expander cons*
(x) x
(x y) (cons x y)
(x y . rest) (cons x (cons* y . rest)))
(define-primitive-expander acons (x y z)
(cons (cons x y) z))
(define-primitive-expander apply (f . args)
(@apply f . args))
(define-primitive-expander call-with-values (producer consumer)
(@call-with-values producer consumer))
(define-primitive-expander call-with-current-continuation (proc)
(@call-with-current-continuation proc))
(define-primitive-expander call/cc (proc)
(@call-with-current-continuation proc))
(define-primitive-expander values (x) x)

43
module/language/tree-il/spec.scm Normal file
View file

@ -0,0 +1,43 @@
;;; Tree Intermediate Language
;; Copyright (C) 2009 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 tree-il spec)
#:use-module (system base language)
#:use-module (language glil)
#:use-module (language tree-il)
#:use-module (language tree-il compile-glil)
#:export (tree-il))
(define (write-tree-il exp . port)
(apply write (unparse-tree-il exp) port))
(define (join exps env)
(make-sequence #f exps))
(define-language tree-il
#:title "Tree Intermediate Language"
#:version "1.0"
#:reader read
#:printer write-tree-il
#:parser parse-tree-il
#:joiner join
#:compilers `((glil . ,compile-glil))
)

410
module/oop/goops.scm
View file

@ -154,17 +154,6 @@
;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
;;; OPTION ::= KEYWORD VALUE
;;;
(define (define-class-pre-definition kw val)
(case kw
((#:getter #:setter)
`(if (or (not (defined? ',val))
(not (is-a? ,val <generic>)))
(define-generic ,val)))
((#:accessor)
`(if (or (not (defined? ',val))
(not (is-a? ,val <accessor>)))
(define-accessor ,val)))
(else #f)))
(define (kw-do-map mapper f kwargs)
(define (keywords l)
@ -180,69 +169,6 @@
(a (args kwargs)))
(mapper f k a)))
;;; This code should be implemented in C.
;;;
(define-macro (define-class name supers . slots)
;; Some slot options require extra definitions to be made. In
;; particular, we want to make sure that the generic function objects
;; which represent accessors exist before `make-class' tries to add
;; methods to them.
;;
;; Postpone some error handling to class macro.
;;
`(begin
;; define accessors
,@(append-map (lambda (slot)
(kw-do-map filter-map
define-class-pre-definition
(if (pair? slot) (cdr slot) '())))
(take-while (lambda (x) (not (keyword? x))) slots))
(if (and (defined? ',name)
(is-a? ,name <class>)
(memq <object> (class-precedence-list ,name)))
(class-redefinition ,name
(class ,supers ,@slots #:name ',name))
(define ,name (class ,supers ,@slots #:name ',name)))))
(define standard-define-class define-class)
;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...)
;;;
;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
;;; OPTION ::= KEYWORD VALUE
;;;
(define-macro (class supers . slots)
(define (make-slot-definition-forms slots)
(map
(lambda (def)
(cond
((pair? def)
`(list ',(car def)
,@(kw-do-map append-map
(lambda (kw arg)
(case kw
((#:init-form)
`(#:init-form ',arg
#:init-thunk (lambda () ,arg)))
(else (list kw arg))))
(cdr def))))
(else
`(list ',def))))
slots))
(if (not (list? supers))
(goops-error "malformed superclass list: ~S" supers))
(let ((slot-defs (cons #f '()))
(slots (take-while (lambda (x) (not (keyword? x))) slots))
(options (or (find-tail keyword? slots) '())))
`(make-class
;; evaluate super class variables
(list ,@supers)
;; evaluate slot definitions, except the slot name!
(list ,@(make-slot-definition-forms slots))
;; evaluate class options
,@options)))
(define (make-class supers slots . options)
(let ((env (or (get-keyword #:environment options #f)
(top-level-env))))
@ -275,6 +201,108 @@
#:environment env
options))))
;;; (class (SUPER ...) SLOT-DEFINITION ... OPTION ...)
;;;
;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
;;; OPTION ::= KEYWORD VALUE
;;;
(define-macro (class supers . slots)
(define (make-slot-definition-forms slots)
(map
(lambda (def)
(cond
((pair? def)
`(list ',(car def)
,@(kw-do-map append-map
(lambda (kw arg)
(case kw
((#:init-form)
`(#:init-form ',arg
#:init-thunk (lambda () ,arg)))
(else (list kw arg))))
(cdr def))))
(else
`(list ',def))))
slots))
(if (not (list? supers))
(goops-error "malformed superclass list: ~S" supers))
(let ((slot-defs (cons #f '()))
(slots (take-while (lambda (x) (not (keyword? x))) slots))
(options (or (find-tail keyword? slots) '())))
`(make-class
;; evaluate super class variables
(list ,@supers)
;; evaluate slot definitions, except the slot name!
(list ,@(make-slot-definition-forms slots))
;; evaluate class options
,@options)))
(define-syntax define-class-pre-definition
(lambda (x)
(syntax-case x ()
((_ (k arg rest ...) out ...)
(keyword? (syntax->datum (syntax k)))
(case (syntax->datum (syntax k))
((#:getter #:setter)
(syntax
(define-class-pre-definition (rest ...)
out ...
(if (or (not (defined? 'arg))
(not (is-a? arg <generic>)))
(toplevel-define!
'arg
(ensure-generic (if (defined? 'arg) arg #f) 'arg))))))
((#:accessor)
(syntax
(define-class-pre-definition (rest ...)
out ...
(if (or (not (defined? 'arg))
(not (is-a? arg <accessor>)))
(toplevel-define!
'arg
(ensure-accessor (if (defined? 'arg) arg #f) 'arg))))))
(else
(syntax
(define-class-pre-definition (rest ...) out ...)))))
((_ () out ...)
(syntax (begin out ...))))))
;; Some slot options require extra definitions to be made. In
;; particular, we want to make sure that the generic function objects
;; which represent accessors exist before `make-class' tries to add
;; methods to them.
(define-syntax define-class-pre-definitions
(lambda (x)
(syntax-case x ()
((_ () out ...)
(syntax (begin out ...)))
((_ (slot rest ...) out ...)
(keyword? (syntax->datum (syntax slot)))
(syntax (begin out ...)))
((_ (slot rest ...) out ...)
(identifier? (syntax slot))
(syntax (define-class-pre-definitions (rest ...)
out ...)))
((_ ((slotname slotopt ...) rest ...) out ...)
(syntax (define-class-pre-definitions (rest ...)
out ... (define-class-pre-definition (slotopt ...))))))))
(define-syntax define-class
(syntax-rules ()
((_ name supers slot ...)
(begin
(define-class-pre-definitions (slot ...))
(if (and (defined? 'name)
(is-a? name <class>)
(memq <object> (class-precedence-list name)))
(class-redefinition name
(class supers slot ... #:name 'name))
(toplevel-define! 'name (class supers slot ... #:name 'name)))))))
(define-syntax standard-define-class
(syntax-rules ()
((_ arg ...) (define-class arg ...))))
;;;
;;; {Generic functions and accessors}
;;;
@ -363,13 +391,13 @@
(else (make <generic> #:name name)))))
;; same semantics as <generic>
(define-macro (define-accessor name)
(if (not (symbol? name))
(goops-error "bad accessor name: ~S" name))
`(define ,name
(if (and (defined? ',name) (is-a? ,name <accessor>))
(make <accessor> #:name ',name)
(ensure-accessor (if (defined? ',name) ,name #f) ',name))))
(define-syntax define-accessor
(syntax-rules ()
((_ name)
(define name
(cond ((not (defined? 'name)) (ensure-accessor #f 'name))
((is-a? name <accessor>) (make <accessor> #:name 'name))
(else (ensure-accessor name 'name)))))))
(define (make-setter-name name)
(string->symbol (string-append "setter:" (symbol->string name))))
@ -424,78 +452,132 @@
;;; {Methods}
;;;
(define-macro (define-method head . body)
(if (not (pair? head))
(goops-error "bad method head: ~S" head))
(let ((gf (car head)))
(cond ((and (pair? gf)
(eq? (car gf) 'setter)
(pair? (cdr gf))
(symbol? (cadr gf))
(null? (cddr gf)))
;; named setter method
(let ((name (cadr gf)))
(cond ((not (symbol? name))
`(add-method! (setter ,name)
(method ,(cdr head) ,@body)))
(else
`(begin
(if (or (not (defined? ',name))
(not (is-a? ,name <accessor>)))
(define-accessor ,name))
(add-method! (setter ,name)
(method ,(cdr head) ,@body)))))))
((not (symbol? gf))
`(add-method! ,gf (method ,(cdr head) ,@body)))
(else
`(begin
;; FIXME: this code is how it always was, but it's quite
;; cracky: it will only define the generic function if it
;; was undefined before (ok), or *was defined to #f*. The
;; latter is crack. But there are bootstrap issues about
;; fixing this -- change it to (is-a? ,gf <generic>) and
;; see.
(if (or (not (defined? ',gf))
(not ,gf))
(define-generic ,gf))
(add-method! ,gf
(method ,(cdr head) ,@body)))))))
(define (toplevel-define! name val)
(module-define! (current-module) name val))
(define-macro (method args . body)
(letrec ((specializers
(lambda (ls)
(cond ((null? ls) (list (list 'quote '())))
((pair? ls) (cons (if (pair? (car ls))
(cadar ls)
'<top>)
(specializers (cdr ls))))
(else '(<top>)))))
(formals
(lambda (ls)
(if (pair? ls)
(cons (if (pair? (car ls)) (caar ls) (car ls))
(formals (cdr ls)))
ls))))
(let ((make-proc (compile-make-procedure (formals args)
(specializers args)
body)))
`(make <method>
#:specializers (cons* ,@(specializers args))
#:formals ',(formals args)
#:body ',body
#:make-procedure ,make-proc
#:procedure ,(and (not make-proc)
;; that is to say: we set #:procedure if
;; `compile-make-procedure' returned `#f',
;; which is the case if `body' does not
;; contain a call to `next-method'
`(lambda ,(formals args)
,@(if (null? body)
;; This used to be '((begin)), but
;; guile's memoizer doesn't like
;; (lambda args (begin)).
'((if #f #f))
body)))))))
(define-syntax define-method
(syntax-rules (setter)
((_ ((setter name) . args) body ...)
(begin
(if (or (not (defined? 'name))
(not (is-a? name <accessor>)))
(toplevel-define! 'name
(ensure-accessor
(if (defined? 'name) name #f) 'name)))
(add-method! (setter name) (method args body ...))))
((_ (name . args) body ...)
(begin
;; FIXME: this code is how it always was, but it's quite cracky:
;; it will only define the generic function if it was undefined
;; before (ok), or *was defined to #f*. The latter is crack. But
;; there are bootstrap issues about fixing this -- change it to
;; (is-a? name <generic>) and see.
(if (or (not (defined? 'name))
(not name))
(toplevel-define! 'name (make <generic> #:name 'name)))
(add-method! name (method args body ...))))))
(define-syntax method
(lambda (x)
(define (parse-args args)
(let lp ((ls args) (formals '()) (specializers '()))
(syntax-case ls ()
(((f s) . rest)
(and (identifier? (syntax f)) (identifier? (syntax s)))
(lp (syntax rest)
(cons (syntax f) formals)
(cons (syntax s) specializers)))
((f . rest)
(identifier? (syntax f))
(lp (syntax rest)
(cons (syntax f) formals)
(cons (syntax <top>) specializers)))
(()
(list (reverse formals)
(reverse (cons (syntax '()) specializers))))
(tail
(identifier? (syntax tail))
(list (append (reverse formals) (syntax tail))
(reverse (cons (syntax <top>) specializers)))))))
(define (find-free-id exp referent)
(syntax-case exp ()
((x . y)
(or (find-free-id (syntax x) referent)
(find-free-id (syntax y) referent)))
(x
(identifier? (syntax x))
(let ((id (datum->syntax (syntax x) referent)))
(and (free-identifier=? (syntax x) id) id)))
(_ #f)))
(define (compute-procedure formals body)
(syntax-case body ()
((body0 ...)
(with-syntax ((formals formals))
(syntax (lambda formals body0 ...))))))
(define (->proper args)
(let lp ((ls args) (out '()))
(syntax-case ls ()
((x . xs) (lp (syntax xs) (cons (syntax x) out)))
(() (reverse out))
(tail (reverse (cons (syntax tail) out))))))
(define (compute-make-procedure formals body next-method)
(syntax-case body ()
((body ...)
(with-syntax ((next-method next-method))
(syntax-case formals ()
((formal ...)
(syntax
(lambda (real-next-method)
(lambda (formal ...)
(let ((next-method (lambda args
(if (null? args)
(real-next-method formal ...)
(apply real-next-method args)))))
body ...)))))
(formals
(with-syntax (((formal ...) (->proper (syntax formals))))
(syntax
(lambda (real-next-method)
(lambda formals
(let ((next-method (lambda args
(if (null? args)
(apply real-next-method formal ...)
(apply real-next-method args)))))
body ...)))))))))))
(define (compute-procedures formals body)
;; So, our use of this is broken, because it operates on the
;; pre-expansion source code. It's equivalent to just searching
;; for referent in the datums. Ah well.
(let ((id (find-free-id body 'next-method)))
(if id
;; return a make-procedure
(values (syntax #f)
(compute-make-procedure formals body id))
(values (compute-procedure formals body)
(syntax #f)))))
(syntax-case x ()
((_ args) (syntax (method args (if #f #f))))
((_ args body0 body1 ...)
(with-syntax (((formals (specializer ...)) (parse-args (syntax args))))
(call-with-values
(lambda ()
(compute-procedures (syntax formals) (syntax (body0 body1 ...))))
(lambda (procedure make-procedure)
(with-syntax ((procedure procedure)
(make-procedure make-procedure))
(syntax
(make <method>
#:specializers (cons* specializer ...)
#:formals 'formals
#:body '(body0 body1 ...)
#:make-procedure make-procedure
#:procedure procedure))))))))))
;;;
;;; {add-method!}
@ -1046,27 +1128,9 @@
;; lookup. Also, @slot-ref and @slot-set! have their own bytecodes.
(eval-when (compile)
(use-modules ((language scheme compile-ghil) :select (define-scheme-translator))
((language ghil) :select (make-ghil-inline make-ghil-call))
(system base pmatch))
;; unfortunately, can't use define-inline because these are primitive
;; syntaxen.
(define-scheme-translator @slot-ref
((,obj ,index) (guard (integer? index)
(>= index 0) (< index max-fixnum))
(make-ghil-inline #f #f 'slot-ref
(list (retrans obj) (retrans index))))
(else
(make-ghil-call e l (retrans (car exp)) (map retrans (cdr exp)))))
(define-scheme-translator @slot-set!
((,obj ,index ,val) (guard (integer? index)
(>= index 0) (< index max-fixnum))
(make-ghil-inline #f #f 'slot-set
(list (retrans obj) (retrans index) (retrans val))))
(else
(make-ghil-call e l (retrans (car exp)) (map retrans (cdr exp))))))
(use-modules ((language tree-il primitives) :select (add-interesting-primitive!)))
(add-interesting-primitive! '@slot-ref)
(add-interesting-primitive! '@slot-set!))
(eval-when (eval load compile)
(define num-standard-pre-cache 20))

32
module/oop/goops/compile.scm
View file

@ -24,7 +24,7 @@
(define-module (oop goops compile)
:use-module (oop goops)
:use-module (oop goops util)
:export (compute-cmethod compile-make-procedure)
:export (compute-cmethod)
:no-backtrace
)
@ -60,9 +60,7 @@
;;; So, for the reader: there basic idea is that, given that the
;;; semantics of `next-method' depend on the concrete types being
;;; dispatched, why not compile a specific procedure to handle each type
;;; combination that we see at runtime. There are two compilation
;;; strategies implemented: one for the memoizer, and one for the VM
;;; compiler.
;;; combination that we see at runtime.
;;;
;;; In theory we can do much better than a bytecode compilation, because
;;; we know the *exact* types of the arguments. It's ideal for native
@ -71,32 +69,6 @@
;;; I think this whole generic application mess would benefit from a
;;; strict MOP.
;;; Temporary solution---return #f if x doesn't refer to `next-method'.
(define (next-method? x)
(and (pair? x)
(or (eq? (car x) 'next-method)
(next-method? (car x))
(next-method? (cdr x)))))
;; Called by the `method' macro in goops.scm.
(define (compile-make-procedure formals specializers body)
(and (next-method? body)
(let ((next-method-sym (gensym " next-method"))
(args-sym (gensym)))
`(lambda (,next-method-sym)
(lambda ,formals
(let ((next-method (lambda ,args-sym
(if (null? ,args-sym)
,(if (list? formals)
`(,next-method-sym ,@formals)
`(apply
,next-method-sym
,@(improper->proper formals)))
(apply ,next-method-sym ,args-sym)))))
,@(if (null? body)
'((begin))
body)))))))
(define (compile-method methods types)
(let ((make-procedure (slot-ref (car methods) 'make-procedure)))
(if make-procedure

5
module/oop/goops/dispatch.scm
View file

@ -209,9 +209,8 @@
;;;
;; Backward compatibility
(if (not (defined? 'lookup-create-cmethod))
(define (lookup-create-cmethod gf args)
(no-applicable-method (car args) (cadr args))))
(define (lookup-create-cmethod gf args)
(no-applicable-method (car args) (cadr args)))
(define (memoize-method! gf args exp)
(if (not (slot-ref gf 'used-by))

4
module/oop/goops/save.scm
View file

@ -110,9 +110,7 @@
;;; Readables
;;;
(if (or (not (defined? 'readables))
(not readables))
(define readables (make-weak-key-hash-table 61)))
(define readables (make-weak-key-hash-table 61))
(define-macro (readable exp)
`(make-readable ,exp ',(copy-tree exp)))

5
module/oop/goops/simple.scm
View file

@ -23,6 +23,9 @@
:export (define-class)
:no-backtrace)
(define define-class define-class-with-accessors-keywords)
(define-syntax define-class
(syntax-rules ()
((_ arg ...)
(define-class-with-accessors-keywords arg ...))))
(module-use! %module-public-interface (resolve-interface '(oop goops)))

71
module/oop/goops/stklos.scm
View file

@ -47,51 +47,30 @@
;;; Enable keyword support (*fixme*---currently this has global effect)
(read-set! keywords 'prefix)
(define standard-define-class-transformer
(macro-transformer standard-define-class))
(define-syntax define-class
(syntax-rules ()
((_ name supers (slot ...) rest ...)
(standard-define-class name supers slot ... rest ...))))
(define define-class
;; Syntax
(let ((name cadr)
(supers caddr)
(slots cadddr)
(rest cddddr))
(procedure->memoizing-macro
(lambda (exp env)
(standard-define-class-transformer
`(define-class ,(name exp) ,(supers exp) ,@(slots exp)
,@(rest exp))
env)))))
(define (toplevel-define! name val)
(module-define! (current-module) name val))
(define define-method
(procedure->memoizing-macro
(lambda (exp env)
(let ((name (cadr exp)))
(if (and (pair? name)
(eq? (car name) 'setter)
(pair? (cdr name))
(null? (cddr name)))
(let ((name (cadr name)))
(cond ((not (symbol? name))
(goops-error "bad method name: ~S" name))
((defined? name env)
`(begin
(if (not (is-a? ,name <generic-with-setter>))
(define-accessor ,name))
(add-method! (setter ,name) (method ,@(cddr exp)))))
(else
`(begin
(define-accessor ,name)
(add-method! (setter ,name) (method ,@(cddr exp)))))))
(cond ((not (symbol? name))
(goops-error "bad method name: ~S" name))
((defined? name env)
`(begin
(if (not (or (is-a? ,name <generic>)
(is-a? ,name <primitive-generic>)))
(define-generic ,name))
(add-method! ,name (method ,@(cddr exp)))))
(else
`(begin
(define-generic ,name)
(add-method! ,name (method ,@(cddr exp)))))))))))
(define-syntax define-method
(syntax-rules (setter)
((_ (setter name) rest ...)
(begin
(if (or (not (defined? 'name))
(not (is-a? name <generic-with-setter>)))
(toplevel-define! 'name
(ensure-accessor
(if (defined? 'name) name #f) 'name)))
(add-method! (setter name) (method rest ...))))
((_ name rest ...)
(begin
(if (or (not (defined? 'name))
(not (or (is-a? name <generic>)
(is-a? name <primitive-generic>))))
(toplevel-define! 'name
(ensure-generic
(if (defined? 'name) name #f) 'name)))
(add-method! name (method rest ...))))))

1
module/srfi/srfi-11.scm
View file

@ -37,7 +37,6 @@
;;; Code:
(define-module (srfi srfi-11)
:use-module (ice-9 syncase)
:export-syntax (let-values let*-values))
(cond-expand-provide (current-module) '(srfi-11))

10
module/srfi/srfi-18.scm
View file

@ -151,8 +151,10 @@
(hashq-set! thread-exception-handlers ct hl)
(handler obj))
(lambda ()
(let ((r (thunk)))
(hashq-set! thread-exception-handlers ct hl) r))))))
(call-with-values thunk
(lambda res
(hashq-set! thread-exception-handlers ct hl)
(apply values res))))))))
(define (current-exception-handler)
(car (current-handler-stack)))
@ -249,8 +251,8 @@
(define (wrap thunk)
(lambda (continuation)
(with-exception-handler (lambda (obj)
(apply (current-exception-handler) (list obj))
(apply continuation (list)))
((current-exception-handler) obj)
(continuation))
thunk)))
;; A pass-thru to cancel-thread that first installs a handler that throws

1
module/srfi/srfi-39.scm
View file

@ -35,7 +35,6 @@
;;; Code:
(define-module (srfi srfi-39)
#:use-module (ice-9 syncase)
#:use-module (srfi srfi-16)
#:export (make-parameter)

20
module/system/base/compile.scm
View file

@ -29,7 +29,7 @@
#:export (syntax-error
*current-language*
compiled-file-name compile-file compile-and-load
compile compile-time-environment
compile
decompile)
#:export-syntax (call-with-compile-error-catch))
@ -107,9 +107,9 @@
port)))
comp))
(define* (compile-and-load file #:key (to 'value) (opts '()))
(read-and-compile (open-input-port file)
#:from lang #:to to #:opts opts))
(define* (compile-and-load file #:key (from 'scheme) (to 'value) (opts '()))
(read-and-compile (open-input-file file)
#:from from #:to to #:opts opts))
(define (compiled-file-name file)
(let ((base (basename file))
@ -135,11 +135,6 @@
;;; Compiler interface
;;;
(define (read-file-in file lang)
(call-with-input-file file
(or (language-read-file lang)
(error "language has no #:read-file" lang))))
(define (compile-passes from to opts)
(map cdr
(or (lookup-compilation-order from to)
@ -152,13 +147,6 @@
(receive (x e new-cenv) ((car passes) x e opts)
(lp (cdr passes) x e (if first? new-cenv cenv) #f)))))
(define (compile-time-environment)
"A special function known to the compiler that, when compiled, will
return a representation of the lexical environment in place at compile
time. Useful for supporting some forms of dynamic compilation. Returns
#f if called from the interpreter."
#f)
(define (find-language-joint from to)
(let lp ((in (reverse (or (lookup-compilation-order from to)
(error "no way to compile" from "to" to))))

3
module/system/base/language.scm
View file

@ -23,7 +23,7 @@
#:use-module (system base syntax)
#:export (define-language language? lookup-language make-language
language-name language-title language-version language-reader
language-printer language-parser language-read-file
language-printer language-parser
language-compilers language-decompilers language-evaluator
language-joiner
@ -42,7 +42,6 @@
reader
printer
(parser #f)
(read-file #f)
(compilers '())
(decompilers '())
(evaluator #f)

7
module/system/base/pmatch.scm
View file

@ -1,5 +1,4 @@
(define-module (system base pmatch)
#:use-module (ice-9 syncase)
#:export (pmatch))
;; FIXME: shouldn't have to export ppat...
@ -17,15 +16,15 @@
(let ((v (op arg ...)))
(pmatch v cs ...)))
((_ v) (if #f #f))
((_ v (else e0 e ...)) (begin e0 e ...))
((_ v (else e0 e ...)) (let () e0 e ...))
((_ v (pat (guard g ...) e0 e ...) cs ...)
(let ((fk (lambda () (pmatch v cs ...))))
(ppat v pat
(if (and g ...) (begin e0 e ...) (fk))
(if (and g ...) (let () e0 e ...) (fk))
(fk))))
((_ v (pat e0 e ...) cs ...)
(let ((fk (lambda () (pmatch v cs ...))))
(ppat v pat (begin e0 e ...) (fk))))))
(ppat v pat (let () e0 e ...) (fk))))))
(define-syntax ppat
(syntax-rules (_ quote unquote)

2
module/system/repl/repl.scm
View file

@ -89,7 +89,7 @@
(catch #t
(lambda () (%start-stack #t thunk))
default-catch-handler
pre-unwind-handler-dispatch))
default-pre-unwind-handler))
(define-macro (with-backtrace form)
`(call-with-backtrace (lambda () ,form)))