/usr/share/r6rs/nanopass/implementation-helpers.chezscheme.sls is in r6rs-nanopass-dev 1.9+git20160429.g1f7e80b-1build1.
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 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 | ;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
#!chezscheme
(library (nanopass implementation-helpers)
(export
;; formatting
format printf pretty-print
;; listy stuff
iota make-list list-head
;; gensym stuff (related to nongenerative languages)
gensym regensym
;; source-information stuff
syntax->source-information
source-information-source-file
source-information-byte-offset-start
source-information-char-offset-start
source-information-byte-offset-end
source-information-char-offset-end
source-information-position-line
source-information-position-column
source-information-type
provide-full-source-information
;; library export stuff (needed for when used inside module to
;; auto-indirect export things)
indirect-export
;; compile-time environment helpers
make-compile-time-value
;; code organization helpers
module
;; useful for warning items
warningf errorf
;; used to get the best performance from hashtables
eq-hashtable-set! eq-hashtable-ref
;; debugging support
trace-lambda trace-define-syntax trace-let trace-define
;; needed to know what code to generate
optimize-level
;; the base record, so that we can use gensym syntax
define-nanopass-record
;; failure token so that we can know when parsing fails with a gensym
np-parse-fail-token
;; handy syntactic stuff
with-implicit
;; abstraction of the grabbing the syntactic environment that will work in
;; Chez, Ikarus, & Vicare
with-compile-time-environment
;; apparently not neeaded (or no longer needed)
; scheme-version= scheme-version< scheme-version> scheme-version>=
; scheme-version<= with-scheme-version gensym? errorf with-output-to-string
; with-input-from-string
)
(import (chezscheme))
; the base language
(define-syntax define-nanopass-record
(lambda (x)
(syntax-case x ()
[(k) (with-implicit (k nanopass-record nanopass-record? nanopass-record-tag)
#'(define-record-type (nanopass-record make-nanopass-record nanopass-record?)
(nongenerative #{nanopass-record d47f8omgluol6otrw1yvu5-0})
(fields (immutable tag nanopass-record-tag))))])))
;; another gensym listed into this library
(define np-parse-fail-token '#{np-parse-fail-token dlkcd4b37swscag1dvmuiz-13})
;; the following should get moved into Chez Scheme proper (and generally
;; cleaned up with appropriate new Chez Scheme primitives for support)
(define regensym
(case-lambda
[(gs extra)
(unless (gensym? gs) (errorf 'regensym "~s is not a gensym" gs))
(unless (string? extra) (errorf 'regensym "~s is not a string" extra))
(let ([pretty-name (parameterize ([print-gensym #f]) (format "~s" gs))]
[unique-name (gensym->unique-string gs)])
(with-input-from-string (format "#{~a ~a~a}" pretty-name unique-name extra) read))]
[(gs extra0 extra1)
(unless (gensym? gs) (errorf 'regensym "~s is not a gensym" gs))
(unless (string? extra0) (errorf 'regensym "~s is not a string" extra0))
(unless (string? extra1) (errorf 'regensym "~s is not a string" extra1))
(with-output-to-string (lambda () (format "~s" gs)))
(let ([pretty-name (parameterize ([print-gensym #f]) (format "~s" gs))]
[unique-name (gensym->unique-string gs)])
(with-input-from-string (format "#{~a~a ~a~a}" pretty-name extra0 unique-name extra1) read))]))
(define-syntax define-scheme-version-relop
(lambda (x)
(syntax-case x ()
[(_ name relop strict-inequality?)
#`(define name
(lambda (ls)
(let-values ([(a1 b1 c1) (scheme-version-number)]
[(a2 b2 c2)
(cond
[(fx= (length ls) 1) (values (car ls) 0 0)]
[(fx= (length ls) 2) (values (car ls) (cadr ls) 0)]
[(fx= (length ls) 3) (values (car ls) (cadr ls) (caddr ls))])])
#,(if (datum strict-inequality?)
#'(or (relop a1 a2)
(and (fx= a1 a2)
(or (relop b1 b2)
(and (fx= b1 b2)
(relop c1 c2)))))
#'(and (relop a1 a2) (relop b1 b2) (relop c1 c2))))))])))
(define-scheme-version-relop scheme-version= fx= #f)
(define-scheme-version-relop scheme-version< fx< #t)
(define-scheme-version-relop scheme-version> fx> #t)
(define-scheme-version-relop scheme-version<= fx<= #f)
(define-scheme-version-relop scheme-version>= fx>= #f)
(define-syntax with-scheme-version
(lambda (x)
(define-scheme-version-relop scheme-version= fx= #f)
(define-scheme-version-relop scheme-version< fx< #t)
(define-scheme-version-relop scheme-version> fx> #t)
(define-scheme-version-relop scheme-version<= fx<= #f)
(define-scheme-version-relop scheme-version>= fx>= #f)
(define finish
(lambda (pat* e** elsee*)
(if (null? pat*)
#`(begin #,@elsee*)
(or (and (syntax-case (car pat*) (< <= = >= >)
[(< v ...) (scheme-version< (datum (v ...)))]
[(<= v ...) (scheme-version<= (datum (v ...)))]
[(= v ...) (scheme-version= (datum (v ...)))]
[(>= v ...) (scheme-version>= (datum (v ...)))]
[(> v ...) (scheme-version> (datum (v ...)))]
[else #f])
#`(begin #,@(car e**)))
(finish (cdr pat*) (cdr e**) elsee*)))))
(syntax-case x (else)
[(_ [pat e1 e2 ...] ... [else ee1 ee2 ...])
(finish #'(pat ...) #'((e1 e2 ...) ...) #'(ee1 ee2 ...))]
[(_ [pat e1 e2 ...] ...)
(finish #'(pat ...) #'((e1 e2 ...) ...) #'())])))
(define provide-full-source-information
(make-parameter #f (lambda (n) (and n #t))))
(define-record-type source-information
(nongenerative)
(sealed #t)
(fields source-file byte-offset-start char-offset-start byte-offset-end
char-offset-end position-line position-column type)
(protocol
(lambda (new)
(lambda (a type)
(let ([so (annotation-source a)])
(let ([sfd (source-object-sfd so)]
[bfp (source-object-bfp so)]
[efp (source-object-efp so)])
(if (provide-full-source-information)
(let ([ip (open-source-file sfd)])
(let loop ([n bfp] [line 1] [col 1])
(if (= n 0)
(let ([byte-offset-start (port-position ip)])
(let loop ([n (- efp bfp)])
(if (= n 0)
(let ([byte-offset-end (port-position ip)])
(close-input-port ip)
(new (source-file-descriptor-path sfd)
byte-offset-start bfp
byte-offset-end efp
line col type))
(let ([c (read-char ip)]) (loop (- n 1))))))
(let ([c (read-char ip)])
(if (char=? c #\newline)
(loop (- n 1) (fx+ line 1) 1)
(loop (- n 1) line (fx+ col 1)))))))
(new (source-file-descriptor-path sfd)
#f bfp #f efp #f #f type))))))))
(define syntax->source-information
(lambda (stx)
(let loop ([stx stx] [type 'at])
(cond
[(syntax->annotation stx) =>
(lambda (a) (make-source-information a type))]
[(pair? stx) (or (loop (car stx) 'near) (loop (cdr stx) 'near))]
[else #f]))))
(define-syntax with-compile-time-environment
(syntax-rules ()
[(_ (arg) body* ... body) (lambda (arg) body* ... body)]))
(with-scheme-version
[(< 8 3 1)
(define syntax->annotation (lambda (x) #f))
(define annotation-source (lambda (x) (errorf 'annotation-source "unsupported before version 8.4")))
(define source-object-bfp (lambda (x) (errorf 'source-object-bfp "unsupported before version 8.4")))
(define source-object-sfd (lambda (x) (errorf 'source-object-sfd "unsupported before version 8.4")))
(define source-file-descriptor-path (lambda (x) (errorf 'source-file-descriptor-path "unsupported before version 8.4")))])
(with-scheme-version
[(< 8 1) (define-syntax indirect-export (syntax-rules () [(_ id indirect-id ...) (define t (if #f #f))]))]))
|