diff options
Diffstat (limited to 'module')
-rw-r--r-- | module/Makefile.am | 1 | ||||
-rw-r--r-- | module/ice-9/boot-9.scm | 26 | ||||
-rw-r--r-- | module/ice-9/command-line.scm | 426 | ||||
-rw-r--r-- | module/ice-9/control.scm | 30 | ||||
-rw-r--r-- | module/ice-9/popen.scm | 4 | ||||
-rw-r--r-- | module/ice-9/top-repl.scm | 9 | ||||
-rw-r--r-- | module/language/tree-il/analyze.scm | 26 | ||||
-rw-r--r-- | module/rnrs/arithmetic/fixnums.scm | 19 | ||||
-rw-r--r-- | module/srfi/srfi-9.scm | 31 |
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) |