-;;; installed-scm-file
+;;; -*- mode: scheme; coding: utf-8; -*-
-;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2009
+;;;; Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,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.
+;;;; 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
\f
-(define (void) (if #f #f))
-
;; Before compiling, make sure any symbols are resolved in the (guile)
;; module, the primary location of those symbols, rather than in
;; (guile-user), the default module that we compile in.
(define pk peek)
+
(define (warn . stuff)
(with-output-to-port (current-error-port)
(lambda ()
(define (provided? feature)
(and (memq feature *features*) #t))
+\f
+
+;;; {and-map and or-map}
+;;;
+;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)
+;;; (or-map fn lst) is like (or (fn (car lst)) (fn (cadr lst)) (fn...) ...)
+;;;
+
+;; and-map f l
+;;
+;; Apply f to successive elements of l until exhaustion or f returns #f.
+;; If returning early, return #f. Otherwise, return the last value returned
+;; by f. If f has never been called because l is empty, return #t.
+;;
+(define (and-map f lst)
+ (let loop ((result #t)
+ (l lst))
+ (and result
+ (or (and (null? l)
+ result)
+ (loop (f (car l)) (cdr l))))))
+
+;; or-map f l
+;;
+;; Apply f to successive elements of l until exhaustion or while f returns #f.
+;; If returning early, return the return value of f.
+;;
+(define (or-map f lst)
+ (let loop ((result #f)
+ (l lst))
+ (or result
+ (and (not (null? l))
+ (loop (f (car l)) (cdr l))))))
+
+\f
+
;; let format alias simple-format until the more complete version is loaded
(define format simple-format)
\f
-;; Before the module system boots, there are no module names. But
-;; psyntax does want a module-name definition, so give it one.
+;; Define a minimal stub of the module API for psyntax, before modules
+;; have booted.
(define (module-name x)
'(guile))
-(define (module-add! module sym var)
- (hashq-set! (%get-pre-modules-obarray) sym var))
-(define (make-module-ref mod var kind)
- (case kind
- ((public) (if mod `(@ ,mod ,var) var))
- ((private) (if (and mod (not (equal? mod (module-name (current-module)))))
- `(@@ ,mod ,var)
- var))
- ((bare) var)
- ((hygiene) (if (and mod
- (not (equal? mod (module-name (current-module))))
- (module-variable (resolve-module mod) var))
- `(@@ ,mod ,var)
- var))
- (else (error "foo" mod var kind))))
+(define (module-define! module sym val)
+ (let ((v (hashq-ref (%get-pre-modules-obarray) sym)))
+ (if v
+ (variable-set! v val)
+ (hashq-set! (%get-pre-modules-obarray) sym
+ (make-variable val)))))
+(define (module-ref module sym)
+ (let ((v (module-variable module sym)))
+ (if v (variable-ref v) (error "badness!" (pk module) (pk sym)))))
(define (resolve-module . args)
#f)
-(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)
+;; Input hook to syncase -- so that we might be able to pass annotated
+;; expressions in. Currently disabled. Maybe we should just use
+;; source-properties directly.
(define (annotation? x) #f)
+;; API provided by psyntax
+(define syntax-violation #f)
+(define datum->syntax #f)
+(define syntax->datum #f)
+(define identifier? #f)
+(define generate-temporaries #f)
(define bound-identifier=? #f)
-(define datum->syntax-object #f)
(define free-identifier=? #f)
-(define generate-temporaries #f)
-(define identifier? #f)
-(define syntax-object->datum #f)
-
-(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 (syncase-error who format-string why what)
- (%start-stack 'syncase-stack
- (lambda ()
- (scm-error 'misc-error who "~A ~S" (list why what) '()))))
+(define sc-expand #f)
-;; Until the module system is booted, this will be the current expander.
+;; $sc-expand is an implementation detail of psyntax. It is used by
+;; expanded macros, to dispatch an input against a set of patterns.
+(define $sc-dispatch #f)
+
+;; Load it up!
(primitive-load-path "ice-9/psyntax-pp")
+;; %pre-modules-transformer is the Scheme expander from now until the
+;; module system has booted up.
(define %pre-modules-transformer sc-expand)
+(define-syntax and
+ (syntax-rules ()
+ ((_) #t)
+ ((_ x) x)
+ ((_ x y ...) (if x (and y ...) #f))))
+
+(define-syntax or
+ (syntax-rules ()
+ ((_) #f)
+ ((_ x) x)
+ ((_ x y ...) (let ((t x)) (if t t (or y ...))))))
+
+;; The "maybe-more" bits are something of a hack, so that we can support
+;; SRFI-61. Rewrites into a standalone syntax-case macro would be
+;; appreciated.
+(define-syntax cond
+ (syntax-rules (=> else)
+ ((_ "maybe-more" test consequent)
+ (if test consequent))
+
+ ((_ "maybe-more" test consequent clause ...)
+ (if test consequent (cond clause ...)))
+
+ ((_ (else else1 else2 ...))
+ (begin else1 else2 ...))
+
+ ((_ (test => receiver) more-clause ...)
+ (let ((t test))
+ (cond "maybe-more" t (receiver t) more-clause ...)))
+
+ ((_ (generator guard => receiver) more-clause ...)
+ (call-with-values (lambda () generator)
+ (lambda t
+ (cond "maybe-more"
+ (apply guard t) (apply receiver t) more-clause ...))))
+
+ ((_ (test => receiver ...) more-clause ...)
+ (syntax-violation 'cond "wrong number of receiver expressions"
+ '(test => receiver ...)))
+ ((_ (generator guard => receiver ...) more-clause ...)
+ (syntax-violation 'cond "wrong number of receiver expressions"
+ '(generator guard => receiver ...)))
+
+ ((_ (test) more-clause ...)
+ (let ((t test))
+ (cond "maybe-more" t t more-clause ...)))
+
+ ((_ (test body1 body2 ...) more-clause ...)
+ (cond "maybe-more"
+ test (begin body1 body2 ...) more-clause ...))))
+
+(define-syntax case
+ (syntax-rules (else)
+ ((case (key ...)
+ clauses ...)
+ (let ((atom-key (key ...)))
+ (case atom-key clauses ...)))
+ ((case key
+ (else result1 result2 ...))
+ (begin result1 result2 ...))
+ ((case key
+ ((atoms ...) result1 result2 ...))
+ (if (memv key '(atoms ...))
+ (begin result1 result2 ...)))
+ ((case key
+ ((atoms ...) result1 result2 ...)
+ clause clauses ...)
+ (if (memv key '(atoms ...))
+ (begin result1 result2 ...)
+ (case key clause clauses ...)))))
+
+(define-syntax do
+ (syntax-rules ()
+ ((do ((var init step ...) ...)
+ (test expr ...)
+ command ...)
+ (letrec
+ ((loop
+ (lambda (var ...)
+ (if test
+ (begin
+ (if #f #f)
+ expr ...)
+ (begin
+ command
+ ...
+ (loop (do "step" var step ...)
+ ...))))))
+ (loop init ...)))
+ ((do "step" x)
+ x)
+ ((do "step" x y)
+ y)))
+
+(define-syntax delay
+ (syntax-rules ()
+ ((_ exp) (make-promise (lambda () exp)))))
+
+(include-from-path "ice-9/quasisyntax")
+
+;;; @bind is used by the old elisp code as a dynamic scoping mechanism.
+;;; Please let the Guile developers know if you are using this macro.
+;;;
+(define-syntax @bind
+ (lambda (x)
+ (define (bound-member id ids)
+ (cond ((null? ids) #f)
+ ((bound-identifier=? id (car ids)) #t)
+ ((bound-member (car ids) (cdr ids)))))
+
+ (syntax-case x ()
+ ((_ () b0 b1 ...)
+ #'(let () b0 b1 ...))
+ ((_ ((id val) ...) b0 b1 ...)
+ (and-map identifier? #'(id ...))
+ (if (let lp ((ids #'(id ...)))
+ (cond ((null? ids) #f)
+ ((bound-member (car ids) (cdr ids)) #t)
+ (else (lp (cdr ids)))))
+ (syntax-violation '@bind "duplicate bound identifier" x)
+ (with-syntax (((old-v ...) (generate-temporaries #'(id ...)))
+ ((v ...) (generate-temporaries #'(id ...))))
+ #'(let ((old-v id) ...
+ (v val) ...)
+ (dynamic-wind
+ (lambda ()
+ (set! id v) ...)
+ (lambda () b0 b1 ...)
+ (lambda ()
+ (set! id old-v) ...)))))))))
+
+
\f
;;; {Defmacros}
;;;
-;;; Depends on: features, eval-case
-;;;
(define-syntax define-macro
(lambda (x)
"Define a defmacro."
(syntax-case x ()
((_ (macro . args) doc body1 body ...)
- (string? (syntax-object->datum (syntax doc)))
+ (string? (syntax->datum (syntax doc)))
(syntax (define-macro macro doc (lambda args body1 body ...))))
((_ (macro . args) body ...)
(syntax (define-macro macro #f (lambda args body ...))))
((_ macro doc transformer)
- (or (string? (syntax-object->datum (syntax doc)))
- (not (syntax-object->datum (syntax doc))))
+ (or (string? (syntax->datum (syntax doc)))
+ (not (syntax->datum (syntax doc))))
(syntax
(define-syntax macro
(lambda (y)
doc
(syntax-case y ()
((_ . args)
- (let ((v (syntax-object->datum (syntax args))))
- (datum->syntax-object y (apply transformer v))))))))))))
+ (let ((v (syntax->datum (syntax args))))
+ (datum->syntax y (apply transformer v))))))))))))
(define-syntax defmacro
(lambda (x)
"Define a defmacro, with the old lispy defun syntax."
(syntax-case x ()
((_ macro args doc body1 body ...)
- (string? (syntax-object->datum (syntax doc)))
+ (string? (syntax->datum (syntax doc)))
(syntax (define-macro macro doc (lambda args body1 body ...))))
((_ macro args body ...)
(syntax (define-macro macro #f (lambda args body ...)))))))
(define (apply-to-args args fn) (apply fn args))
(defmacro false-if-exception (expr)
- `(catch #t (lambda () ,expr)
- (lambda args #f)))
+ `(catch #t
+ (lambda ()
+ ;; avoid saving backtraces inside false-if-exception
+ (with-fluid* the-last-stack (fluid-ref the-last-stack)
+ (lambda () ,expr)))
+ (lambda args #f)))
\f
\f
-;;; {and-map and or-map}
-;;;
-;;; (and-map fn lst) is like (and (fn (car lst)) (fn (cadr lst)) (fn...) ...)
-;;; (or-map fn lst) is like (or (fn (car lst)) (fn (cadr lst)) (fn...) ...)
-;;;
-
-;; and-map f l
-;;
-;; Apply f to successive elements of l until exhaustion or f returns #f.
-;; If returning early, return #f. Otherwise, return the last value returned
-;; by f. If f has never been called because l is empty, return #t.
-;;
-(define (and-map f lst)
- (let loop ((result #t)
- (l lst))
- (and result
- (or (and (null? l)
- result)
- (loop (f (car l)) (cdr l))))))
-
-;; or-map f l
-;;
-;; Apply f to successive elements of l until exhaustion or while f returns #f.
-;; If returning early, return the return value of f.
-;;
-(define (or-map f lst)
- (let loop ((result #f)
- (l lst))
- (or result
- (and (not (null? l))
- (loop (f (car l)) (cdr l))))))
-
-\f
-
(if (provided? 'posix)
(primitive-load-path "ice-9/posix"))
(primitive-load-path "ice-9/networking"))
;; For reference, Emacs file-exists-p uses stat in this same way.
-;; ENHANCE-ME: Catching an exception from stat is a bit wasteful, do this in
-;; C where all that's needed is to inspect the return from stat().
(define file-exists?
(if (provided? 'posix)
(lambda (str)
- (->bool (false-if-exception (stat str))))
+ (->bool (stat str #f)))
(lambda (str)
(let ((port (catch 'system-error (lambda () (open-file str OPEN_READ))
(lambda args #f))))
(set! %load-hook %load-announce)
(define (load name . reader)
+ ;; Returns the .go file corresponding to `name'. Does not search load
+ ;; paths, only the fallback path. If the .go file is missing or out of
+ ;; date, and autocompilation is enabled, will try autocompilation, just
+ ;; as primitive-load-path does internally. primitive-load is
+ ;; unaffected. Returns #f if autocompilation failed or was disabled.
+ (define (autocompiled-file-name name)
+ (catch #t
+ (lambda ()
+ (let* ((cfn ((@ (system base compile) compiled-file-name) name))
+ (scmstat (stat name))
+ (gostat (stat cfn #f)))
+ (if (and gostat (= (stat:mtime gostat) (stat:mtime scmstat)))
+ cfn
+ (begin
+ (if gostat
+ (format (current-error-port)
+ ";;; note: source file ~a\n;;; newer than compiled ~a\n"
+ name cfn))
+ (cond
+ (%load-should-autocompile
+ (%warn-autocompilation-enabled)
+ (format (current-error-port) ";;; compiling ~a\n" name)
+ (let ((cfn ((@ (system base compile) compile-file) name
+ #:env (current-module))))
+ (format (current-error-port) ";;; compiled ~a\n" cfn)
+ cfn))
+ (else #f))))))
+ (lambda (k . args)
+ (format (current-error-port)
+ ";;; WARNING: compilation of ~a failed:\n;;; key ~a, throw_args ~s\n"
+ name k args)
+ #f)))
(with-fluid* current-reader (and (pair? reader) (car reader))
(lambda ()
- (start-stack 'load-stack
- (primitive-load name)))))
+ (let ((cfn (autocompiled-file-name name)))
+ (if cfn
+ (load-compiled cfn)
+ (start-stack 'load-stack
+ (primitive-load name)))))))
\f
;;; See the file `COPYING' for terms applying to this program.
;;;
-(define expt
- (let ((integer-expt integer-expt))
- (lambda (z1 z2)
- (cond ((and (exact? z2) (integer? z2))
- (integer-expt z1 z2))
- ((and (real? z2) (real? z1) (>= z1 0))
- ($expt z1 z2))
- (else
- (exp (* z2 (log z1))))))))
-
(define (sinh z)
(if (real? z) ($sinh z)
(let ((x (real-part z)) (y (imag-part z)))
;;; Reader code for various "#c" forms.
;;;
-(read-hash-extend #\' (lambda (c port)
- (read port)))
-
(define read-eval? (make-fluid))
(fluid-set! read-eval? #f)
(read-hash-extend #\.
(define (%print-module mod port) ; unused args: depth length style table)
(display "#<" port)
(display (or (module-kind mod) "module") port)
- (let ((name (module-name mod)))
- (if name
- (begin
- (display " " port)
- (display name port))))
+ (display " " port)
+ (display (module-name mod) port)
(display " " port)
(display (number->string (object-address mod) 16) port)
(display ">" port))
;; NOTE: This binding is used in libguile/modules.c.
(define module-eval-closure (record-accessor module-type 'eval-closure))
-(define module-transformer (record-accessor module-type 'transformer))
+;; (define module-transformer (record-accessor module-type 'transformer))
(define set-module-transformer! (record-modifier module-type 'transformer))
;; (define module-name (record-accessor module-type 'name)) wait until mods are booted
(define set-module-name! (record-modifier module-type 'name))
;; Make it possible to lookup the module from the environment.
;; This implementation is correct since an eval closure can belong
;; to maximally one module.
- (set-procedure-property! closure 'module module))))
+
+ ;; XXX: The following line introduces a circular reference that
+ ;; precludes garbage collection of modules with the current weak hash
+ ;; table semantics (see
+ ;; http://lists.gnu.org/archive/html/guile-devel/2009-01/msg00102.html and
+ ;; http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/2465
+ ;; for details). Since it doesn't appear to be used (only in
+ ;; `scm_lookup_closure_module ()', which has 1 caller), we just comment
+ ;; it out.
+
+ ;(set-procedure-property! closure 'module module)
+ )))
\f
val
(let ((m (make-module 31)))
(set-module-kind! m 'directory)
- (set-module-name! m (append (or (module-name module) '())
+ (set-module-name! m (append (module-name module)
(list (car name))))
(module-define! module (car name) m)
m)))
;; Import the default set of bindings (from the SCM module) in MODULE.
(module-use! module the-scm-module)))
+(define (make-fresh-user-module)
+ (let ((m (make-module)))
+ (beautify-user-module! m)
+ m))
+
;; NOTE: This binding is used in libguile/modules.c.
;;
(define resolve-module
(define default-duplicate-binding-procedures #f)
(define %app (make-module 31))
+(set-module-name! %app '(%app))
(define app %app) ;; for backwards compatability
-(local-define '(%app modules) (make-module 31))
+(let ((m (make-module 31)))
+ (set-module-name! m '())
+ (local-define '(%app modules) m))
(local-define '(%app modules guile) the-root-module)
;; This boots the module system. All bindings needed by modules.c
;; must have been defined by now.
;;
(set-current-module the-root-module)
-;; definition deferred for syncase's benefit
-(define module-name (record-accessor module-type 'name))
+;; definition deferred for syncase's benefit.
+(define module-name
+ (let ((accessor (record-accessor module-type 'name)))
+ (lambda (mod)
+ (or (accessor mod)
+ (let ((name (list (gensym))))
+ ;; Name MOD and bind it in THE-ROOT-MODULE so that it's visible
+ ;; to `resolve-module'. This is important as `psyntax' stores
+ ;; module names and relies on being able to `resolve-module'
+ ;; them.
+ (set-module-name! mod name)
+ (nested-define! the-root-module `(%app modules ,@name) mod)
+ (accessor mod))))))
;; (define-special-value '(%app modules new-ws) (lambda () (make-scm-module)))
(resolve-module dir-hint-module-name #f)
(and (not (autoload-done-or-in-progress? dir-hint name))
(let ((didit #f))
- (define (load-file proc file)
- (save-module-excursion (lambda () (proc file)))
- (set! didit #t))
(dynamic-wind
(lambda () (autoload-in-progress! dir-hint name))
(lambda ()
- (let ((file (in-vicinity dir-hint name)))
- (let ((compiled (and load-compiled
- (%search-load-path
- (string-append file ".go"))))
- (source (%search-load-path file)))
- (cond ((and source
- (or (not compiled)
- (< (stat:mtime (stat compiled))
- (stat:mtime (stat source)))))
- (if compiled
- (warn "source file" source "newer than" compiled))
- (with-fluid* current-reader #f
- (lambda () (load-file primitive-load source))))
- (compiled
- (load-file load-compiled compiled))))))
+ (with-fluid* current-reader #f
+ (lambda ()
+ (save-module-excursion
+ (lambda ()
+ (primitive-load-path (in-vicinity dir-hint name) #f)
+ (set! didit #t))))))
(lambda () (set-autoloaded! dir-hint name didit)))
didit))))
;;;
(defmacro define-option-interface (option-group)
- (let* ((option-name car)
- (option-value cadr)
- (option-documentation caddr)
+ (let* ((option-name 'car)
+ (option-value 'cadr)
+ (option-documentation 'caddr)
;; Below follow the macros defining the run-time option interfaces.
(,interface (car args)) (,interface))
(else (for-each
(lambda (option)
- (display (option-name option))
+ (display (,option-name option))
(if (< (string-length
- (symbol->string (option-name option)))
+ (symbol->string (,option-name option)))
8)
(display #\tab))
(display #\tab)
- (display (option-value option))
+ (display (,option-value option))
(display #\tab)
- (display (option-documentation option))
+ (display (,option-documentation option))
(newline))
(,interface #t)))))))
(define (set-repl-prompt! v) (set! scm-repl-prompt v))
(define (default-pre-unwind-handler key . args)
- (save-stack pre-unwind-handler-dispatch)
+ (save-stack 1)
(apply throw key args))
-(define (pre-unwind-handler-dispatch key . args)
- (apply default-pre-unwind-handler key args))
+(begin-deprecated
+ (define (pre-unwind-handler-dispatch key . args)
+ (apply default-pre-unwind-handler key args)))
(define abort-hook (make-hook))
(else
(apply bad-throw key args)))))))
- ;; Note that having just `pre-unwind-handler-dispatch'
- ;; here is connected with the mechanism that
- ;; produces a nice backtrace upon error. If, for
- ;; example, this is replaced with (lambda args
- ;; (apply pre-unwind-handler-dispatch args)), the stack
- ;; cutting (in save-stack) goes wrong and ends up
- ;; saving no stack at all, so there is no
- ;; backtrace.
- pre-unwind-handler-dispatch)))
+ default-pre-unwind-handler)))
(if next (loop next) status)))
(set! set-batch-mode?! (lambda (arg)
(apply make-stack #t save-stack primitive-eval #t 0 narrowing))
((load-stack)
(apply make-stack #t save-stack 0 #t 0 narrowing))
- ((tk-stack)
- (apply make-stack #t save-stack tk-stack-mark #t 0 narrowing))
((#t)
(apply make-stack #t save-stack 0 1 narrowing))
(else
;;; The default repl-reader function. We may override this if we've
;;; the readline library.
(define repl-reader
- (lambda (prompt)
+ (lambda (prompt . reader)
(display (if (string? prompt) prompt (prompt)))
(force-output)
(run-hook before-read-hook)
- ((or (fluid-ref current-reader) read) (current-input-port))))
+ ((or (and (pair? reader) (car reader))
+ (fluid-ref current-reader)
+ read)
+ (current-input-port))))
(define (scm-style-repl)
(display ";;; QUIT executed, repl exitting")
(newline)
(repl-report)))
- args))
-
- (-abort (lambda ()
- (if scm-repl-verbose
- (begin
- (display ";;; ABORT executed.")
- (newline)
- (repl-report)))
- (repl -read -eval -print))))
+ args)))
(let ((status (error-catching-repl -read
-eval
(process-use-modules (list (list ,@(compile-interface-spec spec))))
*unspecified*))
-;; Dirk:FIXME:: This incorrect (according to R5RS) syntax needs to be changed
-;; as soon as guile supports hygienic macros.
(define-syntax define-private
(syntax-rules ()
((_ foo bar)
(defmacro name args . body)
(export-syntax name)))))
+;; And now for the most important macro.
+(define-syntax λ
+ (syntax-rules ()
+ ((_ formals body ...)
+ (lambda formals body ...))))
+
+\f
;; Export a local variable
;; This function is called from "modules.c". If you change it, be
\f
-;;; {Compiler interface}
-;;;
-;;; The full compiler interface can be found in (system). Here we put a
-;;; few useful procedures into the global namespace.
-
-(module-autoload! the-scm-module
- '(system base compile)
- '(compile
- compile-time-environment))
-
-
-\f
-
;;; {Parameters}
;;;
(define %cond-expand-features
;; Adjust the above comment when changing this.
'(guile
+ guile-2
r5rs
srfi-0 ;; cond-expand itself
srfi-4 ;; homogenous numeric vectors
(append (hashq-ref %cond-expand-table mod '())
features)))))
-(define cond-expand
- (procedure->memoizing-macro
- (lambda (exp env)
- (let ((clauses (cdr exp))
- (syntax-error (lambda (cl)
- (error "invalid clause in `cond-expand'" cl))))
- (letrec
- ((test-clause
- (lambda (clause)
- (cond
- ((symbol? clause)
- (or (memq clause %cond-expand-features)
- (let lp ((uses (module-uses (env-module env))))
- (if (pair? uses)
- (or (memq clause
- (hashq-ref %cond-expand-table
- (car uses) '()))
- (lp (cdr uses)))
- #f))))
- ((pair? clause)
- (cond
- ((eq? 'and (car clause))
- (let lp ((l (cdr clause)))
- (cond ((null? l)
- #t)
- ((pair? l)
- (and (test-clause (car l)) (lp (cdr l))))
- (else
- (syntax-error clause)))))
- ((eq? 'or (car clause))
- (let lp ((l (cdr clause)))
- (cond ((null? l)
- #f)
- ((pair? l)
- (or (test-clause (car l)) (lp (cdr l))))
- (else
- (syntax-error clause)))))
- ((eq? 'not (car clause))
- (cond ((not (pair? (cdr clause)))
- (syntax-error clause))
- ((pair? (cddr clause))
- ((syntax-error clause))))
- (not (test-clause (cadr clause))))
- (else
- (syntax-error clause))))
- (else
- (syntax-error clause))))))
- (let lp ((c clauses))
- (cond
- ((null? c)
- (error "Unfulfilled `cond-expand'"))
- ((not (pair? c))
- (syntax-error c))
- ((not (pair? (car c)))
- (syntax-error (car c)))
- ((test-clause (caar c))
- `(begin ,@(cdar c)))
- ((eq? (caar c) 'else)
- (if (pair? (cdr c))
- (syntax-error c))
- `(begin ,@(cdar c)))
- (else
- (lp (cdr c))))))))))
+(define-macro (cond-expand . clauses)
+ (let ((syntax-error (lambda (cl)
+ (error "invalid clause in `cond-expand'" cl))))
+ (letrec
+ ((test-clause
+ (lambda (clause)
+ (cond
+ ((symbol? clause)
+ (or (memq clause %cond-expand-features)
+ (let lp ((uses (module-uses (current-module))))
+ (if (pair? uses)
+ (or (memq clause
+ (hashq-ref %cond-expand-table
+ (car uses) '()))
+ (lp (cdr uses)))
+ #f))))
+ ((pair? clause)
+ (cond
+ ((eq? 'and (car clause))
+ (let lp ((l (cdr clause)))
+ (cond ((null? l)
+ #t)
+ ((pair? l)
+ (and (test-clause (car l)) (lp (cdr l))))
+ (else
+ (syntax-error clause)))))
+ ((eq? 'or (car clause))
+ (let lp ((l (cdr clause)))
+ (cond ((null? l)
+ #f)
+ ((pair? l)
+ (or (test-clause (car l)) (lp (cdr l))))
+ (else
+ (syntax-error clause)))))
+ ((eq? 'not (car clause))
+ (cond ((not (pair? (cdr clause)))
+ (syntax-error clause))
+ ((pair? (cddr clause))
+ ((syntax-error clause))))
+ (not (test-clause (cadr clause))))
+ (else
+ (syntax-error clause))))
+ (else
+ (syntax-error clause))))))
+ (let lp ((c clauses))
+ (cond
+ ((null? c)
+ (error "Unfulfilled `cond-expand'"))
+ ((not (pair? c))
+ (syntax-error c))
+ ((not (pair? (car c)))
+ (syntax-error (car c)))
+ ((test-clause (caar c))
+ `(begin ,@(cdar c)))
+ ((eq? (caar c) 'else)
+ (if (pair? (cdr c))
+ (syntax-error c))
+ `(begin ,@(cdar c)))
+ (else
+ (lp (cdr c))))))))
;; This procedure gets called from the startup code with a list of
;; numbers, which are the numbers of the SRFIs to be loaded on startup.
;; (module-eval-closure (current-module))))
;; (deannotate/source-properties (sc-expand (annotate exp)))))
-(define-module (guile-user))
+(define-module (guile-user)
+ #:autoload (system base compile) (compile))
;;; boot-9.scm ends here
HCoop / bpt / guile.git / blobdiff