/usr/share/slib/scamacr.scm is in slib 3b1-5.
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 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 | ;;; "scamacr.scm" syntax-case macros for Scheme constructs
;;; Copyright (C) 1992 R. Kent Dybvig
;;;
;;; Permission to copy this software, in whole or in part, to use this
;;; software for any lawful purpose, and to redistribute this software
;;; is granted subject to the restriction that all copies made of this
;;; software must include this copyright notice in full. This software
;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
;;; OR FITNESS FOR ANY PARTICULAR PURPOSE. IN NO EVENT SHALL THE
;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
;;; NATURE WHATSOEVER.
;;; Written by Robert Hieb & Kent Dybvig
;;; This file was munged by a simple minded sed script since it left
;;; its original authors' hands. See syncase.sh for the horrid details.
;;; macro-defs.ss
;;; Robert Hieb & Kent Dybvig
;;; 92/06/18
(define-syntax with-syntax
(lambda (x)
(syntax-case x ()
((_ () e1 e2 ...)
(syntax (begin e1 e2 ...)))
((_ ((out in)) e1 e2 ...)
(syntax (syntax-case in () (out (begin e1 e2 ...)))))
((_ ((out in) ...) e1 e2 ...)
(syntax (syntax-case (list in ...) ()
((out ...) (begin e1 e2 ...))))))))
(define-syntax syntax-rules
(lambda (x)
(syntax-case x ()
((_ (k ...) ((keyword . pattern) template) ...)
(with-syntax (((dummy ...)
(generate-temporaries (syntax (keyword ...)))))
(syntax (lambda (x)
(syntax-case x (k ...)
((dummy . pattern) (syntax template))
...))))))))
(define-syntax or
(lambda (x)
(syntax-case x ()
((_) (syntax #f))
((_ e) (syntax e))
((_ e1 e2 e3 ...)
(syntax (let ((t e1)) (if t t (or e2 e3 ...))))))))
(define-syntax and
(lambda (x)
(syntax-case x ()
((_ e1 e2 e3 ...) (syntax (if e1 (and e2 e3 ...) #f)))
((_ e) (syntax e))
((_) (syntax #t)))))
(define-syntax cond
(lambda (x)
(syntax-case x (else =>)
((_ (else e1 e2 ...))
(syntax (begin e1 e2 ...)))
((_ (e0))
(syntax (let ((t e0)) (if t t))))
((_ (e0) c1 c2 ...)
(syntax (let ((t e0)) (if t t (cond c1 c2 ...)))))
((_ (e0 => e1)) (syntax (let ((t e0)) (if t (e1 t)))))
((_ (e0 => e1) c1 c2 ...)
(syntax (let ((t e0)) (if t (e1 t) (cond c1 c2 ...)))))
((_ (e0 e1 e2 ...)) (syntax (if e0 (begin e1 e2 ...))))
((_ (e0 e1 e2 ...) c1 c2 ...)
(syntax (if e0 (begin e1 e2 ...) (cond c1 c2 ...)))))))
(define-syntax let*
(lambda (x)
(syntax-case x ()
((let* () e1 e2 ...)
(syntax (let () e1 e2 ...)))
((let* ((x1 v1) (x2 v2) ...) e1 e2 ...)
(syncase:andmap identifier? (syntax (x1 x2 ...)))
(syntax (let ((x1 v1)) (let* ((x2 v2) ...) e1 e2 ...)))))))
(define-syntax case
(lambda (x)
(syntax-case x (else)
((_ v (else e1 e2 ...))
(syntax (begin v e1 e2 ...)))
((_ v ((k ...) e1 e2 ...))
(syntax (if (memv v '(k ...)) (begin e1 e2 ...))))
((_ v ((k ...) e1 e2 ...) c1 c2 ...)
(syntax (let ((x v))
(if (memv x '(k ...))
(begin e1 e2 ...)
(case x c1 c2 ...))))))))
(define-syntax do
(lambda (orig-x)
(syntax-case orig-x ()
((_ ((var init . step) ...) (e0 e1 ...) c ...)
(with-syntax (((step ...)
(map (lambda (v s)
(syntax-case s ()
(() v)
((e) (syntax e))
(_ (syntax-error orig-x))))
(syntax (var ...))
(syntax (step ...)))))
(syntax-case (syntax (e1 ...)) ()
(() (syntax (let doloop ((var init) ...)
(if (not e0)
(begin c ... (doloop step ...))))))
((e1 e2 ...)
(syntax (let doloop ((var init) ...)
(if e0
(begin e1 e2 ...)
(begin c ... (doloop step ...))))))))))))
(define-syntax quasiquote
(letrec
((gen-cons
(lambda (x y)
(syntax-case x (quote)
((quote x)
(syntax-case y (quote list)
((quote y) (syntax (quote (x . y))))
((list y ...) (syntax (list (quote x) y ...)))
(y (syntax (cons (quote x) y)))))
(x (syntax-case y (quote list)
((quote ()) (syntax (list x)))
((list y ...) (syntax (list x y ...)))
(y (syntax (cons x y))))))))
(gen-append
(lambda (x y)
(syntax-case x (quote list cons)
((quote (x1 x2 ...))
(syntax-case y (quote)
((quote y) (syntax (quote (x1 x2 ... . y))))
(y (syntax (append (quote (x1 x2 ...) y))))))
((quote ()) y)
((list x1 x2 ...)
(gen-cons (syntax x1) (gen-append (syntax (list x2 ...)) y)))
(x (syntax-case y (quote list)
((quote ()) (syntax x))
(y (syntax (append x y))))))))
(gen-vector
(lambda (x)
(syntax-case x (quote list)
((quote (x ...)) (syntax (quote #(x ...))))
((list x ...) (syntax (vector x ...)))
(x (syntax (list->vector x))))))
(gen
(lambda (p lev)
(syntax-case p (unquote unquote-splicing quasiquote)
((unquote p)
(if (= lev 0)
(syntax p)
(gen-cons (syntax (quote unquote))
(gen (syntax (p)) (- lev 1)))))
(((unquote-splicing p) . q)
(if (= lev 0)
(gen-append (syntax p) (gen (syntax q) lev))
(gen-cons (gen-cons (syntax (quote unquote-splicing))
(gen (syntax p) (- lev 1)))
(gen (syntax q) lev))))
((quasiquote p)
(gen-cons (syntax (quote quasiquote))
(gen (syntax (p)) (+ lev 1))))
((p . q)
(gen-cons (gen (syntax p) lev) (gen (syntax q) lev)))
(#(x ...) (gen-vector (gen (syntax (x ...)) lev)))
(p (syntax (quote p)))))))
(lambda (x)
(syntax-case x ()
((- e) (gen (syntax e) 0))))))
|