/usr/share/scheme48-1.9/big/vararg.scm is in scheme48 1.9-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 | ; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Mike Sperber
; Library functionality for writing procedures with variable number of arguments.
; This has the same interface as the OPT-LAMBDA in PLT Scheme's etc.ss
; library.
(define-syntax opt-lambda
(syntax-rules ()
((opt-lambda (?clause1 . ?clauses) ?body1 ?body ...)
(opt-lambda-aux-1 (?clause1 . ?clauses) () ?body1 ?body ...))
((opt-lambda ?id ?body1 ?body ...)
(lambda ?id ?body1 ?body ...))))
; process the initial vanilla parameters
(define-syntax opt-lambda-aux-1
(syntax-rules ()
((opt-lambda-aux-1 () (?arg ...) ?body ...)
(lambda (?arg ...) ?body ...))
((opt-lambda-aux-1 ((?id ?default) . ?rest) (?arg ...) ?body ...)
(opt-lambda-aux-2 ((?id ?default) . ?rest)
(?arg ... . rest) rest ()
?body ...))
((opt-lambda-aux-1 (?id . ?rest) (?arg ...) ?body ...)
(opt-lambda-aux-1 ?rest (?arg ... ?id) ?body ...))))
; this processes from the optionals on
(define-syntax opt-lambda-aux-2
(syntax-rules ()
((opt-lambda-aux-2 () ?args ?rest-param (?lclause ...) ?body ...)
(lambda ?args
(let* (?lclause ...)
?body ...)))
;; optimization
((opt-lambda-aux-2 ((?id ?default))
?args ?rest-param (?lclause ...) ?body ...)
(lambda ?args
(let* (?lclause
...
(?id (if (pair? ?rest-param)
(car ?rest-param)
?default)))
?body ...)))
((opt-lambda-aux-2 ((?id ?default) ?rest ...)
?args ?rest-param (?lclause ...) ?body ...)
(opt-lambda-aux-2 (?rest ...)
?args
new-rest
(?lclause ...
(?id (if (pair? ?rest-param)
(car ?rest-param)
?default))
(new-rest (if (pair? ?rest-param)
(cdr ?rest-param)
'())))
?body ...))
;; kludge for dealing with rest parameter
((opt-lambda-aux-2 ((?id ?default) . (?rest1 . ?rest))
?args ?rest-param (?lclause ...) ?body ...)
(opt-lambda-aux-2 (?rest1 . ?rest)
?args
new-rest
(?lclause ...
(?id (if (pair? ?rest-param)
(car ?rest-param)
?default))
(new-rest (if (pair? ?rest-param)
(cdr ?rest-param)
'())))
?body ...))
((opt-lambda-aux-2 ((?id ?default) . ?rest)
?args ?rest-param (?lclause ...) ?body ...)
(lambda ?args
(let* (?lclause
...
(?id (if (pair? ?rest-param)
(car ?rest-param)
?default))
(?rest (if (pair? ?rest-param)
(cdr ?rest-param)
'())))
?body ...)))))
|