/usr/share/r6rs/nanopass/implementation-helpers.ikarus.ss 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 | ;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell
;;; See the accompanying file Copyright for details
(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
#;define-property make-compile-time-value
;; code organization helpers
module
;; useful for warning and error 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 (rnrs) (rnrs eval) (ikarus))
(define-syntax with-implicit
(syntax-rules ()
[(_ (id name ...) body bodies ...)
(with-syntax ([name (datum->syntax #'id 'name)] ...) body bodies ...)]))
; 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})
(define-syntax eq-hashtable-set! (identifier-syntax hashtable-set!))
(define-syntax eq-hashtable-ref (identifier-syntax hashtable-ref))
(define list-head
(lambda (orig-ls orig-n)
(let f ([ls orig-ls] [n orig-n])
(cond
[(fxzero? n) '()]
[(null? ls) (error 'list-head "index out of range" orig-ls orig-n)]
[else (cons (car ls) (f (cdr ls) (fx- n 1)))]))))
(define iota
(lambda (n)
(let loop ([n n] [ls '()])
(if (fxzero? n)
ls
(let ([n (- n 1)])
(loop n (cons n ls)))))))
(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 provide-full-source-information
(make-parameter #f (lambda (x) (and x #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 ([as (annotation-source a)])
(let ([fn (car as)] [cp (cdr as)])
(if (provide-full-source-information)
(call-with-input-file fn
(lambda (ip)
(let loop ([n cp] [line 1] [col 0])
(if (= n 0)
(new fn (port-position ip) cp #f #f line col type)
(let ([c (read-char ip)])
(if (char=? c #\newline)
(loop (- n 1) (fx+ line 1) 0)
(loop (- n 1) line (fx+ col 1))))))))
(new fn #f cp #f #f #f #f type))))))))
(define syntax->annotation
(lambda (x)
(and (struct? x) ;; syntax objects are structs
(string=? (struct-name x) "stx") ;; with the name syntax
(let ([e (struct-ref x 0)]) ;; the 0th element is potentially an annotation
(and (annotation? e) e))))) ;; if it is an annotation return it
(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 errorf
(syntax-rules ()
[(_ who fmt args ...) (error who (format fmt args ...))]))
(define-syntax warningf
(syntax-rules ()
[(_ who fmt args ...) (warning who (format fmt args ...))]))
(define-syntax indirect-export
(syntax-rules ()
[(_ id indirect-id ...) (define t (if #f #f))]))
(define-syntax with-compile-time-environment
(syntax-rules ()
[(_ (arg) body* ... body) (lambda (arg) body* ... body)])))
|