summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
Diffstat (limited to 'module')
-rw-r--r--module/Makefile.am1
-rw-r--r--module/ice-9/boot-9.scm26
-rw-r--r--module/ice-9/command-line.scm426
-rw-r--r--module/ice-9/control.scm30
-rw-r--r--module/ice-9/popen.scm4
-rw-r--r--module/ice-9/top-repl.scm9
-rw-r--r--module/language/tree-il/analyze.scm26
-rw-r--r--module/rnrs/arithmetic/fixnums.scm19
-rw-r--r--module/srfi/srfi-9.scm31
9 files changed, 544 insertions, 28 deletions
diff --git a/module/Makefile.am b/module/Makefile.am
index 2685a3a63..42aff1833 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -181,6 +181,7 @@ ICE_9_SOURCES = \
ice-9/and-let-star.scm \
ice-9/binary-ports.scm \
ice-9/calling.scm \
+ ice-9/command-line.scm \
ice-9/common-list.scm \
ice-9/control.scm \
ice-9/curried-definitions.scm \
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 327e3fa31..401d90476 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -957,8 +957,9 @@ VALUE."
-(if (provided? 'posix)
- (primitive-load-path "ice-9/posix"))
+;; Load `posix.scm' even when not (provided? 'posix) so that we get the
+;; `stat' accessors.
+(primitive-load-path "ice-9/posix")
(if (provided? 'socket)
(primitive-load-path "ice-9/networking"))
@@ -2784,13 +2785,11 @@ module '(ice-9 q) '(make-q q-length))}."
(define-syntax #,(datum->syntax #'while 'break)
(lambda (x)
(syntax-case x ()
- ((_)
- #'(abort-to-prompt break-tag))
- ((_ . args)
- (syntax-violation 'break "too many arguments" x))
+ ((_ arg (... ...))
+ #'(abort-to-prompt break-tag arg (... ...)))
(_
- #'(lambda ()
- (abort-to-prompt break-tag))))))
+ #'(lambda args
+ (apply abort-to-prompt break-tag args))))))
(let lp ()
(call-with-prompt
continue-tag
@@ -2805,10 +2804,12 @@ module '(ice-9 q) '(make-q q-length))}."
(_
#'(lambda ()
(abort-to-prompt continue-tag))))))
- (do () ((not cond)) body ...))
+ (do () ((not cond) #f) body ...))
(lambda (k) (lp)))))
- (lambda (k)
- #t)))))))
+ (lambda (k . args)
+ (if (null? args)
+ #t
+ (apply values args)))))))))
@@ -3289,7 +3290,8 @@ module '(ice-9 q) '(make-q q-length))}."
(catch #t
(lambda ()
(let* ((scmstat (stat name))
- (gostat (stat go-path #f)))
+ (gostat (and (not %fresh-auto-compile)
+ (stat go-path #f))))
(if (and gostat
(or (> (stat:mtime gostat) (stat:mtime scmstat))
(and (= (stat:mtime gostat) (stat:mtime scmstat))
diff --git a/module/ice-9/command-line.scm b/module/ice-9/command-line.scm
new file mode 100644
index 000000000..a34c9a67c
--- /dev/null
+++ b/module/ice-9/command-line.scm
@@ -0,0 +1,426 @@
+;;; Parsing Guile's command-line
+
+;;; Copyright (C) 1994-1998, 2000-2011 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:
+
+;;;
+;;; Please be careful not to load up other modules in this file, unless
+;;; they are explicitly requested. Loading modules currently imposes a
+;;; speed penalty of a few stats, an mmap, and some allocation, which
+;;; can range from 1 to 20ms, depending on the state of your disk cache.
+;;; Since `compile-shell-switches' is called even for the most transient
+;;; of command-line programs, we need to keep it lean.
+;;;
+;;; Generally speaking, the goal is for Guile to boot and execute simple
+;;; expressions like "1" within 20ms or less, measured using system time
+;;; from the time of the `guile' invocation to exit.
+;;;
+
+(define-module (ice-9 command-line)
+ #:autoload (system vm vm) (set-default-vm-engine! set-vm-engine! the-vm)
+ #:export (compile-shell-switches
+ version-etc
+ *GPLv3+*
+ *LGPLv3+*
+ emit-bug-reporting-address))
+
+;; An initial stab at i18n.
+(define _ gettext)
+
+(define *GPLv3+*
+ (_ "License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>.
+This is free software: you are free to change and redistribute it.
+There is NO WARRANTY, to the extent permitted by law."))
+
+(define *LGPLv3+*
+ (_ "License LGPLv3+: GNU LGPL 3 or later <http://gnu.org/licenses/lgpl.html>.
+This is free software: you are free to change and redistribute it.
+There is NO WARRANTY, to the extent permitted by law."))
+
+;; Display the --version information in the
+;; standard way: command and package names, package version, followed
+;; by a short license notice and a list of up to 10 author names.
+;; If COMMAND_NAME is NULL, the PACKAGE is asumed to be the name of
+;; the program. The formats are therefore:
+;; PACKAGE VERSION
+;; or
+;; COMMAND_NAME (PACKAGE) VERSION.
+;;
+;; Based on the version-etc gnulib module.
+;;
+(define* (version-etc package version #:key
+ (port (current-output-port))
+ ;; FIXME: authors
+ (copyright-year 2011)
+ (copyright-holder "Free Software Foundation, Inc.")
+ (copyright (format #f "Copyright (C) ~a ~a"
+ copyright-year copyright-holder))
+ (license *GPLv3+*)
+ command-name
+ packager packager-version)
+ (if command-name
+ (format port "~a (~a) ~a\n" command-name package version)
+ (format port "~a ~a\n" package version))
+
+ (if packager
+ (if packager-version
+ (format port (_ "Packaged by ~a (~a)\n") packager packager-version)
+ (format port (_ "Packaged by ~a\n") packager)))
+
+ (display copyright port)
+ (newline port)
+ (newline port)
+ (display license port)
+ (newline port))
+
+
+;; Display the usual `Report bugs to' stanza.
+;;
+(define* (emit-bug-reporting-address package bug-address #:key
+ (port (current-output-port))
+ (url (string-append
+ "http://www.gnu.org/software/"
+ package
+ "/"))
+ packager packager-bug-address)
+ (format port (_ "\nReport bugs to: ~a\n") bug-address)
+ (if (and packager packager-bug-address)
+ (format port (_ "Report ~a bugs to: ~a\n") packager packager-bug-address))
+ (format port (_ "~a home page: <~a>\n") package url)
+ (format port
+ (_ "General help using GNU software: <http://www.gnu.org/gethelp/>\n")))
+
+(define *usage*
+ (_ "Evaluate Scheme code, interactively or from a script.
+
+ [-s] FILE load Scheme source code from FILE, and exit
+ -c EXPR evalute Scheme expression EXPR, and exit
+ -- stop scanning arguments; run interactively
+
+The above switches stop argument processing, and pass all
+remaining arguments as the value of (command-line).
+If FILE begins with `-' the -s switch is mandatory.
+
+ -L DIRECTORY add DIRECTORY to the front of the module load path
+ -x EXTENSION add EXTENSION to the front of the load extensions
+ -l FILE load Scheme source code from FILE
+ -e FUNCTION after reading script, apply FUNCTION to
+ command line arguments
+ -ds do -s script at this point
+ --debug start with debugging evaluator and backtraces
+ --no-debug start with normal evaluator
+ Default is to enable debugging for interactive
+ use, but not for `-s' and `-c'.
+ --auto-compile compile source files automatically
+ --fresh-auto-compile invalidate auto-compilation cache
+ --no-auto-compile disable automatic source file compilation
+ Default is to enable auto-compilation of source
+ files.
+ --listen[=P] Listen on a local port or a path for REPL clients.
+ If P is not given, the default is local port 37146.
+ -q inhibit loading of user init file
+ --use-srfi=LS load SRFI modules for the SRFIs in LS,
+ which is a list of numbers like \"2,13,14\"
+ -h, --help display this help and exit
+ -v, --version display version information and exit
+ \\ read arguments from following script lines"))
+
+
+(define* (shell-usage name fatal? #:optional fmt . args)
+ (let ((port (if fatal?
+ (current-error-port)
+ (current-output-port))))
+ (if fmt
+ (apply format port fmt args))
+
+ (format port (_ "Usage: ~a [OPTION]... [FILE]...\n") name)
+ (display *usage* port)
+ (newline port)
+
+ (emit-bug-reporting-address
+ "GNU Guile" "bug-guile@gnu.org"
+ #:port port
+ #:url "http://www.gnu.org/software/guile/"
+ #:packager (assq-ref %guile-build-info 'packager)
+ #:packager-bug-address
+ (assq-ref %guile-build-info 'packager-bug-address))
+
+ (if fatal?
+ (exit 1))))
+
+(define (eval-string str)
+ (call-with-input-string
+ str
+ (lambda (port)
+ (let lp ()
+ (let ((exp (read port)))
+ (if (not (eof-object? exp))
+ (begin
+ (eval exp (current-module))
+ (lp))))))))
+
+(define* (compile-shell-switches args #:optional (usage-name "guile"))
+ (let ((arg0 "guile")
+ (do-script '())
+ (entry-point #f)
+ (user-load-path '())
+ (user-extensions '())
+ (interactive? #t)
+ (inhibit-user-init? #f)
+ (turn-on-debugging? #f)
+ (turn-off-debugging? #f))
+
+ (define (error fmt . args)
+ (apply shell-usage usage-name #t fmt args))
+
+ (define (parse args out)
+ (cond
+ ((null? args)
+ (finish args out))
+ (else
+ (let ((arg (car args))
+ (args (cdr args)))
+ (cond
+ ((not (string-prefix? "-" arg)) ; foo
+ ;; If we specified the -ds option, do_script points to the
+ ;; cdr of an expression like (load #f) we replace the car
+ ;; (i.e., the #f) with the script name.
+ (if (pair? do-script)
+ (set-car! do-script arg))
+ (set! arg0 arg)
+ (set! interactive? #f)
+ (finish args
+ (cons `(load ,arg) out)))
+
+ ((string=? arg "-s") ; foo
+ (if (null? args)
+ (error "missing argument to `-s' switch"))
+ (set! arg0 (car args))
+ (if (pair? do-script)
+ (set-car! do-script arg0))
+ (set! interactive? #f)
+ (finish (cdr args)
+ (cons `(load ,arg0) out)))
+
+ ((string=? arg "-c") ; evaluate expr
+ (if (null? args)
+ (error "missing argument to `-c' switch"))
+ (set! interactive? #f)
+ (finish (cdr args)
+ ;; Use our own eval-string to avoid loading (ice-9
+ ;; eval-string), which loads the compiler.
+ (cons `((@@ (ice-9 command-line) eval-string) ,(car args))
+ out)))
+
+ ((string=? arg "--") ; end args go interactive
+ (finish args out))
+
+ ((string=? arg "-l") ; load a file
+ (if (null? args)
+ (error "missing argument to `-l' switch"))
+ (parse (cdr args)
+ (cons `(load ,(car args)) out)))
+
+ ((string=? arg "-L") ; add to %load-path
+ (if (null? args)
+ (error "missing argument to `-L' switch"))
+ (set! user-load-path (cons (car args) user-load-path))
+ (parse (cdr args)
+ out))
+
+ ((string=? arg "-x") ; add to %load-extensions
+ (if (null? args)
+ (error "missing argument to `-L' switch"))
+ (set! user-extensions (cons (car args) user-extensions))
+ (parse (cdr args)
+ out))
+
+ ((string=? arg "-e") ; entry point
+ (if (null? args)
+ (error "missing argument to `-e' switch"))
+ (let* ((port (open-input-string (car args)))
+ (arg1 (read port))
+ (arg2 (read port)))
+ ;; Recognize syntax of certain versions of guile 1.4 and
+ ;; transform to (@ MODULE-NAME FUNC).
+ (set! entry-point
+ (cond
+ ((not (eof-object? arg2))
+ `(@ ,arg1 ,arg2))
+ ((and (pair? arg1)
+ (not (memq (car arg1) '(@ @@)))
+ (and-map symbol? arg1))
+ `(@ ,arg1 main))
+ (else
+ arg1))))
+ (parse (cdr args)
+ out))
+
+ ((string=? arg "-ds") ; do script here
+ ;; We put a dummy "load" expression, and let the -s put the
+ ;; filename in.
+ (if (pair? do-script)
+ (error "the -ds switch may only be specified once")
+ (set! do-script (list #f)))
+ (parse args
+ (cons `(load . ,do-script) out)))
+
+ ((string=? arg "--debug")
+ (set! turn-on-debugging? #t)
+ (set! turn-off-debugging? #f)
+ (parse args out))
+
+ ((string=? arg "--no-debug")
+ (set! turn-off-debugging? #t)
+ (set! turn-on-debugging? #f)
+ (parse args out))
+
+ ;; Do auto-compile on/off now, because the form itself might
+ ;; need this decision.
+ ((string=? arg "--auto-compile")
+ (set! %load-should-auto-compile #t)
+ (parse args out))
+
+ ((string=? arg "--fresh-auto-compile")
+ (set! %load-should-auto-compile #t)
+ (set! %fresh-auto-compile #t)
+ (parse args out))
+
+ ((string=? arg "--no-auto-compile")
+ (set! %load-should-auto-compile #f)
+ (parse args out))
+
+ ((string=? arg "-q") ; don't load user init
+ (set! inhibit-user-init? #t)
+ (parse args out))
+
+ ((string-prefix? "--use-srfi=" arg)
+ (let ((srfis (map (lambda (x)
+ (let ((n (string->number x)))
+ (if (and n (exact? n) (integer? n) (>= n 0))
+ n
+ (error "invalid SRFI specification"))))
+ (string-split (substring arg 11) #\,))))
+ (if (null? srfis)
+ (error "invalid SRFI specification"))
+ (parse args
+ (cons `(use-srfis ',srfis) out))))
+
+ ((string=? arg "--listen") ; start a repl server
+ (parse args
+ (cons '(@@ (system repl server) (spawn-server)) out)))
+
+ ((string-prefix? "--listen=" arg) ; start a repl server
+ (parse
+ args
+ (cons
+ (let ((where (substring arg 8)))
+ (cond
+ ((string->number where) ; --listen=PORT
+ => (lambda (port)
+ (if (and (integer? port) (exact? port) (>= port 0))
+ (error "invalid port for --listen")
+ `(@@ (system repl server)
+ (spawn-server
+ (make-tcp-server-socket #:port ,port))))))
+ ((string-prefix? "/" where) ; --listen=/PATH/TO/SOCKET
+ `(@@ (system repl server)
+ (spawn-server
+ (make-unix-domain-server-socket #:path ,where))))
+ (else
+ (error "unknown argument to --listen"))))
+ out)))
+
+ ((or (string=? arg "-h") (string=? arg "--help"))
+ (shell-usage usage-name #f)
+ (exit 0))
+
+ ((or (string=? arg "-v") (string=? arg "--version"))
+ (version-etc "GNU Guile" (version)
+ #:license *LGPLv3+*
+ #:command-name "guile"
+ #:packager (assq-ref %guile-build-info 'packager)
+ #:packager-version
+ (assq-ref %guile-build-info 'packager-version))
+ (exit 0))
+
+ (else
+ (error "Unrecognized switch ~a" arg)))))))
+
+ (define (finish args out)
+ ;; Check to make sure the -ds got a -s.
+ (if (and (pair? do-script) (not (car do-script)))
+ (error "the `-ds' switch requires the use of `-s' as well"))
+
+ ;; Make any remaining arguments available to the
+ ;; script/command/whatever.
+ (set-program-arguments (cons arg0 args))
+
+ ;; If debugging was requested, or we are interactive and debugging
+ ;; was not explicitly turned off, use the debug engine.
+ (if (or turn-on-debugging?
+ (and interactive? (not turn-off-debugging?)))
+ (begin
+ (set-default-vm-engine! 'debug)
+ (set-vm-engine! (the-vm) 'debug)))
+
+ ;; Return this value.
+ `(;; It would be nice not to load up (ice-9 control), but the
+ ;; default-prompt-handler is nontrivial.
+ (@ (ice-9 control) %)
+ (begin
+ ;; If we didn't end with a -c or a -s and didn't supply a -q, load
+ ;; the user's customization file.
+ ,@(if (and interactive? (not inhibit-user-init?))
+ '((load-user-init))
+ '())
+
+ ;; Use-specified extensions.
+ ,@(map (lambda (ext)
+ `(set! %load-extensions (cons ,ext %load-extensions)))
+ user-extensions)
+
+ ;; Add the user-specified load path here, so it won't be in
+ ;; effect during the loading of the user's customization file.
+ ,@(map (lambda (path)
+ `(set! %load-path (cons ,path %load-path)))
+ user-load-path)
+
+ ;; Put accumulated actions in their correct order.
+ ,@(reverse! out)
+
+ ;; Handle the `-e' switch, if it was specified.
+ ,@(if entry-point
+ `((,entry-point (command-line)))
+ '())
+ ,(if interactive?
+ ;; If we didn't end with a -c or a -s, start the
+ ;; repl.
+ '((@ (ice-9 top-repl) top-repl))
+ ;; Otherwise, after doing all the other actions
+ ;; prescribed by the command line, quit.
+ '(quit)))))
+
+ (if (pair? args)
+ (begin
+ (set! arg0 (car args))
+ (let ((slash (string-rindex arg0 #\/)))
+ (set! usage-name
+ (if slash (substring arg0 (1+ slash)) arg0)))
+ (parse (cdr args) '()))
+ (parse args '()))))
diff --git a/module/ice-9/control.scm b/module/ice-9/control.scm
index dbee61e25..908e0e938 100644
--- a/module/ice-9/control.scm
+++ b/module/ice-9/control.scm
@@ -1,6 +1,6 @@
;;; Beyond call/cc
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011 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
@@ -21,7 +21,7 @@
(define-module (ice-9 control)
#:re-export (call-with-prompt abort-to-prompt
default-prompt-tag make-prompt-tag)
- #:export (% abort))
+ #:export (% abort shift reset shift* reset*))
(define (abort . args)
(apply abort-to-prompt (default-prompt-tag) args))
@@ -54,3 +54,29 @@
(% (default-prompt-tag)
(proc k)
default-prompt-handler))
+
+;; Kindly provided by Wolfgang J Moeller <wjm@heenes.com>, modelled
+;; after the ones by Oleg Kiselyov in
+;; http://okmij.org/ftp/Scheme/delim-control-n.scm, which are in the
+;; public domain, as noted at the top of http://okmij.org/ftp/.
+;;
+(define-syntax reset
+ (syntax-rules ()
+ ((_ . body)
+ (call-with-prompt (default-prompt-tag)
+ (lambda () . body)
+ (lambda (cont f) (f cont))))))
+
+(define-syntax shift
+ (syntax-rules ()
+ ((_ var . body)
+ (abort-to-prompt (default-prompt-tag)
+ (lambda (cont)
+ ((lambda (var) (reset . body))
+ (lambda vals (reset (apply cont vals)))))))))
+
+(define (reset* thunk)
+ (reset (thunk)))
+
+(define (shift* fc)
+ (shift c (fc c)))
diff --git a/module/ice-9/popen.scm b/module/ice-9/popen.scm
index 5445ecb6b..b3def4a1e 100644
--- a/module/ice-9/popen.scm
+++ b/module/ice-9/popen.scm
@@ -139,10 +139,6 @@ A port to the process (based on pipes) is created and returned.
@var{modes} specifies whether an input, an output or an input-output
port to the process is created: it should be the value of
@code{OPEN_READ}, @code{OPEN_WRITE} or @code{OPEN_BOTH}."
-
- ;; Until we get GC hooks working again, pump the guardian here.
- (reap-pipes)
-
(let* ((port/pid (apply open-process mode command args))
(port (car port/pid)))
(pipe-guardian port)
diff --git a/module/ice-9/top-repl.scm b/module/ice-9/top-repl.scm
index 64c023997..d43436c4a 100644
--- a/module/ice-9/top-repl.scm
+++ b/module/ice-9/top-repl.scm
@@ -65,7 +65,14 @@
(call-with-sigint
(lambda ()
(and (defined? 'setlocale)
- (setlocale LC_ALL ""))
+ (catch 'system-error
+ (lambda ()
+ (setlocale LC_ALL ""))
+ (lambda (key subr fmt args errno)
+ (format (current-error-port)
+ "warning: failed to install locale: ~a~%"
+ (strerror (car errno))))))
+
(let ((status (start-repl 'scheme)))
(run-hook exit-hook)
status)))))
diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm
index 60a5bcddd..23eff2ce2 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -1343,6 +1343,25 @@ accurate information is missing from a given `tree-il' element."
min-count max-count))))
(else (error "computer bought the farm" state))))))
+;; Return the literal format pattern for X, or #f.
+(define (const-fmt x)
+ (record-case x
+ ((<const> exp)
+ exp)
+ ((<application> proc args)
+ ;; Gettexted literals, like `(_ "foo")'.
+ (and (record-case proc
+ ((<toplevel-ref> name) (eq? name '_))
+ ((<module-ref> name) (eq? name '_))
+ (else #f))
+ (pmatch args
+ ((,fmt)
+ (record-case fmt
+ ((<const> exp) exp)
+ (else #f)))
+ (else #f))))
+ (else #f)))
+
(define format-analysis
;; Report arity mismatches in the given tree.
(make-tree-analysis
@@ -1355,11 +1374,11 @@ accurate information is missing from a given `tree-il' element."
(define (check-format-args args loc)
(pmatch args
((,port ,fmt . ,rest)
- (guard (const? fmt))
+ (guard (const-fmt fmt))
(if (and (const? port)
(not (boolean? (const-exp port))))
(warning 'format loc 'wrong-port (const-exp port)))
- (let ((fmt (const-exp fmt))
+ (let ((fmt (const-fmt fmt))
(count (length rest)))
(if (string? fmt)
(catch &syntax-error
@@ -1375,6 +1394,9 @@ accurate information is missing from a given `tree-il' element."
(warning 'format loc 'syntax-error key fmt)))
(warning 'format loc 'wrong-format-string fmt))))
((,port ,fmt . ,rest)
+ (if (and (const? port)
+ (not (boolean? (const-exp port))))
+ (warn 'format loc 'wrong-port (const-exp port)))
;; Warn on non-literal format strings, unless they refer to a
;; lexical variable named "fmt".
(if (record-case fmt
diff --git a/module/rnrs/arithmetic/fixnums.scm b/module/rnrs/arithmetic/fixnums.scm
index 0ce245811..e6261999a 100644
--- a/module/rnrs/arithmetic/fixnums.scm
+++ b/module/rnrs/arithmetic/fixnums.scm
@@ -102,17 +102,20 @@
(define (greatest-fixnum) most-positive-fixnum)
(define (least-fixnum) most-negative-fixnum)
- (define-inlinable (fixnum? obj)
+ (define (fixnum? obj)
+ (not (= 0 (logand 2 (object-address obj)))))
+
+ (define-inlinable (inline-fixnum? obj)
(not (= 0 (logand 2 (object-address obj)))))
(define-syntax assert-fixnum
(syntax-rules ()
((_ arg ...)
- (or (and (fixnum? arg) ...)
+ (or (and (inline-fixnum? arg) ...)
(raise (make-assertion-violation))))))
(define (assert-fixnums args)
- (or (for-all fixnum? args) (raise (make-assertion-violation))))
+ (or (for-all inline-fixnum? args) (raise (make-assertion-violation))))
(define-syntax define-fxop*
(syntax-rules ()
@@ -147,13 +150,15 @@
(define (fx+ fx1 fx2)
(assert-fixnum fx1 fx2)
(let ((r (+ fx1 fx2)))
- (or (fixnum? r) (raise (make-implementation-restriction-violation)))
+ (or (inline-fixnum? r)
+ (raise (make-implementation-restriction-violation)))
r))
(define (fx* fx1 fx2)
(assert-fixnum fx1 fx2)
(let ((r (* fx1 fx2)))
- (or (fixnum? r) (raise (make-implementation-restriction-violation)))
+ (or (inline-fixnum? r)
+ (raise (make-implementation-restriction-violation)))
r))
(define* (fx- fx1 #:optional fx2)
@@ -162,10 +167,10 @@
(begin
(assert-fixnum fx2)
(let ((r (- fx1 fx2)))
- (or (fixnum? r) (raise (make-assertion-violation)))
+ (or (inline-fixnum? r) (raise (make-assertion-violation)))
r))
(let ((r (- fx1)))
- (or (fixnum? r) (raise (make-assertion-violation)))
+ (or (inline-fixnum? r) (raise (make-assertion-violation)))
r)))
(define (fxdiv fx1 fx2)
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
index ad9e95de1..6574a8da7 100644
--- a/module/srfi/srfi-9.scm
+++ b/module/srfi/srfi-9.scm
@@ -64,6 +64,37 @@
(cond-expand-provide (current-module) '(srfi-9))
+;; Roll our own instead of using the public `define-inlinable'. This is
+;; because the public one has a different `make-procedure-name', so
+;; using it would require users to recompile code that uses SRFI-9. See
+;; <http://lists.gnu.org/archive/html/guile-devel/2011-04/msg00111.html>.
+
+(define-syntax define-inlinable
+ (lambda (x)
+ (define (make-procedure-name name)
+ (datum->syntax name
+ (symbol-append '% (syntax->datum name)
+ '-procedure)))
+
+ (syntax-case x ()
+ ((_ (name formals ...) body ...)
+ (identifier? #'name)
+ (with-syntax ((proc-name (make-procedure-name #'name))
+ ((args ...) (generate-temporaries #'(formals ...))))
+ #`(begin
+ (define (proc-name formals ...)
+ body ...)
+ (define-syntax name
+ (lambda (x)
+ (syntax-case x ()
+ ((_ args ...)
+ #'((lambda (formals ...)
+ body ...)
+ args ...))
+ (_
+ (identifier? x)
+ #'proc-name))))))))))
+
(define-syntax define-record-type
(lambda (x)
(define (field-identifiers field-specs)