/usr/share/gauche-0.9/0.9.4/lib/srfi-0.scm is in gauche 0.9.4-6.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 | ;;;
;;; SRFI-0 feature based conditional expansion construct
;;;
(define-module srfi-0
(export cond-expand))
(select-module srfi-0)
(define cond-features (with-module gauche.internal cond-features))
;;; Rewritten with a legacy macro, instead of r5rs syntax-rules,
;;; to enable adding features at runtime. Such capability is
;;; for system management, and not supposed to be used freely
;;; by user programs.
;; Note: If you modify this, try to avoid relying on other autoloaded
;; modules as much as possible; cond-expand can be used extensively, and
;; it's easy to introduce a circular dependency.
(define-macro (cond-expand . clauses)
;; Kludge - must be replaced once we have low-level hygienic macro.
(define use. ((with-module gauche.internal make-identifier)
'use (find-module 'gauche) '()))
(define begin. ((with-module gauche.internal make-identifier)
'begin (find-module 'gauche) '()))
;; Check feature requirement. Returns #f if requirement is not
;; satisfied. Returns a list of features to be use'd if requirement
;; is satisfied (it can be an emptylist, if the requirement is fulfilled
;; by Gauche built-in features).
(define (fulfill? req seed)
(cond
[(identifier? req) (fulfill? (identifier->symbol req) seed)]
[(symbol? req)
(let ((p (assq req (cond-features))))
(and p (if (null? (cdr p)) seed (cons (cadr p) seed))))]
[(not (pair? req)) (error "Invalid cond-expand feature-id:" req)]
[else
(case (unwrap-syntax (car req))
[(and) (fulfill-and (cdr req) seed)]
[(or) (fulfill-or (cdr req) seed)]
[(not) (fulfill-not (cadr req) seed)]
[(library) (fulfill-library (cdr req) seed)]
[else (error "Invalid cond-expand feature expression:" req)])]))
(define (fulfill-and reqs seed)
(if (null? reqs)
seed
(let ((c1 (fulfill? (car reqs) seed)))
(and c1 (fulfill-and (cdr reqs) c1)))))
(define (fulfill-or reqs seed)
(if (null? reqs)
#f
(let ((c1 (fulfill? (car reqs) seed)))
(or c1 (fulfill-or (cdr reqs) seed)))))
(define (fulfill-not req seed)
(if (fulfill? req '()) #f seed))
(define (fulfill-library rest seed)
(unless (null? (cdr rest))
(error "Invalid feature requirement:" `(library ,@rest)))
(let ((modname (library-name->module-name (car rest))))
(and (library-exists? modname) seed)))
(define (rec cls)
(cond
[(null? cls) (error "Unfulfilled cond-expand:" cls)]
[(not (pair? (car cls)))
(error "Bad clause in cond-expand:" (car cls))]
[(equal? (caar cls) 'else)
(if (null? (cdr cls))
`(,begin. . ,(cdar cls))
(error "Misplaced else clause in cond-expand:" (car cls)))]
[(fulfill? (caar cls) '())
=> (lambda (uses)
`(,begin. ,@(map (lambda (mod) `(,use. ,mod)) uses)
,@(cdar cls)))]
[else
(rec (cdr cls))]))
(rec clauses))
|