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

Merge branch 'master' into boehm-demers-weiser-gc

Browse source 
Conflicts:
	lib/Makefile.am
	libguile/Makefile.am
	libguile/frames.c
	libguile/gc-card.c
	libguile/gc-freelist.c
	libguile/gc-mark.c
	libguile/gc-segment.c
	libguile/gc_os_dep.c
	libguile/load.c
	libguile/macros.c
	libguile/objcodes.c
	libguile/programs.c
	libguile/strings.c
	libguile/vm.c
	m4/gnulib-cache.m4
	m4/gnulib-comp.m4
	m4/inline.m4
This commit is contained in:
Ludovic Courtès 2009-08-17 23:39:56 +02:00
commit fbb857a472
823 changed files with 61674 additions and 14111 deletions
Download patch file Download diff file Expand all files Collapse all files

251
module/Makefile.am
View file

@ -4,55 +4,88 @@
##
## This file is part of GUILE.
##
## GUILE 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
## GUILE 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 3, or
## (at your option) any later version.
##
## GUILE 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.
## GNU Lesser General Public License for more details.
##
## You should have received a copy of the GNU General Public
## License along with GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
## You should have received a copy of the GNU Lesser General Public
## License along with GUILE; see the file COPYING.LESSER. If not,
## write to the Free Software Foundation, Inc., 51 Franklin Street,
## Fifth Floor, Boston, MA 02110-1301 USA
# Build the compiler and VM support first to avoid stack overflows
# when building the rest.
SUBDIRS = . ice-9 srfi oop
include $(top_srcdir)/am/guilec
# We're at the root of the module hierarchy.
modpath =
# Compile psyntax and boot-9 first, so that we get the speed benefit in
# the rest of the compilation. Also, if there is too much switching back
# and forth between interpreted and compiled code, we end up using more
# of the C stack than the interpreter would have; so avoid that by
# putting these core modules first.
SOURCES = \
ice-9/psyntax-pp.scm \
system/base/pmatch.scm system/base/syntax.scm \
system/base/compile.scm system/base/language.scm \
system/base/message.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 \
language/tree-il.scm \
language/glil.scm language/assembly.scm \
\
system/xref.scm \
\
system/repl/repl.scm system/repl/common.scm \
system/repl/command.scm \
\
language/ghil.scm language/glil.scm language/assembly.scm \
\
$(SCHEME_LANG_SOURCES) $(ECMASCRIPT_LANG_SOURCES) \
$(GHIL_LANG_SOURCES) $(GLIL_LANG_SOURCES) \
$(SCHEME_LANG_SOURCES) \
$(TREE_IL_LANG_SOURCES) \
$(GLIL_LANG_SOURCES) \
$(ASSEMBLY_LANG_SOURCES) $(BYTECODE_LANG_SOURCES) \
$(OBJCODE_LANG_SOURCES) $(VALUE_LANG_SOURCES)
$(OBJCODE_LANG_SOURCES) $(VALUE_LANG_SOURCES) \
\
$(ICE_9_SOURCES) \
$(SRFI_SOURCES) \
$(RNRS_SOURCES) \
$(OOP_SOURCES) \
$(SYSTEM_SOURCES) \
$(SCRIPTS_SOURCES) \
$(GHIL_LANG_SOURCES) \
$(ECMASCRIPT_LANG_SOURCES) \
$(BRAINFUCK_LANG_SOURCES)
## test.scm is not currently installed.
EXTRA_DIST += ice-9/test.scm ice-9/compile-psyntax.scm ice-9/ChangeLog-2008
# We expect this to never be invoked when there is not already
# ice-9/psyntax-pp.scm in %load-path, since compile-psyntax.scm depends
# on ice-9/syncase.scm, which does `(load-from-path "ice-9/psyntax-pp.scm")'.
# In other words, to bootstrap this file, you need to do something like:
# GUILE_LOAD_PATH=/usr/local/share/guile/1.5.4 make psyntax-pp.scm
include $(top_srcdir)/am/pre-inst-guile
ice-9/psyntax-pp.scm: ice-9/psyntax.scm
$(preinstguile) --no-autocompile -s $(srcdir)/ice-9/compile-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
GHIL_LANG_SOURCES = \
language/ghil/spec.scm language/ghil/compile-glil.scm
TREE_IL_LANG_SOURCES = \
language/tree-il/primitives.scm \
language/tree-il/optimize.scm \
language/tree-il/inline.scm \
language/tree-il/fix-letrec.scm \
language/tree-il/analyze.scm \
language/tree-il/compile-glil.scm \
language/tree-il/spec.scm
GHIL_LANG_SOURCES = \
language/ghil.scm language/ghil/spec.scm language/ghil/compile-glil.scm
GLIL_LANG_SOURCES = \
language/glil/spec.scm language/glil/compile-assembly.scm \
@ -77,14 +110,166 @@ ECMASCRIPT_LANG_SOURCES = \
language/ecmascript/parse-lalr.scm \
language/ecmascript/tokenize.scm \
language/ecmascript/parse.scm \
language/ecmascript/spec.scm \
language/ecmascript/impl.scm \
language/ecmascript/base.scm \
language/ecmascript/function.scm \
language/ecmascript/array.scm \
language/ecmascript/compile-ghil.scm
language/ecmascript/compile-tree-il.scm \
language/ecmascript/spec.scm
BRAINFUCK_LANG_SOURCES = \
language/brainfuck/parse.scm \
language/brainfuck/compile-scheme.scm \
language/brainfuck/compile-tree-il.scm \
language/brainfuck/spec.scm
SCRIPTS_SOURCES = \
scripts/PROGRAM.scm \
scripts/autofrisk.scm \
scripts/compile.scm \
scripts/disassemble.scm \
scripts/display-commentary.scm \
scripts/doc-snarf.scm \
scripts/frisk.scm \
scripts/generate-autoload.scm \
scripts/lint.scm \
scripts/punify.scm \
scripts/read-scheme-source.scm \
scripts/read-text-outline.scm \
scripts/use2dot.scm \
scripts/snarf-check-and-output-texi.scm \
scripts/summarize-guile-TODO.scm \
scripts/scan-api.scm \
scripts/api-diff.scm \
scripts/read-rfc822.scm \
scripts/snarf-guile-m4-docs.scm
ICE_9_SOURCES = \
ice-9/boot-9.scm \
ice-9/r4rs.scm \
ice-9/r5rs.scm \
ice-9/and-let-star.scm \
ice-9/calling.scm \
ice-9/common-list.scm \
ice-9/debug.scm \
ice-9/debugger.scm \
ice-9/documentation.scm \
ice-9/emacs.scm \
ice-9/expect.scm \
ice-9/format.scm \
ice-9/getopt-long.scm \
ice-9/hcons.scm \
ice-9/i18n.scm \
ice-9/lineio.scm \
ice-9/ls.scm \
ice-9/mapping.scm \
ice-9/match.scm \
ice-9/networking.scm \
ice-9/null.scm \
ice-9/occam-channel.scm \
ice-9/optargs.scm \
ice-9/poe.scm \
ice-9/popen.scm \
ice-9/posix.scm \
ice-9/q.scm \
ice-9/rdelim.scm \
ice-9/receive.scm \
ice-9/regex.scm \
ice-9/runq.scm \
ice-9/rw.scm \
ice-9/safe-r5rs.scm \
ice-9/safe.scm \
ice-9/session.scm \
ice-9/slib.scm \
ice-9/stack-catch.scm \
ice-9/streams.scm \
ice-9/string-fun.scm \
ice-9/syncase.scm \
ice-9/threads.scm \
ice-9/buffered-input.scm \
ice-9/time.scm \
ice-9/history.scm \
ice-9/channel.scm \
ice-9/pretty-print.scm \
ice-9/ftw.scm \
ice-9/gap-buffer.scm \
ice-9/weak-vector.scm \
ice-9/deprecated.scm \
ice-9/list.scm \
ice-9/serialize.scm \
ice-9/gds-server.scm
SRFI_SOURCES = \
srfi/srfi-1.scm \
srfi/srfi-2.scm \
srfi/srfi-4.scm \
srfi/srfi-6.scm \
srfi/srfi-8.scm \
srfi/srfi-9.scm \
srfi/srfi-10.scm \
srfi/srfi-11.scm \
srfi/srfi-13.scm \
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 \
srfi/srfi-34.scm \
srfi/srfi-35.scm \
srfi/srfi-37.scm \
srfi/srfi-39.scm \
srfi/srfi-60.scm \
srfi/srfi-69.scm \
srfi/srfi-88.scm \
srfi/srfi-98.scm
RNRS_SOURCES = \
rnrs/bytevector.scm \
rnrs/io/ports.scm
EXTRA_DIST += scripts/ChangeLog-2008
EXTRA_DIST += scripts/README
OOP_SOURCES = \
oop/goops.scm \
oop/goops/active-slot.scm \
oop/goops/compile.scm \
oop/goops/composite-slot.scm \
oop/goops/describe.scm \
oop/goops/dispatch.scm \
oop/goops/internal.scm \
oop/goops/save.scm \
oop/goops/stklos.scm \
oop/goops/util.scm \
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 = \
system/repl/describe.scm
include $(top_srcdir)/am/guilec
ice-9/gds-client.scm \
ice-9/psyntax.scm \
system/repl/describe.scm \
ice-9/debugger/command-loop.scm \
ice-9/debugger/commands.scm \
ice-9/debugger/state.scm \
ice-9/debugger/trc.scm \
ice-9/debugger/utils.scm \
ice-9/debugging/example-fns.scm \
ice-9/debugging/ice-9-debugger-extensions.scm \
ice-9/debugging/steps.scm \
ice-9/debugging/trace.scm \
ice-9/debugging/traps.scm \
ice-9/debugging/trc.scm

70
module/ice-9/Makefile.am
View file

@ -1,70 +0,0 @@
## Process this file with automake to produce Makefile.in.
##
## Copyright (C) 1998,1999,2000,2001,2003, 2004, 2006, 2008 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
## GUILE 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.
##
## GUILE 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 GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
AUTOMAKE_OPTIONS = gnu
SUBDIRS = debugger debugging
# These should be installed and distributed.
modpath = ice-9
# Compile psyntax and boot-9 first, so that we get the speed benefit in
# the rest of the compilation. Also, if there is too much switching back
# and forth between interpreted and compiled code, we end up using more
# of the C stack than the interpreter would have; so avoid that by
# putting these core modules first.
SOURCES = psyntax-pp.scm annotate.scm boot-9.scm \
and-let-star.scm calling.scm common-list.scm \
debug.scm debugger.scm documentation.scm emacs.scm expect.scm \
format.scm getopt-long.scm hcons.scm i18n.scm \
lineio.scm ls.scm mapping.scm match.scm \
networking.scm null.scm occam-channel.scm optargs.scm poe.scm \
popen.scm posix.scm q.scm r4rs.scm r5rs.scm \
rdelim.scm receive.scm regex.scm runq.scm rw.scm \
safe-r5rs.scm safe.scm session.scm slib.scm stack-catch.scm \
streams.scm string-fun.scm syncase.scm threads.scm \
buffered-input.scm time.scm history.scm channel.scm \
pretty-print.scm ftw.scm gap-buffer.scm \
weak-vector.scm deprecated.scm list.scm serialize.scm \
gds-server.scm
# gds-client is tight with the memoizer, so punt on it until it can be
# made portable.
#
# psyntax.scm needs help. fortunately it's only needed when recompiling
# psyntax-pp.scm.
NOCOMP_SOURCES = gds-client.scm psyntax.scm
include $(top_srcdir)/am/guilec
## test.scm is not currently installed.
EXTRA_DIST += test.scm compile-psyntax.scm ChangeLog-2008
TAGS_FILES = $(SOURCES)
# We expect this to never be invoked when there is not already
# ice-9/psyntax-pp.scm in %load-path, since compile-psyntax.scm depends
# on ice-9/syncase.scm, which does `(load-from-path "ice-9/psyntax-pp.scm")'.
# In other words, to bootstrap this file, you need to do something like:
# GUILE_LOAD_PATH=/usr/local/share/guile/1.5.4 make psyntax-pp.scm
include $(top_srcdir)/am/pre-inst-guile
psyntax-pp.scm: psyntax.scm
$(preinstguile) -s $(srcdir)/compile-psyntax.scm \
$(srcdir)/psyntax.scm $(srcdir)/psyntax-pp.scm

2
module/ice-9/and-let-star.scm
View file

@ -6,7 +6,7 @@
;;;; 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.
;;;; version 3 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

80
module/ice-9/annotate.scm
View file

@ -1,80 +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 annotate)
:export (<annotation> annotation? annotate deannotate make-annotation
annotation-expression annotation-source annotation-stripped
set-annotation-stripped!
deannotate/source-properties))
(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)))

21
module/ice-9/arrays.scm
View file

@ -2,20 +2,19 @@
;;;; Copyright (C) 1999, 2001, 2004, 2006 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 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 3 of the License, or (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; 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 General Public License for more details.
;;;; 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 General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;;;; Boston, MA 02110-1301 USA
;;;; 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 (array-shape a)

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

File diff suppressed because it is too large Load diff

2
module/ice-9/buffered-input.scm
View file

@ -5,7 +5,7 @@
;;;; 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.
;;;; version 3 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

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

@ -5,7 +5,7 @@
;;;; 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.
;;;; version 3 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

26
module/ice-9/channel.scm
View file

@ -2,19 +2,19 @@
;; Copyright (C) 2001, 2006 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
;;;; 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 3 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
;;; Commentary:

2
module/ice-9/common-list.scm
View file

@ -5,7 +5,7 @@
;;;; 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.
;;;; version 3 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

43
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"))))
(with-fluids ((expansion-eval-closure
(module-eval-closure (current-module))))
(use-modules (language tree-il) (ice-9 pretty-print))
(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 (sc-expand3 x 'c '(compile load eval)) out)
(newline out)
(loop (read in)))))))
(system (format #f "mv -f ~s.tmp ~s" target target))
(begin
(close-port out)
(close-port in))
(begin
(pretty-print (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)))

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

@ -3,7 +3,7 @@
;;;; 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.
;;;; version 3 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

26
module/ice-9/debugger.scm
View file

@ -2,19 +2,19 @@
;;; Copyright (C) 1999, 2001, 2002, 2006 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
;;;; 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 3 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 debugger)
#:use-module (ice-9 debugger command-loop)

31
module/ice-9/debugger/Makefile.am
View file

@ -1,31 +0,0 @@
## Process this file with automake to produce Makefile.in.
##
## Copyright (C) 2002, 2004, 2006 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
## GUILE 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.
##
## GUILE 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 GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
AUTOMAKE_OPTIONS = gnu
# These should be installed and distributed.
ice9_debugger_sources = command-loop.scm commands.scm state.scm trc.scm utils.scm
subpkgdatadir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)/ice-9/debugger
subpkgdata_DATA = $(ice9_debugger_sources)
TAGS_FILES = $(subpkgdata_DATA)
EXTRA_DIST = $(ice9_debugger_sources)

26
module/ice-9/debugger/command-loop.scm
View file

@ -2,19 +2,19 @@
;;; Copyright (C) 1999, 2001, 2002, 2003, 2006 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
;;;; 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 3 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 debugger command-loop)
#:use-module ((ice-9 debugger commands) :prefix debugger:)

26
module/ice-9/debugger/commands.scm
View file

@ -2,19 +2,19 @@
;;; Copyright (C) 2002, 2006 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
;;;; 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 3 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 debugger commands)
#:use-module (ice-9 debug)

26
module/ice-9/debugger/state.scm
View file

@ -2,19 +2,19 @@
;;; Copyright (C) 2002, 2006 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
;;;; 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 3 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 debugger state)
#:export (make-state

26
module/ice-9/debugger/trc.scm
View file

@ -2,19 +2,19 @@
;;; Copyright (C) 2002, 2006 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
;;;; 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 3 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 debugger trc)
#:export (trc trc-syms trc-all trc-none trc-add trc-remove trc-port))

33
module/ice-9/debugging/Makefile.am
View file

@ -1,33 +0,0 @@
## Process this file with automake to produce Makefile.in.
##
## Copyright (C) 2006 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
## GUILE 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.
##
## GUILE 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 GUILE; see the file COPYING. If not, write
## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
## Floor, Boston, MA 02110-1301 USA
AUTOMAKE_OPTIONS = gnu
# These should be installed and distributed.
ice9_debugging_sources = example-fns.scm \
ice-9-debugger-extensions.scm \
steps.scm trace.scm traps.scm trc.scm
subpkgdatadir = $(pkgdatadir)/${GUILE_EFFECTIVE_VERSION}/ice-9/debugging
subpkgdata_DATA = $(ice9_debugging_sources)
TAGS_FILES = $(subpkgdata_DATA)
EXTRA_DIST = $(ice9_debugging_sources)

26
module/ice-9/debugging/breakpoints.scm
View file

@ -2,19 +2,19 @@
;;; Copyright (C) 2005 Neil Jerram
;;;
;; 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; 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 3 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
;;; This module provides a practical interface for setting and
;;; manipulating breakpoints.

26
module/ice-9/debugging/steps.scm
View file

@ -2,19 +2,19 @@
;;; Copyright (C) 2002, 2004 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; 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 3 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 debugging steps)
#:use-module (ice-9 debugging traps)

26
module/ice-9/debugging/trace.scm
View file

@ -2,19 +2,19 @@
;;; Copyright (C) 2002 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; 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 3 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 debugging trace)
#:use-module (ice-9 debug)

26
module/ice-9/debugging/traps.scm
View file

@ -3,19 +3,19 @@
;;; Copyright (C) 2002, 2004 Free Software Foundation, Inc.
;;; Copyright (C) 2005 Neil Jerram
;;;
;; 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; 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 3 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
;;; This module provides an abstraction around Guile's low level trap
;;; handler interface; its aim is to make the low level trap mechanism

26
module/ice-9/debugging/trc.scm
View file

@ -2,19 +2,19 @@
;;; Copyright (C) 2002, 2004 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; 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 3 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 debugging trc)
#:export (trc trc-syms trc-all trc-none trc-add trc-remove trc-port))

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

@ -3,7 +3,7 @@
;;;; 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.
;;;; version 3 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
@ -21,7 +21,7 @@
(define substring-move-right! substring-move!)
;; This method of dynamically linking Guile Extensions is deprecated.
;; Use `load-extension' explicitely from Scheme code instead.
;; Use `load-extension' explicitly from Scheme code instead.
(define (split-c-module-name str)
(let loop ((rev '())

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

@ -3,7 +3,7 @@
;;;; 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.
;;;; version 3 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
@ -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)

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

@ -3,7 +3,7 @@
;;;; 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.
;;;; version 3 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

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

@ -3,7 +3,7 @@
;;;; 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.
;;;; version 3 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

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

@ -5,7 +5,7 @@
;;;; 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.
;;;; version 3 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

26
module/ice-9/gap-buffer.scm
View file

@ -2,19 +2,19 @@
;;; Copyright (C) 2002, 2003, 2006 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
;;;; 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 3 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
;;;
;;; Author: Thien-Thi Nguyen <ttn@gnu.org>

26
module/ice-9/gds-server.scm
View file

@ -2,19 +2,19 @@
;;; Copyright (C) 2003 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;;; 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 3 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 gds-server)
#:export (run-server))

26
module/ice-9/getopt-long.scm
View file

@ -1,18 +1,18 @@
;;; Copyright (C) 1998, 2001, 2006, 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
;;;; 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 3 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
;;; Author: Russ McManus (rewritten by Thien-Thi Nguyen)

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

@ -5,7 +5,7 @@
;;;; 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.
;;;; version 3 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

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

@ -3,7 +3,7 @@
;;;; 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.
;;;; version 3 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

6
module/ice-9/i18n.scm
View file

@ -5,13 +5,13 @@
;;;; 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.
;;;;
;;;; version 3 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

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

@ -5,7 +5,7 @@
;;;; 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.
;;;; version 3 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

26
module/ice-9/list.scm
View file

@ -2,19 +2,19 @@
;;; Copyright (C) 2003, 2006 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
;;;; 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 3 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 list)
:export (rassoc rassv rassq))

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

@ -5,7 +5,7 @@
;;;; 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.
;;;; version 3 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

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

@ -5,7 +5,7 @@
;;;; 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.
;;;; version 3 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

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

@ -5,7 +5,7 @@
;;;; 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.
;;;; version 3 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
@ -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)))))

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

@ -5,7 +5,7 @@
;;;; 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.
;;;; version 3 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
@ -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))

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

@ -3,7 +3,7 @@
;;;; 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.
;;;; version 3 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
@ -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

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

@ -2,22 +2,21 @@
;;; Copyright (C) 2003, 2006 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
;;;; 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 3 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 occam-channel)
#:use-syntax (ice-9 syncase)
#:use-module (oop goops)
#:use-module (ice-9 threads)
#:export-syntax (alt

14
module/ice-9/optargs.scm
View file

@ -5,7 +5,7 @@
;;;; 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.
;;;; version 3 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
@ -410,15 +410,11 @@
;; (defmacro* transmorgify (a #:optional b)
(defmacro defmacro* (NAME ARGLIST . BODY)
(defmacro*-guts 'define NAME ARGLIST BODY))
`(define-macro ,NAME #f (lambda* ,ARGLIST ,@BODY)))
(defmacro defmacro*-public (NAME ARGLIST . BODY)
(defmacro*-guts 'define-public NAME ARGLIST BODY))
;; The guts of defmacro* and defmacro*-public
(define (defmacro*-guts DT NAME ARGLIST BODY)
`(,DT ,NAME
(,(lambda (transformer) (defmacro:transformer transformer))
(lambda* ,ARGLIST ,@BODY))))
`(begin
(defmacro* ,NAME ,ARGLIST ,@BODY)
(export-syntax ,NAME)))
;;; optargs.scm ends here

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

@ -5,7 +5,7 @@
;;;; 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.
;;;; version 3 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

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

@ -5,7 +5,7 @@
;;;; 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.
;;;; version 3 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

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

@ -5,7 +5,7 @@
;;;; 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.
;;;; version 3 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
@ -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))

2
module/ice-9/pretty-print.scm
View file

@ -5,7 +5,7 @@
;;;; 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.
;;;; version 3 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

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

File diff suppressed because one or more lines are too long

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

File diff suppressed because it is too large Load diff

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

@ -5,7 +5,7 @@
;;;; 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.
;;;; version 3 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

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

@ -6,7 +6,7 @@
;;;; 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.
;;;; version 3 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
@ -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/r5rs.scm
View file

@ -3,7 +3,7 @@
;;;; 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.
;;;; version 3 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

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

@ -5,7 +5,7 @@
;;;; 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.
;;;; version 3 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

26
module/ice-9/receive.scm
View file

@ -2,19 +2,19 @@
;;; Copyright (C) 2000, 2001, 2004, 2006 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
;;;; 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 3 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 receive)
:export (receive)

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

@ -3,7 +3,7 @@
;;;; 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.
;;;; version 3 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

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

@ -5,7 +5,7 @@
;;;; 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.
;;;; version 3 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

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

@ -5,7 +5,7 @@
;;;; 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.
;;;; version 3 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

2
module/ice-9/safe-r5rs.scm
View file

@ -3,7 +3,7 @@
;;;; 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.
;;;; version 3 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

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

@ -3,7 +3,7 @@
;;;; 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.
;;;; version 3 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

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

@ -3,7 +3,7 @@
;;;; 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.
;;;; version 3 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

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

@ -3,7 +3,7 @@
;;;; 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.
;;;; version 3 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

6
module/ice-9/slib.scm
View file

@ -5,13 +5,13 @@
;;;; 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.
;;;;
;;;; version 3 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

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

@ -5,7 +5,7 @@
;;;; 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.
;;;; version 3 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
@ -40,4 +40,4 @@ this call to @code{catch}."
(catch key
thunk
handler
pre-unwind-handler-dispatch))
default-pre-unwind-handler))

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

@ -6,7 +6,7 @@
;;;; 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.
;;;; version 3 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

2
module/ice-9/string-fun.scm
View file

@ -5,7 +5,7 @@
;;;; 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.
;;;; version 3 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

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

@ -3,7 +3,7 @@
;;;; 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.
;;;; version 3 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
@ -17,236 +17,15 @@
(define-module (ice-9 syncase)
:use-module (ice-9 debug)
:use-module (ice-9 threads)
:export-syntax (sc-macro define-syntax define-syntax-public
eval-when 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))
)
(define expansion-eval-closure (make-fluid))
(define (current-eval-closure)
(or (fluid-ref expansion-eval-closure)
(module-eval-closure (current-module))))
(define (env->eval-closure env)
(and env (car (last-pair env))))
(define (annotation? x) #f)
(define sc-macro
(procedure->memoizing-macro
(lambda (exp env)
(with-fluids ((expansion-eval-closure (env->eval-closure env)))
(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 the-syncase-eval-closure (module-eval-closure the-syncase-module))
(fluid-set! expansion-eval-closure the-syncase-eval-closure)
(define (putprop symbol key binding)
(let* ((eval-closure (current-eval-closure))
;; Why not simply do (eval-closure symbol #t)?
;; Answer: That would overwrite imported bindings
(v (or (eval-closure symbol #f) ;lookup
(eval-closure symbol #t) ;create it locally
)))
;; Don't destroy Guile macros corresponding to
;; primitive syntax when syncase boots.
(if (not (and (symbol-property symbol 'primitive-syntax)
(eq? eval-closure the-syncase-eval-closure)))
(variable-set! v sc-macro))
;; Properties are tied to variable objects
(set-object-property! v key binding)))
(define (getprop symbol key)
(let* ((v ((current-eval-closure) symbol #f)))
(and v
(or (object-property v key)
(and (variable-bound? v)
(macro? (variable-ref v))
(macro-transformer (variable-ref v)) ;non-primitive
guile-macro)))))
(define guile-macro
(cons 'external-macro
(lambda (e r w s)
(let ((e (syntax-object->datum e)))
(if (symbol? e)
;; pass the expression through
e
(let* ((eval-closure (current-eval-closure))
(m (variable-ref (eval-closure (car e) #f))))
(if (eq? (macro-type m) 'syntax)
;; pass the expression through
e
;; perform Guile macro transform
(let ((e ((macro-transformer m)
e
(append r (list eval-closure)))))
(if (variable? e)
e
(if (null? r)
(sc-expand e)
(sc-chi e r w)))))))))))
(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))))
;;; The following lines are necessary only if we start making changes
;; (use-syntax sc-expand)
;; (load-from-path "ice-9/psyntax")
(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"))
(cadr x)
(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)
(with-fluids ((expansion-eval-closure
(module-eval-closure (current-module))))
(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 ...)))))
(fluid-set! expansion-eval-closure #f)
;; 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))))

26
module/ice-9/test.scm
View file

@ -1,18 +1,18 @@
;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2006 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
;;;; 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 3 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
;;;; "test.scm" Test correctness of scheme implementations.
;;; Author: Aubrey Jaffer

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

@ -3,7 +3,7 @@
;;;; 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.
;;;; version 3 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
@ -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

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

@ -3,7 +3,7 @@
;;;; 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.
;;;; version 3 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
@ -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/ice-9/weak-vector.scm
View file

@ -5,7 +5,7 @@
;;;; 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.
;;;; version 3 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

105
module/language/assembly.scm
View file

@ -2,57 +2,54 @@
;; 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.
;;;; 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 3 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
;;; Code:
(define-module (language assembly)
#:use-module (rnrs bytevector)
#:use-module (system base pmatch)
#:use-module (system vm instruction)
#:use-module ((srfi srfi-1) #:select (fold))
#:export (byte-length
addr+ align-program
addr+ align-program align-code align-block
assembly-pack assembly-unpack
object->assembly assembly->object))
;; nargs, nrest, nlocs, nexts, len, metalen
(define *program-header-len* (+ 1 1 1 1 4 4))
;; nargs, nrest, nlocs, len, metalen, padding
(define *program-header-len* (+ 1 1 2 4 4 4))
;; lengths are encoded in 3 bytes
(define *len-len* 3)
(define (byte-length assembly)
(pmatch assembly
(,label (guard (not (pair? label)))
0)
((load-unsigned-integer ,str)
(+ 1 *len-len* (string-length str)))
((load-integer ,str)
(+ 1 *len-len* (string-length str)))
((load-number ,str)
(+ 1 *len-len* (string-length str)))
((load-string ,str)
(+ 1 *len-len* (string-length str)))
((load-wide-string ,str)
(+ 1 *len-len* (* 4 (string-length str))))
((load-symbol ,str)
(+ 1 *len-len* (string-length str)))
((load-keyword ,str)
(+ 1 *len-len* (string-length str)))
((define ,str)
(+ 1 *len-len* (string-length str)))
((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code)
((load-array ,bv)
(+ 1 *len-len* (bytevector-length bv)))
((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code)
(+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0)))
((,inst . _) (guard (>= (instruction-length inst) 0))
(+ 1 (instruction-length inst)))
@ -61,18 +58,28 @@
(define *program-alignment* 8)
(define *block-alignment* 8)
(define (addr+ addr code)
(fold (lambda (x len) (+ (byte-length x) len))
addr
code))
(define (code-alignment addr alignment header-len)
(make-list (modulo (- alignment
(modulo (+ addr header-len) alignment))
alignment)
'(nop)))
(define (align-block addr)
(code-alignment addr *block-alignment* 0))
(define (align-code code addr alignment header-len)
`(,@(code-alignment addr alignment header-len)
,code))
(define (align-program prog addr)
`(,@(make-list (modulo (- *program-alignment*
(modulo (1+ addr) *program-alignment*))
;; plus the one for the load-program inst itself
*program-alignment*)
'(nop))
,prog))
(align-code prog addr *program-alignment* 1))
;;;
;;; Code compress/decompression
@ -104,12 +111,26 @@
((null? x) `(make-eol))
((and (integer? x) (exact? x))
(cond ((and (<= -128 x) (< x 128))
`(make-int8 ,(modulo x 256)))
(assembly-pack `(make-int8 ,(modulo x 256))))
((and (<= -32768 x) (< x 32768))
(let ((n (if (< x 0) (+ x 65536) x)))
`(make-int16 ,(quotient n 256) ,(modulo n 256))))
((and (<= 0 x #xffffffffffffffff))
`(make-uint64 ,@(bytevector->u8-list
(let ((bv (make-bytevector 8)))
(bytevector-u64-set! bv 0 x (endianness big))
bv))))
((and (<= 0 (+ x #x8000000000000000) #x7fffffffffffffff))
`(make-int64 ,@(bytevector->u8-list
(let ((bv (make-bytevector 8)))
(bytevector-s64-set! bv 0 x (endianness big))
bv))))
(else #f)))
((char? x) `(make-char8 ,(char->integer x)))
((char? x)
(cond ((<= (char->integer x) #xff)
`(make-char8 ,(char->integer x)))
(else
`(make-char32 ,(char->integer x)))))
(else #f)))
(define (assembly->object code)
@ -122,9 +143,23 @@
((make-int16 ,n1 ,n2)
(let ((n (+ (* n1 256) n2)))
(if (< n 32768) n (- n 65536))))
((make-uint64 ,n1 ,n2 ,n3 ,n4 ,n5 ,n6 ,n7 ,n8)
(bytevector-u64-ref
(u8-list->bytevector (list n1 n2 n3 n4 n5 n6 n7 n8))
0
(endianness big)))
((make-int64 ,n1 ,n2 ,n3 ,n4 ,n5 ,n6 ,n7 ,n8)
(bytevector-s64-ref
(u8-list->bytevector (list n1 n2 n3 n4 n5 n6 n7 n8))
0
(endianness big)))
((make-char8 ,n)
(integer->char n))
((make-char32 ,n1 ,n2 ,n3 ,n4)
(integer->char (+ (* n1 #x1000000)
(* n2 #x10000)
(* n3 #x100)
n4)))
((load-string ,s) s)
((load-symbol ,s) (string->symbol s))
((load-keyword ,s) (symbol->keyword (string->symbol s)))
(else #f)))

80
module/language/assembly/compile-bytecode.scm
View file

@ -2,20 +2,19 @@
;; 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.
;;;; 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 3 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
;;; Code:
@ -24,6 +23,7 @@
#:use-module (language assembly)
#:use-module (system vm instruction)
#:use-module (srfi srfi-4)
#:use-module (rnrs bytevector)
#:use-module ((srfi srfi-1) #:select (fold))
#:use-module ((system vm objcode) #:select (byte-order))
#:export (compile-bytecode write-bytecode))
@ -40,7 +40,7 @@
(get-addr (lambda () i)))
(write-bytecode assembly write-byte get-addr '())
(if (= i (u8vector-length v))
(values v env)
(values v env env)
(error "incorrect length in assembly" i (u8vector-length v)))))
(else (error "bad assembly" assembly))))
@ -65,6 +65,14 @@
(write-byte (logand (ash x -8) 255))
(write-byte (logand (ash x -16) 255))
(write-byte (logand (ash x -24) 255)))
(define (write-uint32 x)
(case byte-order
((1234) (write-uint32-le x))
((4321) (write-uint32-be x))
(else (error "unknown endianness" byte-order))))
(define (write-wide-string s)
(write-loader-len (* 4 (string-length s)))
(string-for-each (lambda (c) (write-uint32 (char->integer c))) s))
(define (write-loader-len len)
(write-byte (ash len -16))
(write-byte (logand (ash len -8) 255))
@ -72,27 +80,43 @@
(define (write-loader str)
(write-loader-len (string-length str))
(write-string str))
(define (write-sized-loader str)
(let ((len (string-length str))
(wid (string-width str)))
(write-loader-len len)
(write-byte wid)
(if (= wid 4)
(write-wide-string str)
(write-string str))))
(define (write-bytevector bv)
(write-loader-len (bytevector-length bv))
;; Ew!
(for-each write-byte (bytevector->u8-list bv)))
(define (write-break label)
(write-uint16-be (- (assq-ref labels label) (+ (get-addr) 2))))
(let ((offset (- (assq-ref labels label)
(logand (+ (get-addr) 2) (lognot #x7)))))
(cond ((not (= 0 (modulo offset 8))) (error "unaligned jump" offset))
((>= offset (ash 1 18)) (error "jump too far forward" offset))
((< offset (- (ash 1 18))) (error "jump too far backwards" offset))
(else (write-uint16-be (ash offset -3))))))
(let ((inst (car asm))
(args (cdr asm))
(write-uint32 (case byte-order
((1234) write-uint32-le)
((4321) write-uint32-be)
(write-uint16 (case byte-order
((1234) write-uint16-le)
((4321) write-uint16-be)
(else (error "unknown endianness" byte-order)))))
(let ((opcode (instruction->opcode inst))
(len (instruction-length inst)))
(write-byte opcode)
(pmatch asm
((load-program ,nargs ,nrest ,nlocs ,nexts
,labels ,length ,meta . ,code)
((load-program ,nargs ,nrest ,nlocs ,labels ,length ,meta . ,code)
(write-byte nargs)
(write-byte nrest)
(write-byte nlocs)
(write-byte nexts)
(write-uint16 nlocs)
(write-uint32 length)
(write-uint32 (if meta (1- (byte-length meta)) 0))
(write-uint32 0) ; padding
(letrec ((i 0)
(write (lambda (x) (set! i (1+ i)) (write-byte x)))
(get-addr (lambda () i)))
@ -106,14 +130,16 @@
(set! i (1+ i))
(if (> i 0) (write-byte x))))
(get-addr (lambda () i)))
;; META's bytecode meets the alignment requirements of
;; `scm_objcode', thanks to the alignment computed in
;; `(language assembly)'.
(write-bytecode meta write get-addr '()))))
((load-unsigned-integer ,str) (write-loader str))
((load-integer ,str) (write-loader str))
((make-char32 ,x) (write-uint32-be x))
((load-number ,str) (write-loader str))
((load-string ,str) (write-loader str))
((load-wide-string ,str) (write-wide-string str))
((load-symbol ,str) (write-loader str))
((load-keyword ,str) (write-loader str))
((define ,str) (write-loader str))
((load-array ,bv) (write-bytevector bv))
((br ,l) (write-break l))
((br-if ,l) (write-break l))
((br-if-not ,l) (write-break l))

63
module/language/assembly/decompile-bytecode.scm
View file

@ -1,21 +1,20 @@
;;; Guile VM code converters
;; Copyright (C) 2001 Free Software Foundation, Inc.
;; 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.
;;;; 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 3 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
;;; Code:
@ -23,7 +22,9 @@
#:use-module (system vm instruction)
#:use-module (system base pmatch)
#:use-module (srfi srfi-4)
#:use-module (rnrs bytevector)
#:use-module (language assembly)
#:use-module ((system vm objcode) #:select (byte-order))
#:export (decompile-bytecode))
(define (decompile-bytecode x env opts)
@ -48,17 +49,21 @@
x
(- x (ash 1 16)))))
;; FIXME: this is a little-endian disassembly!!!
(define (decode-load-program pop)
(let* ((nargs (pop)) (nrest (pop)) (nlocs (pop)) (nexts (pop))
(let* ((nargs (pop)) (nrest (pop)) (nlocs0 (pop)) (nlocs1 (pop))
(nlocs (+ nlocs0 (ash nlocs1 8)))
(a (pop)) (b (pop)) (c (pop)) (d (pop))
(e (pop)) (f (pop)) (g (pop)) (h (pop))
(len (+ a (ash b 8) (ash c 16) (ash d 24)))
(metalen (+ e (ash f 8) (ash g 16) (ash h 24)))
(totlen (+ len metalen))
(pad0 (pop)) (pad1 (pop)) (pad2 (pop)) (pad3 (pop))
(labels '())
(i 0))
(define (ensure-label rel1 rel2)
(let ((where (+ i (bytes->s16 rel1 rel2))))
(let ((where (+ (logand i (lognot #x7))
(* (bytes->s16 rel1 rel2) 8))))
(or (assv-ref labels where)
(begin
(let ((l (gensym ":L")))
@ -74,7 +79,7 @@
(cond ((> i len)
(error "error decoding program -- read too many bytes" out))
((= i len)
`(load-program ,nargs ,nrest ,nlocs ,nexts
`(load-program ,nargs ,nrest ,nlocs
,(map (lambda (x) (cons (cdr x) (car x)))
(reverse labels))
,len
@ -97,15 +102,29 @@
(cond
((eq? inst 'load-program)
(decode-load-program pop))
((< (instruction-length inst) 0)
(let* ((len (let* ((a (pop)) (b (pop)) (c (pop)))
;; the negative length indicates a variable length
;; instruction
(let* ((make-sequence
(if (or (memq inst '(load-array load-wide-string)))
make-bytevector
make-string))
(sequence-set!
(if (or (memq inst '(load-array load-wide-string)))
bytevector-u8-set!
(lambda (str pos value)
(string-set! str pos (integer->char value)))))
(len (let* ((a (pop)) (b (pop)) (c (pop)))
(+ (ash a 16) (ash b 8) c)))
(str (make-string len)))
(seq (make-sequence len)))
(let lp ((i 0))
(if (= i len)
`(,inst ,str)
`(,inst ,(if (eq? inst 'load-wide-string)
(utf32->string seq)
seq))
(begin
(string-set! str i (integer->char (pop)))
(sequence-set! seq i (pop))
(lp (1+ i)))))))
(else
;; fixed length

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

@ -1,21 +1,20 @@
;;; Guile VM code converters
;; Copyright (C) 2001 Free Software Foundation, Inc.
;; 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.
;;;; 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 3 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
;;; Code:
@ -36,12 +35,11 @@
(define (disassemble-load-program asm env)
(pmatch asm
((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code)
((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,code)
(let ((objs (and env (assq-ref env 'objects)))
(free-vars (and env (assq-ref env 'free-vars)))
(meta (and env (assq-ref env 'meta)))
(exts (and env (assq-ref env 'exts)))
(blocs (and env (assq-ref env 'blocs)))
(bexts (and env (assq-ref env 'bexts)))
(srcs (and env (assq-ref env 'sources))))
(let lp ((pos 0) (code code) (programs '()))
(cond
@ -62,15 +60,17 @@
(print-info pos `(load-program ,sym) #f #f)
(lp (+ pos (byte-length asm)) (cdr code)
(acons sym asm programs))))
((nop)
(lp (+ pos (byte-length asm)) (cdr code) programs))
(else
(print-info pos asm
(code-annotation end asm objs nargs blocs bexts
(code-annotation end asm objs nargs blocs
labels)
(and=> (and srcs (assq end srcs)) source->string))
(lp (+ pos (byte-length asm)) (cdr code) programs)))))))
(if (pair? exts)
(disassemble-externals exts))
(if (pair? free-vars)
(disassemble-free-vars free-vars))
(if meta
(disassemble-meta meta))
@ -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))))
@ -93,13 +93,12 @@
((= n len) (newline))
(print-info n (vector-ref objs n) #f #f))))
(define (disassemble-externals exts)
(display "Externals:\n\n")
(let ((len (length exts)))
(do ((n 0 (1+ n))
(l exts (cdr l)))
((null? l) (newline))
(print-info n (car l) #f #f))))
(define (disassemble-free-vars free-vars)
(display "Free variables:\n\n")
(let ((i 0))
(cond ((< i (vector-length free-vars))
(print-info i (vector-ref free-vars i) #f #f)
(lp (1+ i))))))
(define-macro (unless test . body)
`(if (not ,test) (begin ,@body)))
@ -123,7 +122,7 @@
(define (make-int16 byte1 byte2)
(+ (* byte1 256) byte2))
(define (code-annotation end-addr code objs nargs blocs bexts labels)
(define (code-annotation end-addr code objs nargs blocs labels)
(let* ((code (assembly-unpack code))
(inst (car code))
(args (cdr code)))
@ -134,7 +133,7 @@
(list "-> ~A" (assq-ref labels (car args))))
((object-ref)
(and objs (list "~s" (vector-ref objs (car args)))))
((local-ref local-set)
((local-ref local-boxed-ref local-set local-boxed-set)
(and blocs
(let lp ((bindings (list-ref blocs (car args))))
(and (pair? bindings)
@ -144,13 +143,9 @@
(list "`~a'~@[ (arg)~]"
(binding:name b) (< (binding:index b) nargs))
(lp (cdr bindings))))))))
((external-ref external-set)
(and bexts
(if (< (car args) (length bexts))
(let ((b (list-ref bexts (car args))))
(list "`~a'~@[ (arg)~]"
(binding:name b) (< (binding:index b) nargs)))
(list "(closure variable)"))))
((free-ref free-boxed-ref free-boxed-set)
;; FIXME: we can do better than this
(list "(closure variable)"))
((toplevel-ref toplevel-set)
(and objs
(let ((v (vector-ref objs (car args))))

27
module/language/assembly/spec.scm
View file

@ -2,20 +2,19 @@
;; 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.
;;;; 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 3 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
;;; Code:

126
module/language/brainfuck/compile-scheme.scm Normal file
View file

@ -0,0 +1,126 @@
;;; Brainfuck for GNU Guile
;; 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 3 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
;;; Code:
(define-module (language brainfuck compile-scheme)
#:export (compile-scheme))
;; Compilation of Brainfuck to Scheme is pretty straight-forward. For all of
;; brainfuck's instructions, there are basic representations in Scheme we
;; only have to generate.
;;
;; Brainfuck's pointer and data-tape are stored in the variables pointer and
;; tape, where tape is a vector of integer values initially set to zero. Pointer
;; starts out at position 0.
;; Our tape is thus of finite length, with an address range of 0..n for
;; some defined upper bound n depending on the length of our tape.
;; Define the length to use for the tape.
(define tape-size 30000)
;; This compiles a whole brainfuck program. This constructs a Scheme code like:
;; (let ((pointer 0)
;; (tape (make-vector tape-size 0)))
;; (begin
;; <body>
;; (write-char #\newline)))
;;
;; So first the pointer and tape variables are set up correctly, then the
;; program's body is executed in this context, and finally we output an
;; additional newline character in case the program does not output one.
;;
;; TODO: Find out and explain the details about env, the three return values and
;; how to use the options. Implement options to set the tape-size, maybe.
(define (compile-scheme exp env opts)
(values
`(let ((pointer 0)
(tape (make-vector ,tape-size 0)))
,@(if (not (eq? '<brainfuck> (car exp)))
(error "expected brainfuck program")
`(begin
,@(compile-body (cdr exp))
(write-char #\newline))))
env
env))
;; Compile a list of instructions to get a list of Scheme codes. As we always
;; strip off the car of the instructions-list and cons the result onto the
;; result-list, it will get out in reversed order first; so we have to (reverse)
;; it on return.
(define (compile-body instructions)
(let iterate ((cur instructions)
(result '()))
(if (null? cur)
(reverse result)
(let ((compiled (compile-instruction (car cur))))
(iterate (cdr cur) (cons compiled result))))))
;; Compile a single instruction to Scheme, using the direct representations
;; all of Brainfuck's instructions have.
(define (compile-instruction ins)
(case (car ins)
;; Pointer moval >< is done simply by something like:
;; (set! pointer (+ pointer +-1))
((<bf-move>)
(let ((dir (cadr ins)))
`(set! pointer (+ pointer ,dir))))
;; Cell increment +- is done as:
;; (vector-set! tape pointer (+ (vector-ref tape pointer) +-1))
((<bf-increment>)
(let ((inc (cadr ins)))
`(vector-set! tape pointer (+ (vector-ref tape pointer) ,inc))))
;; Output . is done by converting the cell's integer value to a character
;; first and then printing out this character:
;; (write-char (integer->char (vector-ref tape pointer)))
((<bf-print>)
'(write-char (integer->char (vector-ref tape pointer))))
;; Input , is done similarly, read in a character, get its ASCII code and
;; store it into the current cell:
;; (vector-set! tape pointer (char->integer (read-char)))
((<bf-read>)
'(vector-set! tape pointer (char->integer (read-char))))
;; For loops [...] we use a named let construction to execute the body until
;; the current cell gets zero. The body is compiled via a recursive call
;; back to (compile-body).
;; (let iterate ()
;; (if (not (= (vector-ref! tape pointer) 0))
;; (begin
;; <body>
;; (iterate))))
((<bf-loop>)
`(let iterate ()
(if (not (= (vector-ref tape pointer) 0))
(begin
,@(compile-body (cdr ins))
(iterate)))))
(else (error "unknown brainfuck instruction " (car ins)))))

181
module/language/brainfuck/compile-tree-il.scm Normal file
View file

@ -0,0 +1,181 @@
;;; Brainfuck for GNU Guile
;; 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 3 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
;;; Commentary:
;; Brainfuck is a simple language that mostly mimics the operations of a
;; Turing machine. This file implements a compiler from Brainfuck to
;; Guile's Tree-IL.
;;; Code:
(define-module (language brainfuck compile-tree-il)
#:use-module (system base pmatch)
#:use-module (language tree-il)
#:export (compile-tree-il))
;; Compilation of Brainfuck is pretty straight-forward. For all of
;; brainfuck's instructions, there are basic representations in Tree-IL
;; we only have to generate.
;;
;; Brainfuck's pointer and data-tape are stored in the variables pointer and
;; tape, where tape is a vector of integer values initially set to zero. Pointer
;; starts out at position 0.
;; Our tape is thus of finite length, with an address range of 0..n for
;; some defined upper bound n depending on the length of our tape.
;; Define the length to use for the tape.
(define tape-size 30000)
;; This compiles a whole brainfuck program. This constructs a Tree-IL
;; code equivalent to Scheme code like this:
;;
;; (let ((pointer 0)
;; (tape (make-vector tape-size 0)))
;; (begin
;; <body>
;; (write-char #\newline)))
;;
;; So first the pointer and tape variables are set up correctly, then the
;; program's body is executed in this context, and finally we output an
;; additional newline character in case the program does not output one.
;;
;; The fact that we are compiling to Guile primitives gives this
;; implementation a number of interesting characteristics. First, the
;; values of the tape cells do not underflow or overflow. We could make
;; them do otherwise via compiling calls to "modulo" at certain points.
;;
;; In addition, tape overruns or underruns will be detected, and will
;; throw an error, whereas a number of Brainfuck compilers do not detect
;; this.
;;
;; Note that we're generating the S-expression representation of
;; Tree-IL, then using parse-tree-il to turn it into the actual Tree-IL
;; data structures. This makes the compiler more pleasant to look at,
;; but we do lose is the ability to propagate source information. Since
;; Brainfuck is so obtuse anyway, this shouldn't matter ;-)
;;
;; `compile-tree-il' takes as its input the read expression, the
;; environment, and some compile options. It returns the compiled
;; expression, the environment appropriate for the next pass of the
;; compiler -- in our case, just the environment unchanged -- and the
;; continuation environment.
;;
;; The normal use of a continuation environment is if compiling one
;; expression changes the environment, and that changed environment
;; should be passed to the next compiled expression -- for example,
;; changing the current module. But Brainfuck is incapable of that, so
;; for us, the continuation environment is just the same environment we
;; got in.
;;
;; FIXME: perhaps use options or the env to set the tape-size?
(define (compile-tree-il exp env opts)
(values
(parse-tree-il
`(let (pointer tape) (pointer tape)
((const 0)
(apply (primitive make-vector) (const ,tape-size) (const 0)))
,(compile-body exp)))
env
env))
;; Compile a list of instructions to a Tree-IL expression.
(define (compile-body instructions)
(let lp ((in instructions) (out '()))
(define (emit x)
(lp (cdr in) (cons x out)))
(cond
((null? in)
;; No more input, build our output.
(cond
((null? out) '(void)) ; no output
((null? (cdr out)) (car out)) ; single expression
(else `(begin ,@(reverse out)))) ; sequence
)
(else
(pmatch (car in)
;; Pointer moves >< are done simply by something like:
;; (set! pointer (+ pointer +-1))
((<bf-move> ,dir)
(emit `(set! (lexical pointer)
(apply (primitive +) (lexical pointer) (const ,dir)))))
;; Cell increment +- is done as:
;; (vector-set! tape pointer (+ (vector-ref tape pointer) +-1))
((<bf-increment> ,inc)
(emit `(apply (primitive vector-set!) (lexical tape) (lexical pointer)
(apply (primitive +)
(apply (primitive vector-ref)
(lexical tape) (lexical pointer))
(const ,inc)))))
;; Output . is done by converting the cell's integer value to a
;; character first and then printing out this character:
;; (write-char (integer->char (vector-ref tape pointer)))
((<bf-print>)
(emit `(apply (primitive write-char)
(apply (primitive integer->char)
(apply (primitive vector-ref)
(lexical tape) (lexical pointer))))))
;; Input , is done similarly, read in a character, get its ASCII
;; code and store it into the current cell:
;; (vector-set! tape pointer (char->integer (read-char)))
((<bf-read>)
(emit `(apply (primitive vector-set!)
(lexical tape) (lexical pointer)
(apply (primitive char->integer)
(apply (primitive read-char))))))
;; For loops [...] we use a letrec construction to execute the body until
;; the current cell gets zero. The body is compiled via a recursive call
;; back to (compile-body).
;; (let iterate ()
;; (if (not (= (vector-ref! tape pointer) 0))
;; (begin
;; <body>
;; (iterate))))
;;
;; Indeed, letrec is the only way we have to loop in Tree-IL.
;; Note that this does not mean that the closure must actually
;; be created; later passes can compile tail-recursive letrec
;; calls into inline code with gotos. Admittedly, that part of
;; the compiler is not yet in place, but it will be, and in the
;; meantime the code is still reasonably efficient.
((<bf-loop> . ,body)
(let ((iterate (gensym)))
(emit `(letrec (iterate) (,iterate)
((lambda () ()
(if (apply (primitive =)
(apply (primitive vector-ref)
(lexical tape) (lexical pointer))
(const 0))
(void)
(begin ,(compile-body body)
(apply (lexical ,iterate))))))
(apply (lexical ,iterate))))))
(else (error "unknown brainfuck instruction" (car in))))))))

91
module/language/brainfuck/parse.scm Normal file
View file

@ -0,0 +1,91 @@
;;; Brainfuck for GNU Guile.
;; 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 3 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
;;; Code:
(define-module (language brainfuck parse)
#:export (read-brainfuck))
; Purpose of the parse module is to read in brainfuck in text form and produce
; the corresponding tree representing the brainfuck code.
;
; Each object (representing basically a single instruction) is structured like:
; (<instruction> [arguments])
; where <instruction> is a symbolic name representing the type of instruction
; and the optional arguments represent further data (for instance, the body of
; a [...] loop as a number of nested instructions).
;
; A full brainfuck program is represented by the (<brainfuck> instructions)
; object.
; While reading a number of instructions in sequence, all of them are cons'ed
; onto a list of instructions; thus this list gets out in reverse order.
; Additionally, for "comment characters" (everything not an instruction) we
; generate <bf-nop> NOP instructions.
;
; This routine reverses a list of instructions and removes all <bf-nop>'s on the
; way to fix these two issues for a read-in list.
(define (reverse-without-nops lst)
(let iterate ((cur lst)
(result '()))
(if (null? cur)
result
(let ((head (car cur))
(tail (cdr cur)))
(if (eq? (car head) '<bf-nop>)
(iterate tail result)
(iterate tail (cons head result)))))))
; Read in a set of instructions until a terminating ] character is found (or
; end of file is reached). This is used both for loop bodies and whole
; programs, so that a program has to be either terminated by EOF or an
; additional ], too.
;
; For instance, the basic program so just echo one character would be:
; ,.]
(define (read-brainfuck p)
(let iterate ((parsed '()))
(let ((chr (read-char p)))
(if (or (eof-object? chr) (eq? #\] chr))
(reverse-without-nops parsed)
(iterate (cons (process-input-char chr p) parsed))))))
; This routine processes a single character of input and builds the
; corresponding instruction. Loop bodies are read by recursively calling
; back (read-brainfuck).
;
; For the poiner movement commands >< and the cell increment/decrement +-
; commands, we only use one instruction form each and specify the direction of
; the pointer/value increment using an argument to the instruction form.
(define (process-input-char chr p)
(case chr
((#\>) '(<bf-move> 1))
((#\<) '(<bf-move> -1))
((#\+) '(<bf-increment> 1))
((#\-) '(<bf-increment> -1))
((#\.) '(<bf-print>))
((#\,) '(<bf-read>))
((#\[) `(<bf-loop> ,@(read-brainfuck p)))
(else '(<bf-nop>))))

44
module/language/brainfuck/spec.scm Normal file
View file

@ -0,0 +1,44 @@
;;; Brainfuck for GNU Guile.
;; 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 3 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
;;; Code:
(define-module (language brainfuck spec)
#:use-module (language brainfuck compile-tree-il)
#:use-module (language brainfuck compile-scheme)
#:use-module (language brainfuck parse)
#:use-module (system base language)
#:export (brainfuck))
; The new language is integrated into Guile via this (define-language)
; specification in the special module (language [lang] spec).
; Provided is a parser-routine in #:reader, a output routine in #:printer
; and one or more compiler routines (as target-language - routine pairs)
; in #:compilers. This is the basic set of fields needed to specify a new
; language.
(define-language brainfuck
#:title "Guile Brainfuck"
#:version "1.0"
#:reader (lambda () (read-brainfuck (current-input-port)))
#:compilers `((tree-il . ,compile-tree-il)
(scheme . ,compile-scheme))
#:printer write
)

29
module/language/bytecode/spec.scm
View file

@ -2,20 +2,19 @@
;; 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.
;;;; 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 3 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
;;; Code:
@ -25,7 +24,7 @@
#:export (bytecode))
(define (compile-objcode x e opts)
(values (bytecode->objcode x) e))
(values (bytecode->objcode x) e e))
(define (decompile-objcode x e opts)
(values (objcode->bytecode x) e))

27
module/language/ecmascript/array.scm
View file

@ -2,20 +2,19 @@
;; 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.
;;;; 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 3 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
;;; Code:

27
module/language/ecmascript/base.scm
View file

@ -2,20 +2,19 @@
;; 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.
;;;; 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 3 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
;;; Code:

572
module/language/ecmascript/compile-ghil.scm
View file

@ -1,572 +0,0 @@
;;; ECMAScript for Guile
;; 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 ecmascript compile-ghil)
#:use-module (language ghil)
#:use-module (ice-9 receive)
#:use-module (system base pmatch)
#:export (compile-ghil))
(define-macro (-> form)
`(,(symbol-append 'make-ghil- (car form)) e l . ,(cdr form)))
(define-macro (@implv sym)
`(-> (ref (ghil-var-at-module! e '(language ecmascript impl) ',sym #t))))
(define-macro (@impl sym args)
`(-> (call (@implv ,sym) ,args)))
(define (compile-ghil exp env opts)
(values
(call-with-ghil-environment (make-ghil-toplevel-env) '()
(lambda (e vars)
(let ((l #f))
(-> (lambda vars #f '()
(-> (begin (list (@impl js-init '())
(comp exp e)))))))))
env))
(define (location x)
(and (pair? x)
(let ((props (source-properties x)))
(and (not (null? props))
props))))
;; The purpose, you ask? To avoid non-tail recursion when expanding a
;; long pmatch sequence.
(define-macro (ormatch x . clauses)
(let ((X (gensym)))
`(let ((,X ,x))
(or ,@(map (lambda (c)
(if (eq? (car c) 'else)
`(begin . ,(cdr c))
`(pmatch ,X ,c (else #f))))
clauses)))))
(define (comp x e)
(let ((l (location x)))
(define (let1 what proc)
(call-with-ghil-bindings e '(%tmp)
(lambda (vars)
(-> (bind vars (list what)
(proc (car vars)))))))
(define (begin1 what proc)
(call-with-ghil-bindings e '(%tmp)
(lambda (vars)
(-> (bind vars (list what)
(-> (begin (list (proc (car vars))
(-> (ref (car vars)))))))))))
(ormatch x
(null
;; FIXME, null doesn't have much relation to EOL...
(-> (quote '())))
(true
(-> (quote #t)))
(false
(-> (quote #f)))
((number ,num)
(-> (quote num)))
((string ,str)
(-> (quote str)))
(this
(@impl get-this '()))
((+ ,a)
(-> (inline 'add
(list (@impl ->number (list (comp a e)))
(-> (quote 0))))))
((- ,a)
(-> (inline 'sub (list (-> (quote 0)) (comp a e)))))
((~ ,a)
(@impl bitwise-not (list (comp a e))))
((! ,a)
(@impl logical-not (list (comp a e))))
((+ ,a ,b)
(-> (inline 'add (list (comp a e) (comp b e)))))
((- ,a ,b)
(-> (inline 'sub (list (comp a e) (comp b e)))))
((/ ,a ,b)
(-> (inline 'div (list (comp a e) (comp b e)))))
((* ,a ,b)
(-> (inline 'mul (list (comp a e) (comp b e)))))
((% ,a ,b)
(@impl mod (list (comp a e) (comp b e))))
((<< ,a ,b)
(@impl shift (list (comp a e) (comp b e))))
((>> ,a ,b)
(@impl shift (list (comp a e) (comp `(- ,b) e))))
((< ,a ,b)
(-> (inline 'lt? (list (comp a e) (comp b e)))))
((<= ,a ,b)
(-> (inline 'le? (list (comp a e) (comp b e)))))
((> ,a ,b)
(-> (inline 'gt? (list (comp a e) (comp b e)))))
((>= ,a ,b)
(-> (inline 'ge? (list (comp a e) (comp b e)))))
((in ,a ,b)
(@impl has-property? (list (comp a e) (comp b e))))
((== ,a ,b)
(-> (inline 'equal? (list (comp a e) (comp b e)))))
((!= ,a ,b)
(-> (inline 'not
(list (-> (inline 'equal?
(list (comp a e) (comp b e))))))))
((=== ,a ,b)
(-> (inline 'eqv? (list (comp a e) (comp b e)))))
((!== ,a ,b)
(-> (inline 'not
(list (-> (inline 'eqv?
(list (comp a e) (comp b e))))))))
((& ,a ,b)
(@impl band (list (comp a e) (comp b e))))
((^ ,a ,b)
(@impl bxor (list (comp a e) (comp b e))))
((bor ,a ,b)
(@impl bior (list (comp a e) (comp b e))))
((and ,a ,b)
(-> (and (list (comp a e) (comp b e)))))
((or ,a ,b)
(-> (or (list (comp a e) (comp b e)))))
((if ,test ,then ,else)
(-> (if (@impl ->boolean (list (comp test e)))
(comp then e)
(comp else e))))
((if ,test ,then ,else)
(-> (if (@impl ->boolean (list (comp test e)))
(comp then e)
(@implv *undefined*))))
((postinc (ref ,foo))
(begin1 (comp `(ref ,foo) e)
(lambda (var)
(-> (set (ghil-var-for-set! e foo)
(-> (inline 'add
(list (-> (ref var))
(-> (quote 1))))))))))
((postinc (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
(begin1 (@impl pget
(list (-> (ref objvar))
(-> (quote prop))))
(lambda (tmpvar)
(@impl pput
(list (-> (ref objvar))
(-> (quote prop))
(-> (inline 'add
(list (-> (ref tmpvar))
(-> (quote 1))))))))))))
((postinc (aref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
(let1 (comp prop e)
(lambda (propvar)
(begin1 (@impl pget
(list (-> (ref objvar))
(-> (ref propvar))))
(lambda (tmpvar)
(@impl pput
(list (-> (ref objvar))
(-> (ref propvar))
(-> (inline 'add
(list (-> (ref tmpvar))
(-> (quote 1))))))))))))))
((postdec (ref ,foo))
(begin1 (comp `(ref ,foo) e)
(lambda (var)
(-> (set (ghil-var-for-set! e foo)
(-> (inline 'sub
(list (-> (ref var))
(-> (quote 1))))))))))
((postdec (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
(begin1 (@impl pget
(list (-> (ref objvar))
(-> (quote prop))))
(lambda (tmpvar)
(@impl pput
(list (-> (ref objvar))
(-> (quote prop))
(-> (inline 'sub
(list (-> (ref tmpvar))
(-> (quote 1))))))))))))
((postdec (aref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
(let1 (comp prop e)
(lambda (propvar)
(begin1 (@impl pget
(list (-> (ref objvar))
(-> (ref propvar))))
(lambda (tmpvar)
(@impl pput
(list (-> (ref objvar))
(-> (ref propvar))
(-> (inline
'sub (list (-> (ref tmpvar))
(-> (quote 1))))))))))))))
((preinc (ref ,foo))
(let ((v (ghil-var-for-set! e foo)))
(-> (begin
(list
(-> (set v
(-> (inline 'add
(list (-> (ref v))
(-> (quote 1)))))))
(-> (ref v)))))))
((preinc (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
(begin1 (-> (inline 'add
(list (@impl pget
(list (-> (ref objvar))
(-> (quote prop))))
(-> (quote 1)))))
(lambda (tmpvar)
(@impl pput (list (-> (ref objvar))
(-> (quote prop))
(-> (ref tmpvar)))))))))
((preinc (aref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
(let1 (comp prop e)
(lambda (propvar)
(begin1 (-> (inline 'add
(list (@impl pget
(list (-> (ref objvar))
(-> (ref propvar))))
(-> (quote 1)))))
(lambda (tmpvar)
(@impl pput
(list (-> (ref objvar))
(-> (ref propvar))
(-> (ref tmpvar)))))))))))
((predec (ref ,foo))
(let ((v (ghil-var-for-set! e foo)))
(-> (begin
(list
(-> (set v
(-> (inline 'sub
(list (-> (ref v))
(-> (quote 1)))))))
(-> (ref v)))))))
((predec (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
(begin1 (-> (inline 'sub
(list (@impl pget
(list (-> (ref objvar))
(-> (quote prop))))
(-> (quote 1)))))
(lambda (tmpvar)
(@impl pput
(list (-> (ref objvar))
(-> (quote prop))
(-> (ref tmpvar)))))))))
((predec (aref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
(let1 (comp prop e)
(lambda (propvar)
(begin1 (-> (inline 'sub
(list (@impl pget
(list (-> (ref objvar))
(-> (ref propvar))))
(-> (quote 1)))))
(lambda (tmpvar)
(@impl pput
(list (-> (ref objvar))
(-> (ref propvar))
(-> (ref tmpvar)))))))))))
((ref ,id)
(-> (ref (ghil-var-for-ref! e id))))
((var . ,forms)
(-> (begin
(map (lambda (form)
(pmatch form
((,x ,y)
(-> (define (ghil-var-define! (ghil-env-parent e) x)
(comp y e))))
((,x)
(-> (define (ghil-var-define! (ghil-env-parent e) x)
(@implv *undefined*))))
(else (error "bad var form" form))))
forms))))
((begin . ,forms)
(-> (begin
(map (lambda (x) (comp x e)) forms))))
((lambda ,formals ,body)
(call-with-ghil-environment e '(%args)
(lambda (e vars)
(-> (lambda vars #t '()
(comp-body env l body formals '%args))))))
((call/this ,obj ,prop ,args)
(@impl call/this*
(list obj
(-> (lambda '() #f '()
(-> (call (@impl pget (list obj prop))
args)))))))
((call (pref ,obj ,prop) ,args)
(comp `(call/this ,(comp obj e)
,(-> (quote prop))
,(map (lambda (x) (comp x e)) args))
e))
((call (aref ,obj ,prop) ,args)
(comp `(call/this ,(comp obj e)
,(comp prop e)
,(map (lambda (x) (comp x e)) args))
e))
((call ,proc ,args)
(-> (call (comp proc e)
(map (lambda (x) (comp x e)) args))))
((return ,expr)
(-> (inline 'return
(list (comp expr e)))))
((array . ,args)
(@impl new-array
(map (lambda (x) (comp x e)) args)))
((object . ,args)
(@impl new-object
(map (lambda (x)
(pmatch x
((,prop ,val)
(-> (inline 'cons
(list (-> (quote prop))
(comp val e)))))
(else
(error "bad prop-val pair" x))))
args)))
((pref ,obj ,prop)
(@impl pget
(list (comp obj e)
(-> (quote prop)))))
((aref ,obj ,index)
(@impl pget
(list (comp obj e)
(comp index e))))
((= (ref ,name) ,val)
(let ((v (ghil-var-for-set! e name)))
(-> (begin
(list (-> (set v (comp val e)))
(-> (ref v)))))))
((= (pref ,obj ,prop) ,val)
(@impl pput
(list (comp obj e)
(-> (quote prop))
(comp val e))))
((= (aref ,obj ,prop) ,val)
(@impl pput
(list (comp obj e)
(comp prop e)
(comp val e))))
((+= ,what ,val)
(comp `(= ,what (+ ,what ,val)) e))
((-= ,what ,val)
(comp `(= ,what (- ,what ,val)) e))
((/= ,what ,val)
(comp `(= ,what (/ ,what ,val)) e))
((*= ,what ,val)
(comp `(= ,what (* ,what ,val)) e))
((%= ,what ,val)
(comp `(= ,what (% ,what ,val)) e))
((>>= ,what ,val)
(comp `(= ,what (>> ,what ,val)) e))
((<<= ,what ,val)
(comp `(= ,what (<< ,what ,val)) e))
((>>>= ,what ,val)
(comp `(= ,what (>>> ,what ,val)) e))
((&= ,what ,val)
(comp `(= ,what (& ,what ,val)) e))
((bor= ,what ,val)
(comp `(= ,what (bor ,what ,val)) e))
((^= ,what ,val)
(comp `(= ,what (^ ,what ,val)) e))
((new ,what ,args)
(@impl new
(map (lambda (x) (comp x e))
(cons what args))))
((delete (pref ,obj ,prop))
(@impl pdel
(list (comp obj e)
(-> (quote prop)))))
((delete (aref ,obj ,prop))
(@impl pdel
(list (comp obj e)
(comp prop e))))
((void ,expr)
(-> (begin
(list (comp expr e)
(@implv *undefined*)))))
((typeof ,expr)
(@impl typeof
(list (comp expr e))))
((do ,statement ,test)
(call-with-ghil-bindings e '(%loop %continue)
(lambda (vars)
(-> (bind vars
(list (call-with-ghil-environment e '()
(lambda (e _)
(-> (lambda '() #f '()
(-> (begin
(list (comp statement e)
(-> (call
(-> (ref (ghil-var-for-ref! e '%continue)))
'())))))))))
(call-with-ghil-environment e '()
(lambda (e _)
(-> (lambda '() #f '()
(-> (if (@impl ->boolean (list (comp test e)))
(-> (call
(-> (ref (ghil-var-for-ref! e '%loop)))
'()))
(@implv *undefined*))))))))
(-> (call (-> (ref (car vars))) '())))))))
((while ,test ,statement)
(call-with-ghil-bindings e '(%continue)
(lambda (vars)
(-> (begin
(list
(-> (set (car vars)
(call-with-ghil-environment e '()
(lambda (e _)
(-> (lambda '() #f '()
(-> (if (@impl ->boolean (list (comp test e)))
(-> (begin
(list (comp statement e)
(-> (call
(-> (ref (ghil-var-for-ref! e '%continue)))
'())))))
(@implv *undefined*)))))))))
(-> (call (-> (ref (car vars))) '()))))))))
((for ,init ,test ,inc ,statement)
(call-with-ghil-bindings e '(%continue)
(lambda (vars)
(-> (begin
(list
(comp (or init '(begin)) e)
(-> (set (car vars)
(call-with-ghil-environment e '()
(lambda (e _)
(-> (lambda '() #f '()
(-> (if (if test
(@impl ->boolean (list (comp test e)))
(comp 'true e))
(-> (begin
(list (comp statement e)
(comp (or inc '(begin)) e)
(-> (call
(-> (ref (ghil-var-for-ref! e '%continue)))
'())))))
(@implv *undefined*)))))))))
(-> (call (-> (ref (car vars))) '()))))))))
((for-in ,var ,object ,statement)
(call-with-ghil-bindings e '(%continue %enum)
(lambda (vars)
(-> (begin
(list
(-> (set (car vars)
(call-with-ghil-environment e '()
(lambda (e _)
(-> (lambda '() #f '()
(-> (if (@impl ->boolean
(list (@impl pget
(list (-> (ref (ghil-var-for-ref! e '%enum)))
(-> (quote 'length))))))
(-> (begin
(list
(comp `(= ,var (call/this ,(-> (ref (ghil-var-for-ref! e '%enum)))
,(-> (quote 'pop))
()))
e)
(comp statement e)
(-> (call (-> (ref (ghil-var-for-ref! e '%continue)))
'())))))
(@implv *undefined*)))))))))
(-> (set (cadr vars)
(@impl make-enumerator (list (comp object e)))))
(-> (call (-> (ref (car vars))) '()))))))))
((break)
(let ((var (ghil-var-for-ref! e '%continue)))
(if (and (ghil-env? (ghil-var-env var))
(eq? (ghil-var-env var) (ghil-env-parent e)))
(-> (inline 'return (@implv *undefined*)))
(error "bad break, yo"))))
((continue)
(let ((var (ghil-var-for-ref! e '%continue)))
(if (and (ghil-env? (ghil-var-env var))
(eq? (ghil-var-env var) (ghil-env-parent e)))
(-> (inline 'goto/args (list (-> (ref var)))))
(error "bad continue, yo"))))
((block ,x)
(comp x e))
(else
(error "compilation not yet implemented:" x)))))
(define (comp-body e l body formals %args)
(define (process)
(let lp ((in body) (out '()) (rvars (reverse formals)))
(pmatch in
(((var (,x) . ,morevars) . ,rest)
(lp `((var . ,morevars) . ,rest)
out
(if (memq x rvars) rvars (cons x rvars))))
(((var (,x ,y) . ,morevars) . ,rest)
(lp `((var . ,morevars) . ,rest)
`((= (ref ,x) ,y) . ,out)
(if (memq x rvars) rvars (cons x rvars))))
(((var) . ,rest)
(lp rest out rvars))
((,x . ,rest) (guard (and (pair? x) (eq? (car x) 'lambda)))
(lp rest
(cons x out)
rvars))
((,x . ,rest) (guard (pair? x))
(receive (sub-out rvars)
(lp x '() rvars)
(lp rest
(cons sub-out out)
rvars)))
((,x . ,rest)
(lp rest
(cons x out)
rvars))
(()
(values (reverse! out)
rvars)))))
(receive (out rvars)
(process)
(call-with-ghil-bindings e (reverse rvars)
(lambda (vars)
(let ((%argv (assq-ref (ghil-env-table e) %args)))
(-> (begin
`(,@(map
(lambda (f)
(-> (if (-> (inline 'null?
(list (-> (ref %argv)))))
(-> (begin '()))
(-> (begin
(list (-> (set (ghil-var-for-ref! e f)
(-> (inline 'car
(list (-> (ref %argv)))))))
(-> (set %argv
(-> (inline 'cdr
(list (-> (ref %argv)))))))))))))
formals)
;; fixme: here check for too many args
,(comp out e)))))))))

549
module/language/ecmascript/compile-tree-il.scm Normal file
View file

@ -0,0 +1,549 @@
;;; ECMAScript for Guile
;; 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 3 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
;;; Code:
(define-module (language ecmascript compile-tree-il)
#:use-module (language tree-il)
#:use-module (ice-9 receive)
#:use-module (system base pmatch)
#:use-module (srfi srfi-1)
#:export (compile-tree-il))
(define-syntax ->
(syntax-rules ()
((_ (type arg ...))
`(type ,arg ...))))
(define-syntax @implv
(syntax-rules ()
((_ sym)
(-> (module-ref '(language ecmascript impl) 'sym #t)))))
(define-syntax @impl
(syntax-rules ()
((_ sym arg ...)
(-> (apply (@implv sym) arg ...)))))
(define (empty-lexical-environment)
'())
(define (econs name gensym env)
(acons name gensym env))
(define (lookup name env)
(or (assq-ref env name)
(-> (toplevel name))))
(define (compile-tree-il exp env opts)
(values
(parse-tree-il (comp exp (empty-lexical-environment)))
env
env))
(define (location x)
(and (pair? x)
(let ((props (source-properties x)))
(and (not (null? props))
props))))
;; for emacs:
;; (put 'pmatch/source 'scheme-indent-function 1)
(define-syntax pmatch/source
(syntax-rules ()
((_ x clause ...)
(let ((x x))
(let ((res (pmatch x
clause ...)))
(let ((loc (location x)))
(if loc
(set-source-properties! res (location x))))
res)))))
(define (comp x e)
(let ((l (location x)))
(define (let1 what proc)
(let ((sym (gensym)))
(-> (let (list sym) (list sym) (list what)
(proc sym)))))
(define (begin1 what proc)
(let1 what (lambda (v)
(-> (begin (proc v)
(-> (lexical v v)))))))
(pmatch/source x
(null
;; FIXME, null doesn't have much relation to EOL...
(-> (const '())))
(true
(-> (const #t)))
(false
(-> (const #f)))
((number ,num)
(-> (const num)))
((string ,str)
(-> (const str)))
(this
(@impl get-this '()))
((+ ,a)
(-> (apply (-> (primitive '+))
(@impl ->number (comp a e))
(-> (const 0)))))
((- ,a)
(-> (apply (-> (primitive '-)) (-> (const 0)) (comp a e))))
((~ ,a)
(@impl bitwise-not (comp a e)))
((! ,a)
(@impl logical-not (comp a e)))
((+ ,a ,b)
(-> (apply (-> (primitive '+)) (comp a e) (comp b e))))
((- ,a ,b)
(-> (apply (-> (primitive '-)) (comp a e) (comp b e))))
((/ ,a ,b)
(-> (apply (-> (primitive '/)) (comp a e) (comp b e))))
((* ,a ,b)
(-> (apply (-> (primitive '*)) (comp a e) (comp b e))))
((% ,a ,b)
(@impl mod (comp a e) (comp b e)))
((<< ,a ,b)
(@impl shift (comp a e) (comp b e)))
((>> ,a ,b)
(@impl shift (comp a e) (comp `(- ,b) e)))
((< ,a ,b)
(-> (apply (-> (primitive '<)) (comp a e) (comp b e))))
((<= ,a ,b)
(-> (apply (-> (primitive '<=)) (comp a e) (comp b e))))
((> ,a ,b)
(-> (apply (-> (primitive '>)) (comp a e) (comp b e))))
((>= ,a ,b)
(-> (apply (-> (primitive '>=)) (comp a e) (comp b e))))
((in ,a ,b)
(@impl has-property? (comp a e) (comp b e)))
((== ,a ,b)
(-> (apply (-> (primitive 'equal?)) (comp a e) (comp b e))))
((!= ,a ,b)
(-> (apply (-> (primitive 'not))
(-> (apply (-> (primitive 'equal?))
(comp a e) (comp b e))))))
((=== ,a ,b)
(-> (apply (-> (primitive 'eqv?)) (comp a e) (comp b e))))
((!== ,a ,b)
(-> (apply (-> (primitive 'not))
(-> (apply (-> (primitive 'eqv?))
(comp a e) (comp b e))))))
((& ,a ,b)
(@impl band (comp a e) (comp b e)))
((^ ,a ,b)
(@impl bxor (comp a e) (comp b e)))
((bor ,a ,b)
(@impl bior (comp a e) (comp b e)))
((and ,a ,b)
(-> (if (@impl ->boolean (comp a e))
(comp b e)
(-> (const #f)))))
((or ,a ,b)
(let1 (comp a e)
(lambda (v)
(-> (if (@impl ->boolean (-> (lexical v v)))
(-> (lexical v v))
(comp b e))))))
((if ,test ,then ,else)
(-> (if (@impl ->boolean (comp test e))
(comp then e)
(comp else e))))
((if ,test ,then ,else)
(-> (if (@impl ->boolean (comp test e))
(comp then e)
(@implv *undefined*))))
((postinc (ref ,foo))
(begin1 (comp `(ref ,foo) e)
(lambda (var)
(-> (set! (lookup foo e)
(-> (apply (-> (primitive '+))
(-> (lexical var var))
(-> (const 1)))))))))
((postinc (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
(begin1 (@impl pget
(-> (lexical objvar objvar))
(-> (const prop)))
(lambda (tmpvar)
(@impl pput
(-> (lexical objvar objvar))
(-> (const prop))
(-> (apply (-> (primitive '+))
(-> (lexical tmpvar tmpvar))
(-> (const 1))))))))))
((postinc (aref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
(let1 (comp prop e)
(lambda (propvar)
(begin1 (@impl pget
(-> (lexical objvar objvar))
(-> (lexical propvar propvar)))
(lambda (tmpvar)
(@impl pput
(-> (lexical objvar objvar))
(-> (lexical propvar propvar))
(-> (apply (-> (primitive '+))
(-> (lexical tmpvar tmpvar))
(-> (const 1))))))))))))
((postdec (ref ,foo))
(begin1 (comp `(ref ,foo) e)
(lambda (var)
(-> (set (lookup foo e)
(-> (apply (-> (primitive '-))
(-> (lexical var var))
(-> (const 1)))))))))
((postdec (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
(begin1 (@impl pget
(-> (lexical objvar objvar))
(-> (const prop)))
(lambda (tmpvar)
(@impl pput
(-> (lexical objvar objvar))
(-> (const prop))
(-> (apply (-> (primitive '-))
(-> (lexical tmpvar tmpvar))
(-> (const 1))))))))))
((postdec (aref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
(let1 (comp prop e)
(lambda (propvar)
(begin1 (@impl pget
(-> (lexical objvar objvar))
(-> (lexical propvar propvar)))
(lambda (tmpvar)
(@impl pput
(-> (lexical objvar objvar))
(-> (lexical propvar propvar))
(-> (inline
'- (-> (lexical tmpvar tmpvar))
(-> (const 1))))))))))))
((preinc (ref ,foo))
(let ((v (lookup foo e)))
(-> (begin
(-> (set! v
(-> (apply (-> (primitive '+))
v
(-> (const 1))))))
v))))
((preinc (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
(begin1 (-> (apply (-> (primitive '+))
(@impl pget
(-> (lexical objvar objvar))
(-> (const prop)))
(-> (const 1))))
(lambda (tmpvar)
(@impl pput (-> (lexical objvar objvar))
(-> (const prop))
(-> (lexical tmpvar tmpvar))))))))
((preinc (aref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
(let1 (comp prop e)
(lambda (propvar)
(begin1 (-> (apply (-> (primitive '+))
(@impl pget
(-> (lexical objvar objvar))
(-> (lexical propvar propvar)))
(-> (const 1))))
(lambda (tmpvar)
(@impl pput
(-> (lexical objvar objvar))
(-> (lexical propvar propvar))
(-> (lexical tmpvar tmpvar))))))))))
((predec (ref ,foo))
(let ((v (lookup foo e)))
(-> (begin
(-> (set! v
(-> (apply (-> (primitive '-))
v
(-> (const 1))))))
v))))
((predec (pref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
(begin1 (-> (apply (-> (primitive '-))
(@impl pget
(-> (lexical objvar objvar))
(-> (const prop)))
(-> (const 1))))
(lambda (tmpvar)
(@impl pput
(-> (lexical objvar objvar))
(-> (const prop))
(-> (lexical tmpvar tmpvar))))))))
((predec (aref ,obj ,prop))
(let1 (comp obj e)
(lambda (objvar)
(let1 (comp prop e)
(lambda (propvar)
(begin1 (-> (apply (-> (primitive '-))
(@impl pget
(-> (lexical objvar objvar))
(-> (lexical propvar propvar)))
(-> (const 1))))
(lambda (tmpvar)
(@impl pput
(-> (lexical objvar objvar))
(-> (lexical propvar propvar))
(-> (lexical tmpvar tmpvar))))))))))
((ref ,id)
(lookup id e))
((var . ,forms)
(-> (begin
(map (lambda (form)
(pmatch form
((,x ,y)
(-> (define x (comp y e))))
((,x)
(-> (define x (@implv *undefined*))))
(else (error "bad var form" form))))
forms))))
((begin . ,forms)
`(begin ,@(map (lambda (x) (comp x e)) forms)))
((lambda ,formals ,body)
(let ((%args (gensym "%args ")))
(-> (lambda '%args %args '()
(comp-body (econs '%args %args e) body formals '%args)))))
((call/this ,obj ,prop . ,args)
(@impl call/this*
obj
(-> (lambda '() '() '()
`(apply ,(@impl pget obj prop) ,@args)))))
((call (pref ,obj ,prop) ,args)
(comp `(call/this ,(comp obj e)
,(-> (const prop))
,@(map (lambda (x) (comp x e)) args))
e))
((call (aref ,obj ,prop) ,args)
(comp `(call/this ,(comp obj e)
,(comp prop e)
,@(map (lambda (x) (comp x e)) args))
e))
((call ,proc ,args)
`(apply ,(comp proc e)
,@(map (lambda (x) (comp x e)) args)))
((return ,expr)
(-> (apply (-> (primitive 'return))
(comp expr e))))
((array . ,args)
`(apply ,(@implv new-array)
,@(map (lambda (x) (comp x e)) args)))
((object . ,args)
(@impl new-object
(map (lambda (x)
(pmatch x
((,prop ,val)
(-> (apply (-> (primitive 'cons))
(-> (const prop))
(comp val e))))
(else
(error "bad prop-val pair" x))))
args)))
((pref ,obj ,prop)
(@impl pget
(comp obj e)
(-> (const prop))))
((aref ,obj ,index)
(@impl pget
(comp obj e)
(comp index e)))
((= (ref ,name) ,val)
(let ((v (lookup name e)))
(-> (begin
(-> (set! v (comp val e)))
v))))
((= (pref ,obj ,prop) ,val)
(@impl pput
(comp obj e)
(-> (const prop))
(comp val e)))
((= (aref ,obj ,prop) ,val)
(@impl pput
(comp obj e)
(comp prop e)
(comp val e)))
((+= ,what ,val)
(comp `(= ,what (+ ,what ,val)) e))
((-= ,what ,val)
(comp `(= ,what (- ,what ,val)) e))
((/= ,what ,val)
(comp `(= ,what (/ ,what ,val)) e))
((*= ,what ,val)
(comp `(= ,what (* ,what ,val)) e))
((%= ,what ,val)
(comp `(= ,what (% ,what ,val)) e))
((>>= ,what ,val)
(comp `(= ,what (>> ,what ,val)) e))
((<<= ,what ,val)
(comp `(= ,what (<< ,what ,val)) e))
((>>>= ,what ,val)
(comp `(= ,what (>>> ,what ,val)) e))
((&= ,what ,val)
(comp `(= ,what (& ,what ,val)) e))
((bor= ,what ,val)
(comp `(= ,what (bor ,what ,val)) e))
((^= ,what ,val)
(comp `(= ,what (^ ,what ,val)) e))
((new ,what ,args)
(@impl new
(map (lambda (x) (comp x e))
(cons what args))))
((delete (pref ,obj ,prop))
(@impl pdel
(comp obj e)
(-> (const prop))))
((delete (aref ,obj ,prop))
(@impl pdel
(comp obj e)
(comp prop e)))
((void ,expr)
(-> (begin
(comp expr e)
(@implv *undefined*))))
((typeof ,expr)
(@impl typeof
(comp expr e)))
((do ,statement ,test)
(let ((%loop (gensym "%loop "))
(%continue (gensym "%continue ")))
(let ((e (econs '%loop %loop (econs '%continue %continue e))))
(-> (letrec '(%loop %continue) (list %loop %continue)
(list (-> (lambda '() '() '()
(-> (begin
(comp statement e)
(-> (apply (-> (lexical '%continue %continue)))
)))))
(-> (lambda '() '() '()
(-> (if (@impl ->boolean (comp test e))
(-> (apply (-> (lexical '%loop %loop))))
(@implv *undefined*))))))
(-> (apply (-> (lexical '%loop %loop)))))))))
((while ,test ,statement)
(let ((%continue (gensym "%continue ")))
(let ((e (econs '%continue %continue e)))
(-> (letrec '(%continue) (list %continue)
(list (-> (lambda '() '() '()
(-> (if (@impl ->boolean (comp test e))
(-> (begin (comp statement e)
(-> (apply (-> (lexical '%continue %continue))))))
(@implv *undefined*))))))
(-> (apply (-> (lexical '%continue %continue)))))))))
((for ,init ,test ,inc ,statement)
(let ((%continue (gensym "%continue ")))
(let ((e (econs '%continue %continue e)))
(-> (letrec '(%continue) (list %continue)
(list (-> (lambda '() '() '()
(-> (if (if test
(@impl ->boolean (comp test e))
(comp 'true e))
(-> (begin (comp statement e)
(comp (or inc '(begin)) e)
(-> (apply (-> (lexical '%continue %continue))))))
(@implv *undefined*))))))
(-> (begin (comp (or init '(begin)) e)
(-> (apply (-> (lexical '%continue %continue)))))))))))
((for-in ,var ,object ,statement)
(let ((%enum (gensym "%enum "))
(%continue (gensym "%continue ")))
(let ((e (econs '%enum %enum (econs '%continue %continue e))))
(-> (letrec '(%enum %continue) (list %enum %continue)
(list (@impl make-enumerator (comp object e))
(-> (lambda '() '() '()
(-> (if (@impl ->boolean
(@impl pget
(-> (lexical '%enum %enum))
(-> (const 'length))))
(-> (begin
(comp `(= ,var (call/this ,(-> (lexical '%enum %enum))
,(-> (const 'pop))))
e)
(comp statement e)
(-> (apply (-> (lexical '%continue %continue))))))
(@implv *undefined*))))))
(-> (apply (-> (lexical '%continue %continue)))))))))
((block ,x)
(comp x e))
(else
(error "compilation not yet implemented:" x)))))
(define (comp-body e body formals %args)
(define (process)
(let lp ((in body) (out '()) (rvars (reverse formals)))
(pmatch in
(((var (,x) . ,morevars) . ,rest)
(lp `((var . ,morevars) . ,rest)
out
(if (memq x rvars) rvars (cons x rvars))))
(((var (,x ,y) . ,morevars) . ,rest)
(lp `((var . ,morevars) . ,rest)
`((= (ref ,x) ,y) . ,out)
(if (memq x rvars) rvars (cons x rvars))))
(((var) . ,rest)
(lp rest out rvars))
((,x . ,rest) (guard (and (pair? x) (eq? (car x) 'lambda)))
(lp rest
(cons x out)
rvars))
((,x . ,rest) (guard (pair? x))
(receive (sub-out rvars)
(lp x '() rvars)
(lp rest
(cons sub-out out)
rvars)))
((,x . ,rest)
(lp rest
(cons x out)
rvars))
(()
(values (reverse! out)
rvars)))))
(receive (out rvars)
(process)
(let* ((names (reverse rvars))
(syms (map (lambda (x)
(gensym (string-append (symbol->string x) " ")))
names))
(e (fold acons e names syms)))
(let ((%argv (lookup %args e)))
(let lp ((names names) (syms syms))
(if (null? names)
;; fixme: here check for too many args
(comp out e)
(-> (let (list (car names)) (list (car syms))
(list (-> (if (-> (apply (-> (primitive 'null?)) %argv))
(-> (@implv *undefined*))
(-> (let1 (-> (apply (-> (primitive 'car)) %argv))
(lambda (v)
(-> (set! %argv
(-> (apply (-> (primitive 'cdr)) %argv))))
(-> (lexical v v))))))))
(lp (cdr names) (cdr syms))))))))))

27
module/language/ecmascript/function.scm
View file

@ -2,20 +2,19 @@
;; 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.
;;;; 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 3 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
;;; Code:

27
module/language/ecmascript/impl.scm
View file

@ -2,20 +2,19 @@
;; 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.
;;;; 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 3 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
;;; Code:

25
module/language/ecmascript/parse-lalr.scm
View file

@ -2,18 +2,19 @@
;; Copyright (C) 1984,1989,1990 Free Software Foundation, Inc.
;; Copyright (C) 1996-2002 Dominique Boucher
;; 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 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>.
;;;; 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 3 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
;; ---------------------------------------------------------------------- ;;

27
module/language/ecmascript/parse.scm
View file

@ -2,20 +2,19 @@
;; 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.
;;;; 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 3 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
;;; Code:

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

@ -2,27 +2,26 @@
;; 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.
;;;; 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 3 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
;;; Code:
(define-module (language ecmascript spec)
#:use-module (system base language)
#:use-module (language ecmascript parse)
#:use-module (language ecmascript compile-ghil)
#:use-module (language ecmascript compile-tree-il)
#:export (ecmascript))
;;;
@ -33,8 +32,7 @@
#:title "Guile ECMAScript"
#:version "3.0"
#:reader (lambda () (read-ecmascript/1 (current-input-port)))
#:read-file read-ecmascript
#:compilers `((ghil . ,compile-ghil))
#:compilers `((tree-il . ,compile-tree-il))
;; a pretty-printer would be interesting.
#:printer write
)

29
module/language/ecmascript/tokenize.scm
View file

@ -2,20 +2,19 @@
;; 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.
;;;; 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 3 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
;;; Code:
@ -366,7 +365,7 @@
. ,(cdar puncs))))))
(lp nodes (cdr puncs))))
(else
(lp (cons `(,(string-ref (caar puncs) 0) #f) nodes)
(lp (cons (list (string-ref (caar puncs) 0) #f) nodes)
puncs))))))
(lambda (port)
(let lp ((c (peek-char port)) (tree punc-tree) (candidate #f))

27
module/language/elisp/spec.scm
View file

@ -2,20 +2,19 @@
;; 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.
;;;; 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 3 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
;;; Code:

32
module/language/ghil.scm
View file

@ -2,20 +2,19 @@
;; 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.
;;;; 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 3 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
;;; Code:
@ -432,7 +431,10 @@
((<ghil-quote> env loc obj)
`(,'quote ,obj))
((<ghil-quasiquote> env loc exp)
`(,'quasiquote ,(map unparse-ghil exp)))
`(,'quasiquote ,(let lp ((x exp))
(cond ((struct? x) (unparse-ghil x))
((pair? x) (cons (lp (car x)) (lp (cdr x))))
(else x)))))
((<ghil-unquote> env loc exp)
`(,'unquote ,(unparse-ghil exp)))
((<ghil-unquote-splicing> env loc exp)

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

@ -2,25 +2,24 @@
;; 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.
;;;; 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 3 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
;;; Code:
(define-module (language ghil compile-glil)
#:use-syntax (system base syntax)
#:use-module (system base syntax)
#:use-module (language glil)
#:use-module (language ghil)
#:use-module (ice-9 common-list)
@ -29,7 +28,8 @@
(define (compile-glil x e opts)
(if (memq #:O opts) (set! x (optimize x)))
(values (codegen x)
(and e (cons (car e) (cddr e)))))
(and e (cons (car e) (cddr e)))
e))
;;;
@ -186,7 +186,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)
@ -216,7 +216,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)))))
@ -495,7 +497,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)
@ -508,7 +510,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)
@ -522,8 +524,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)

46
module/language/ghil/spec.scm
View file

@ -2,20 +2,19 @@
;; 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.
;;;; 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 3 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
;;; Code:
@ -34,11 +33,30 @@
(lambda (env vars)
(make-ghil-lambda env #f vars #f '() (parse-ghil env x)))))
(define (join exps env)
(if (or-map (lambda (x)
(or (not (ghil-lambda? x))
(ghil-lambda-rest x)
(memq 'argument
(map ghil-var-kind
(ghil-env-variables (ghil-lambda-env x))))))
exps)
(error "GHIL expressions to join must be thunks"))
(let ((env (make-ghil-env env '()
(apply append
(map ghil-env-variables
(map ghil-lambda-env exps))))))
(make-ghil-lambda env #f '() #f '()
(make-ghil-begin env #f
(map ghil-lambda-body exps)))))
(define-language ghil
#:title "Guile High Intermediate Language (GHIL)"
#:version "0.3"
#:reader read
#:printer write-ghil
#:parser parse
#:joiner join
#:compilers `((glil . ,compile-glil))
)

90
module/language/glil.scm
View file

@ -1,21 +1,20 @@
;;; Guile Low Intermediate Language
;; Copyright (C) 2001 Free Software Foundation, Inc.
;; 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.
;;;; 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 3 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
;;; Code:
@ -25,9 +24,9 @@
#:use-module ((srfi srfi-1) #:select (fold))
#:export
(<glil-program> make-glil-program glil-program?
glil-program-nargs glil-program-nrest glil-program-nlocs glil-program-nexts
glil-program-meta glil-program-body glil-program-closure-level
glil-program-nargs glil-program-nrest glil-program-nlocs
glil-program-meta glil-program-body
<glil-bind> make-glil-bind glil-bind?
glil-bind-vars
@ -44,14 +43,8 @@
<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
<glil-external> make-glil-external glil-external?
glil-external-op glil-external-depth glil-external-index
<glil-lexical> make-glil-lexical glil-lexical?
glil-lexical-local? glil-lexical-boxed? glil-lexical-op glil-lexical-index
<glil-toplevel> make-glil-toplevel glil-toplevel?
glil-toplevel-op glil-toplevel-name
@ -78,7 +71,7 @@
(define-type (<glil> #:printer print-glil)
;; Meta operations
(<glil-program> nargs nrest nlocs nexts meta body (closure-level #f))
(<glil-program> nargs nrest nlocs meta body)
(<glil-bind> vars)
(<glil-mv-bind> vars rest)
(<glil-unbind>)
@ -87,9 +80,7 @@
(<glil-void>)
(<glil-const> obj)
;; Variables
(<glil-argument> op index)
(<glil-local> op index)
(<glil-external> op depth index)
(<glil-lexical> local? boxed? op index)
(<glil-toplevel> op name)
(<glil-module> op mod name public?)
;; Controls
@ -98,40 +89,23 @@
(<glil-call> inst nargs)
(<glil-mv-call> nargs ra))
(define (compute-closure-level body)
(fold (lambda (x ret)
(record-case x
((<glil-program> closure-level) (max ret closure-level))
((<glil-external> depth) (max ret depth))
(else ret)))
0 body))
(define %make-glil-program make-glil-program)
(define (make-glil-program . args)
(let ((prog (apply %make-glil-program args)))
(if (not (glil-program-closure-level prog))
(set! (glil-program-closure-level prog)
(compute-closure-level (glil-program-body prog))))
prog))
(define (parse-glil x)
(pmatch x
((program ,nargs ,nrest ,nlocs ,nexts ,meta . ,body)
(make-glil-program nargs nrest nlocs nexts meta (map parse-glil body)))
((program ,nargs ,nrest ,nlocs ,meta . ,body)
(make-glil-program nargs nrest nlocs meta (map parse-glil body)))
((bind . ,vars) (make-glil-bind vars))
((mv-bind ,vars ,rest) (make-glil-mv-bind vars rest))
((unbind) (make-glil-unbind))
((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))
((lexical ,local? ,boxed? ,op ,index) (make-glil-lexical local? boxed? op 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))
@ -140,8 +114,8 @@
(define (unparse-glil glil)
(record-case glil
;; meta
((<glil-program> nargs nrest nlocs nexts meta body)
`(program ,nargs ,nrest ,nlocs ,nexts ,meta ,@(map unparse-glil body)))
((<glil-program> nargs nrest nlocs meta body)
`(program ,nargs ,nrest ,nlocs ,meta ,@(map unparse-glil body)))
((<glil-bind> vars) `(bind ,@vars))
((<glil-mv-bind> vars rest) `(mv-bind ,vars ,rest))
((<glil-unbind>) `(unbind))
@ -150,12 +124,8 @@
((<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)
`(external ,op ,depth ,index))
((<glil-lexical> local? boxed? op index)
`(lexical ,local? ,boxed? ,op ,index))
((<glil-toplevel> op name)
`(toplevel ,op ,name))
((<glil-module> op mod name public?)

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

@ -2,20 +2,19 @@
;; 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.
;;;; 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 3 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
;;; Code:
@ -28,6 +27,7 @@
#:use-module ((system vm program) #:select (make-binding))
#:use-module (ice-9 receive)
#:use-module ((srfi srfi-1) #:select (fold))
#:use-module (rnrs bytevector)
#:export (compile-assembly))
;; Variable cache cells go in the object table, and serialize as their
@ -72,27 +72,26 @@
(if (and (null? bindings) (null? sources) (null? tail))
#f
(compile-assembly
(make-glil-program 0 0 0 0 '()
(make-glil-program 0 0 0 '()
(list
(make-glil-const `(,bindings ,sources ,@tail))
(make-glil-call 'return 1))))))
;; A functional stack of names of live variables.
(define (make-open-binding name ext? index)
(list name ext? index))
(define (make-open-binding name boxed? index)
(list name boxed? index))
(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 external ,i) (make-open-binding name #t i))
(else (error "unknown binding type" name type))))
((,name ,boxed? ,i)
(make-open-binding name boxed? i))
(else (error "unknown binding type" v))))
vars)
(car bindings))
(cdr bindings)))
@ -129,81 +128,88 @@
(define (compile-assembly glil)
(receive (code . _)
(glil->assembly glil 0 '() '(()) '() '() #f -1)
(glil->assembly glil #t '(()) '() '() #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 toplevel? bindings
source-alist label-alist object-alist addr)
(define (emit-code x)
(values (map assembly-pack x) bindings source-alist label-alist object-alist))
(values x bindings source-alist label-alist object-alist))
(define (emit-code/object x object-alist)
(values (map assembly-pack x) bindings source-alist label-alist object-alist))
(values x bindings source-alist label-alist object-alist))
(record-case glil
((<glil-program> nargs nrest nlocs nexts meta body closure-level)
(let ((toplevel? (null? nexts-stack)))
(define (process-body)
(let ((nexts-stack (cons nexts nexts-stack)))
(let lp ((body body) (code '()) (bindings '(())) (source-alist '())
(label-alist '()) (object-alist (if toplevel? #f '())) (addr 0))
(cond
((null? body)
(values (reverse code)
(close-all-bindings bindings addr)
(limn-sources (reverse! source-alist))
(reverse label-alist)
(and object-alist (map car (reverse object-alist)))
addr))
(else
(receive (subcode bindings source-alist label-alist object-alist)
(glil->assembly (car body) nargs nexts-stack bindings
source-alist label-alist object-alist addr)
(lp (cdr body) (append (reverse subcode) code)
bindings source-alist label-alist object-alist
(addr+ addr subcode))))))))
((<glil-program> nargs nrest nlocs meta body)
(define (process-body)
(let lp ((body body) (code '()) (bindings '(())) (source-alist '())
(label-alist '()) (object-alist (if toplevel? #f '())) (addr 0))
(cond
((null? body)
(values (reverse code)
(close-all-bindings bindings addr)
(limn-sources (reverse! source-alist))
(reverse label-alist)
(and object-alist (map car (reverse object-alist)))
addr))
(else
(receive (subcode bindings source-alist label-alist object-alist)
(glil->assembly (car body) #f bindings
source-alist label-alist object-alist addr)
(lp (cdr body) (append (reverse subcode) code)
bindings source-alist label-alist object-alist
(addr+ addr subcode)))))))
(receive (code bindings sources labels objects len)
(process-body)
(let ((prog `(load-program ,nargs ,nrest ,nlocs ,nexts ,labels
,len
,(make-meta bindings sources meta)
. ,code)))
(cond
(toplevel?
;; toplevel bytecode isn't loaded by the vm, no way to do
;; object table or closure capture (not in the bytecode,
;; anyway)
(emit-code (align-program prog addr)))
(else
(let ((table (dump-object (make-object-table objects) addr))
(closure (if (> closure-level 0) '((make-closure)) '())))
(cond
(object-alist
;; if we are being compiled from something with an object
;; table, cache the program there
(receive (i object-alist)
(object-index-and-alist (make-subprogram table prog)
object-alist)
(emit-code/object `((object-ref ,i) ,@closure)
object-alist)))
(else
;; otherwise emit a load directly
(emit-code `(,@table ,@(align-program prog (addr+ addr table))
,@closure)))))))))))
(receive (code bindings sources labels objects len)
(process-body)
(let* ((meta (make-meta bindings sources meta))
(meta-pad (if meta (modulo (- 8 (modulo len 8)) 8) 0))
(prog `(load-program ,nargs ,nrest ,nlocs ,labels
,(+ len meta-pad)
,meta
,@code
,@(if meta
(make-list meta-pad '(nop))
'()))))
(cond
(toplevel?
;; toplevel bytecode isn't loaded by the vm, no way to do
;; object table or closure capture (not in the bytecode,
;; anyway)
(emit-code (align-program prog addr)))
(else
(let ((table (make-object-table objects)))
(cond
(object-alist
;; if we are being compiled from something with an object
;; table, cache the program there
(receive (i object-alist)
(object-index-and-alist (make-subprogram table prog)
object-alist)
(emit-code/object `(,(if (< i 256)
`(object-ref ,i)
`(long-object-ref ,(quotient i 256)
,(modulo i 256))))
object-alist)))
(else
;; otherwise emit a load directly
(let ((table-code (dump-object table addr)))
(emit-code
`(,@table-code
,@(align-program prog (addr+ addr table-code)))))))))))))
((<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))
@ -235,27 +241,57 @@
(else
(receive (i object-alist)
(object-index-and-alist obj object-alist)
(emit-code/object `((object-ref ,i))
(emit-code/object (if (< i 256)
`((object-ref ,i))
`((long-object-ref ,(quotient i 256)
,(modulo i 256))))
object-alist)))))
((<glil-argument> 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)
(lp (1- d) (+ n (car stack)) (cdr stack))
(if (eq? op 'ref)
`((external-ref ,(+ n index)))
`((external-set ,(+ n index))))))))
((<glil-lexical> local? boxed? op index)
(emit-code
(if local?
(if (< index 256)
(case op
((ref) (if boxed?
`((local-boxed-ref ,index))
`((local-ref ,index))))
((set) (if boxed?
`((local-boxed-set ,index))
`((local-set ,index))))
((box) `((box ,index)))
((empty-box) `((empty-box ,index)))
((fix) `((fix-closure 0 ,index)))
(else (error "what" op)))
(let ((a (quotient i 256))
(b (modulo i 256)))
`((,(case op
((ref)
(if boxed?
`((long-local-ref ,a ,b)
(variable-ref))
`((long-local-ref ,a ,b))))
((set)
(if boxed?
`((long-local-ref ,a ,b)
(variable-set))
`((long-local-set ,a ,b))))
((box)
`((make-variable)
(variable-set)
(long-local-set ,a ,b)))
((empty-box)
`((make-variable)
(long-local-set ,a ,b)))
((fix)
`((fix-closure ,a ,b)))
(else (error "what" op)))
,index))))
`((,(case op
((ref) (if boxed? 'free-boxed-ref 'free-ref))
((set) (if boxed? 'free-boxed-set (error "what." glil)))
(else (error "what" op)))
,index)))))
((<glil-toplevel> op name)
(case op
((ref set)
@ -270,13 +306,20 @@
(receive (i object-alist)
(object-index-and-alist (make-variable-cache-cell name)
object-alist)
(emit-code/object (case op
((ref) `((toplevel-ref ,i)))
((set) `((toplevel-set ,i))))
(emit-code/object (if (< i 256)
`((,(case op
((ref) 'toplevel-ref)
((set) 'toplevel-set))
,i))
`((,(case op
((ref) 'long-toplevel-ref)
((set) 'long-toplevel-set))
,(quotient i 256)
,(modulo i 256))))
object-alist)))))
((define)
(emit-code `((define ,(symbol->string name))
(variable-set))))
(emit-code `(,@(dump-object name addr)
(define))))
(else
(error "unknown toplevel var kind" op name))))
@ -303,11 +346,12 @@
(error "unknown module var kind" op key)))))
((<glil-label> label)
(values '()
bindings
source-alist
(acons label addr label-alist)
object-alist))
(let ((code (align-block addr)))
(values code
bindings
source-alist
(acons label (addr+ addr code) label-alist)
object-alist)))
((<glil-branch> inst label)
(emit-code `((,inst ,label))))
@ -318,7 +362,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
@ -335,25 +384,27 @@
((object->assembly x) => list)
((variable-cache-cell? x) (dump-object (variable-cache-cell-key x) addr))
((subprogram? x)
`(,@(subprogram-table x)
,@(align-program (subprogram-prog x)
(addr+ addr (subprogram-table x)))))
((and (integer? x) (exact? x))
(let ((str (do ((n x (quotient n 256))
(l '() (cons (modulo n 256) l)))
((= n 0)
(list->string (map integer->char l))))))
(if (< x 0)
`((load-integer ,str))
`((load-unsigned-integer ,str)))))
(let ((table-code (dump-object (subprogram-table x) addr)))
`(,@table-code
,@(align-program (subprogram-prog x)
(addr+ addr table-code)))))
((number? x)
`((load-number ,(number->string x))))
((string? x)
`((load-string ,x)))
(case (string-width x)
((1) `((load-string ,x)))
((4) (align-code `(load-wide-string ,x) addr 4 4))
(else (error "bad string width" x))))
((symbol? x)
`((load-symbol ,(symbol->string x))))
(let ((str (symbol->string x)))
(case (string-width str)
((1) `((load-symbol ,str)))
((4) `(,@(dump-object str addr)
(make-symbol)))
(else (error "bad string width" str)))))
((keyword? x)
`((load-keyword ,(symbol->string (keyword->symbol x)))))
`(,@(dump-object (keyword->symbol x) addr)
(make-keyword)))
((list? x)
(let ((tail (let ((len (length x)))
(if (>= len 65536) (too-long "list"))
@ -380,6 +431,16 @@
(let ((code (dump-object (vector-ref x i) addr)))
(dump-objects (1+ i) (cons code codes)
(addr+ addr code)))))))
((and (array? x) (symbol? (array-type x)))
(let* ((type (dump-object (array-type x) addr))
(shape (dump-object (array-shape x) (addr+ addr type))))
`(,@type
,@shape
,@(align-code
`(load-array ,(uniform-array->bytevector x))
(addr+ (addr+ addr type) shape)
8
4))))
(else
(error "assemble: unrecognized object" x))))

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

@ -1,21 +1,20 @@
;;; Guile VM code converters
;; Copyright (C) 2001 Free Software Foundation, Inc.
;; 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.
;;;; 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 3 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
;;; Code:
@ -32,8 +31,8 @@
(define (decompile-toplevel x)
(pmatch x
((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,body)
(decompile-load-program nargs nrest nlocs nexts
((load-program ,nargs ,nrest ,nlocs ,labels ,len ,meta . ,body)
(decompile-load-program nargs nrest nlocs
(decompile-meta meta)
body labels #f))
(else
@ -57,7 +56,7 @@
((glil-program? (car in)) (lp (cdr in) (cons (car in) out)))
(else (lp (cdr in) (cons (make-glil-const (car l)) out))))))
(define (decompile-load-program nargs nrest nlocs nexts meta body labels
(define (decompile-load-program nargs nrest nlocs meta body labels
objects)
(let ((glil-labels (sort (map (lambda (x)
(cons (cdr x) (make-glil-label (car x))))
@ -101,19 +100,11 @@
(cond
((null? in)
(or (null? stack) (error "leftover stack insts" stack body))
(make-glil-program nargs nrest nlocs nexts props (reverse out) #f))
(make-glil-program nargs nrest nlocs props (reverse out) #f))
((pop-bindings! pos)
=> (lambda (bindings)
(lp in stack
(cons (make-glil-bind
(map (lambda (x)
(let ((name (binding:name x))
(i (binding:index x)))
(cond
((binding:extp x) `(,name external ,i))
((< i nargs) `(,name argument ,i))
(else `(,name local ,(- i nargs))))))
bindings))
(cons (make-glil-bind bindings)
out)
pos)))
((pop-unbindings! pos)
@ -175,15 +166,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)

29
module/language/glil/spec.scm
View file

@ -2,20 +2,19 @@
;; 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.
;;;; 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 3 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
;;; Code:
@ -30,7 +29,7 @@
(apply write (unparse-glil exp) port))
(define (compile-asm x e opts)
(values (compile-assembly x) e))
(values (compile-assembly x) e e))
(define-language glil
#:title "Guile Lowlevel Intermediate Language (GLIL)"

27
module/language/objcode.scm
View file

@ -2,20 +2,19 @@
;; 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.
;;;; 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 3 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
;;; Code:

Some files were not shown because too many files have changed in this diff Show more