1;;; Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell 2;;; See the accompanying file Copyright for details 3 4(library (nanopass helpers) 5 (export 6 ;; auxiliary keywords for language/pass definitions 7 extends definitions entry terminals nongenerative-id maybe 8 9 ;; predicates for looking for identifiers independent of context 10 ellipsis? unquote? colon? arrow? plus? minus? double-arrow? 11 12 ;; things for dealing with syntax and idetnfieris 13 all-unique-identifiers? construct-id construct-unique-id gentemp 14 bound-id-member? bound-id-union partition-syn datum 15 16 ;; things for dealing with language meta-variables 17 meta-var->raw-meta-var combine unique-name 18 19 ;; convenience syntactic forms 20 rec with-values define-who 21 22 ;; source information funtions 23 syntax->source-info 24 25 ;;; stuff imported from implementation-helpers 26 27 ;; formatting 28 format printf pretty-print 29 30 ;; listy stuff 31 iota make-list list-head 32 33 ;; gensym stuff (related to nongenerative languages) 34 gensym regensym 35 36 ;; library export stuff (needed for when used inside module to 37 ;; auto-indirect export things) 38 indirect-export 39 40 ;; compile-time environment helpers 41 make-compile-time-value 42 43 ;; code organization helpers 44 module 45 46 ;; useful for warning items 47 warningf errorf 48 49 ;; used to get the best performance from hashtables 50 eq-hashtable-set! eq-hashtable-ref 51 52 ;; debugging support 53 trace-lambda trace-define-syntax trace-let trace-define 54 55 ;; needed to know what code to generate 56 optimize-level 57 58 ;; the base record, so that we can use gensym syntax 59 define-nanopass-record 60 61 ;; failure token so that we can know when parsing fails with a gensym 62 np-parse-fail-token 63 64 ;; handy syntactic stuff 65 with-implicit with-r6rs-quasiquote with-extended-quasiquote 66 extended-quasiquote with-auto-unquote 67 68 ;; abstraction of the grabbing the syntactic environment that will work in 69 ;; Chez, Ikarus, & Vicare 70 with-compile-time-environment) 71 (import (rnrs) (nanopass implementation-helpers)) 72 73 (define-syntax datum 74 (syntax-rules () 75 [(_ e) (syntax->datum #'e)])) 76 77 (define-syntax with-r6rs-quasiquote 78 (lambda (x) 79 (syntax-case x () 80 [(k . body) 81 (with-implicit (k quasiquote) 82 #'(let-syntax ([quasiquote (syntax-rules () [(_ x) `x])]) . body))]))) 83 84 (define-syntax extended-quasiquote 85 (lambda (x) 86 (define gather-unquoted-exprs 87 (lambda (body) 88 (let f ([body body] [t* '()] [e* '()]) 89 (syntax-case body (unquote unquote-splicing) 90 [(unquote x) 91 (identifier? #'x) 92 (values body (cons #'x t*) (cons #'x e*))] 93 [(unquote-splicing x) 94 (identifier? #'x) 95 (values body (cons #'x t*) (cons #'x e*))] 96 [(unquote e) 97 (with-syntax ([(t) (generate-temporaries '(t))]) 98 (values #'(unquote t) (cons #'t t*) (cons #'e e*)))] 99 [(unquote-splicing e) 100 (with-syntax ([(t) (generate-temporaries '(t))]) 101 (values #'(unquote-splicing t) (cons #'t t*) (cons #'e e*)))] 102 [(tmpl0 . tmpl1) 103 (let-values ([(tmpl0 t* e*) (f #'tmpl0 t* e*)]) 104 (let-values ([(tmpl1 t* e*) (f #'tmpl1 t* e*)]) 105 (values #`(#,tmpl0 . #,tmpl1) t* e*)))] 106 [atom (values #'atom t* e*)])))) 107 (define build-list 108 (lambda (body orig-level) 109 (let loop ([body body] [level orig-level]) 110 (syntax-case body (unquote unquote-splicing) 111 [(tmpl0 ... (unquote e)) 112 (with-syntax ([(tmpl0 ...) (rebuild-body #'(tmpl0 ...) (fx- orig-level 1))]) 113 (cond 114 [(fx=? level 0) #'(tmpl0 ... (unquote e))] 115 [(fx=? level 1) #'(tmpl0 ... (unquote-splicing e))] 116 [else (let loop ([level level] [e #'e]) 117 (if (fx=? level 1) 118 #`(tmpl0 ... (unquote-splicing #,e)) 119 (loop (fx- level 1) #`(apply append #,e))))]))] 120 [(tmpl0 ... (unquote-splicing e)) 121 (with-syntax ([(tmpl0 ...) (rebuild-body #'(tmpl0 ...) (fx- orig-level 1))]) 122 (cond 123 [(fx=? level 0) #'(tmpl0 ... (unquote-splicing e))] 124 [else (let loop ([level level] [e #'e]) 125 (if (fx=? level 0) 126 #`(tmpl0 ... (unquote-splicing #,e)) 127 (loop (fx- level 1) #`(apply append #,e))))]))] 128 [(tmpl0 ... tmpl1 ellipsis) 129 (eq? (datum ellipsis) '...) 130 (loop #'(tmpl0 ... tmpl1) (fx+ level 1))] 131 [(tmpl0 ... tmpl1) 132 (with-syntax ([(tmpl0 ...) (rebuild-body #'(tmpl0 ...) (fx- orig-level 1))]) 133 (let-values ([(tmpl1 t* e*) (gather-unquoted-exprs #'tmpl1)]) 134 (when (null? e*) 135 (syntax-violation 'extended-quasiquote 136 "no variables found in ellipsis expression" body)) 137 (let loop ([level level] 138 [e #`(map (lambda #,t* 139 (extended-quasiquote 140 #,tmpl1)) 141 . #,e*)]) 142 (if (fx=? level 1) 143 #`(tmpl0 ... (unquote-splicing #,e)) 144 (loop (fx- level 1) #`(apply append #,e))))))])))) 145 (define rebuild-body 146 (lambda (body level) 147 (syntax-case body (unquote unquote-splicing) 148 [(unquote e) #'(unquote e)] 149 [(unquote-splicing e) #'(unquote-splicing e)] 150 [(tmpl0 ... tmpl1 ellipsis) 151 (eq? (datum ellipsis) '...) 152 (with-syntax ([(tmpl0 ...) (build-list #'(tmpl0 ... tmpl1) (fx+ level 1))]) 153 #'(tmpl0 ...))] 154 [(tmpl0 ... tmpl1 ellipsis . tmpl2) 155 (eq? (datum ellipsis) '...) 156 (with-syntax ([(tmpl0 ...) (build-list #'(tmpl0 ... tmpl1) (fx+ level 1))] 157 [tmpl2 (rebuild-body #'tmpl2 level)]) 158 #'(tmpl0 ... . tmpl2))] 159 [(tmpl0 ... tmpl1) 160 (with-syntax ([(tmpl0 ...) (rebuild-body #'(tmpl0 ...) level)] 161 [tmpl1 (rebuild-body #'tmpl1 level)]) 162 #'(tmpl0 ... tmpl1))] 163 [(tmpl0 ... tmpl1 . tmpl2) 164 (with-syntax ([(tmpl0 ...) (rebuild-body #'(tmpl0 ... tmpl1) level)] 165 [tmpl2 (rebuild-body #'tmpl2 level)]) 166 #'(tmpl0 ... . tmpl2))] 167 [other #'other]))) 168 (syntax-case x () 169 [(k body) 170 (with-syntax ([body (rebuild-body #'body 0)]) 171 #'(quasiquote body))]))) 172 173 (define-syntax with-extended-quasiquote 174 (lambda (x) 175 (syntax-case x () 176 [(k . body) 177 (with-implicit (k quasiquote) 178 #'(let-syntax ([quasiquote (syntax-rules () 179 [(_ x) (extended-quasiquote x)])]) 180 181 . body))]))) 182 183 (define-syntax with-auto-unquote 184 (lambda (x) 185 (syntax-case x () 186 [(k (x* ...) . body) 187 (with-implicit (k quasiquote) 188 #'(let-syntax ([quasiquote 189 (lambda (x) 190 (define replace-vars 191 (let ([vars (list #'x* ...)]) 192 (lambda (b) 193 (let f ([b b]) 194 (syntax-case b () 195 [id (identifier? #'id) 196 (if (memp (lambda (var) (free-identifier=? var #'id)) vars) 197 #'(unquote id) 198 #'id)] 199 [(a . d) (with-syntax ([a (f #'a)] [d (f #'d)]) #'(a . d))] 200 [atom #'atom]))))) 201 (syntax-case x () 202 [(_ b) 203 (with-syntax ([b (replace-vars #'b)]) 204 #'`b)]))]) 205 . body))]))) 206 207 (define all-unique-identifiers? 208 (lambda (ls) 209 (and (for-all identifier? ls) 210 (let f ([ls ls]) 211 (if (null? ls) 212 #t 213 (let ([id (car ls)] [ls (cdr ls)]) 214 (and (not (memp (lambda (x) (free-identifier=? x id)) ls)) 215 (f ls)))))))) 216 217 (define-syntax with-values 218 (syntax-rules () 219 [(_ p c) (call-with-values (lambda () p) c)])) 220 221 (define-syntax rec 222 (syntax-rules () 223 [(_ name proc) (letrec ([name proc]) name)] 224 [(_ (name . arg) body body* ...) 225 (letrec ([name (lambda arg body body* ...)]) name)])) 226 227 (define-syntax define-auxiliary-keyword 228 (syntax-rules () 229 [(_ name) 230 (define-syntax name 231 (lambda (x) 232 (syntax-violation 'name "misplaced use of auxiliary keyword" x)))])) 233 234 (define-syntax define-auxiliary-keywords 235 (syntax-rules () 236 [(_ name* ...) 237 (begin (define-auxiliary-keyword name*) ...)])) 238 239 (define-auxiliary-keywords extends definitions entry terminals nongenerative-id maybe) 240 241 (define-syntax define-who 242 (lambda (x) 243 (syntax-case x () 244 [(k name expr) 245 (with-implicit (k who) 246 #'(define name (let () (define who 'name) expr)))] 247 [(k (name . fmls) expr exprs ...) 248 #'(define-who name (lambda (fmls) expr exprs ...))]))) 249 250 ;;; moved from meta-syntax-dispatch.ss and nano-syntax-dispatch.ss 251 (define combine 252 (lambda (r* r) 253 (if (null? (car r*)) 254 r 255 (cons (map car r*) (combine (map cdr r*) r))))) 256 257 ;;; moved from meta-syntax-dispatch.ss and syntaxconvert.ss 258 (define ellipsis? 259 (lambda (x) 260 (and (identifier? x) (free-identifier=? x (syntax (... ...)))))) 261 262 (define unquote? 263 (lambda (x) 264 (and (identifier? x) (free-identifier=? x (syntax unquote))))) 265 266 (define unquote-splicing? 267 (lambda (x) 268 (and (identifier? x) (free-identifier=? x (syntax unquote-splicing))))) 269 270 (define plus? 271 (lambda (x) 272 (and (identifier? x) 273 (or (free-identifier=? x #'+) 274 (eq? (syntax->datum x) '+))))) 275 276 (define minus? 277 (lambda (x) 278 (and (identifier? x) 279 (or (free-identifier=? x #'-) 280 (eq? (syntax->datum x) '-))))) 281 282 (define double-arrow? 283 (lambda (x) 284 (and (identifier? x) 285 (or (free-identifier=? x #'=>) 286 (eq? (syntax->datum x) '=>))))) 287 288 (define colon? 289 (lambda (x) 290 (and (identifier? x) 291 (or (free-identifier=? x #':) 292 (eq? (syntax->datum x) ':))))) 293 294 (define arrow? 295 (lambda (x) 296 (and (identifier? x) 297 (or (free-identifier=? x #'->) 298 (eq? (syntax->datum x) '->))))) 299 300 ;;; unique-name produces a unique name derived the input name by 301 ;;; adding a unique suffix of the form .<digit>+. creating a unique 302 ;;; name from a unique name has the effect of replacing the old 303 ;;; unique suffix with a new one. 304 305 (define unique-suffix 306 (let ((count 0)) 307 (lambda () 308 (set! count (+ count 1)) 309 (number->string count)))) 310 311 (define unique-name 312 (lambda (id . id*) 313 (string-append 314 (fold-right 315 (lambda (id str) (string-append str ":" (symbol->string (syntax->datum id)))) 316 (symbol->string (syntax->datum id)) id*) 317 "." 318 (unique-suffix)))) 319 320 ; TODO: at some point we may want this to be a little bit more 321 ; sophisticated, or we may want to have something like a regular 322 ; expression style engine where we bail as soon as we can identify 323 ; what the meta-var corresponds to. 324 (define meta-var->raw-meta-var 325 (lambda (sym) 326 (let ([s (symbol->string sym)]) 327 (let f ([i (fx- (string-length s) 1)]) 328 (cond 329 [(fx=? i -1) sym] 330 [(or (char=? #\* (string-ref s i)) 331 (char=? #\^ (string-ref s i)) 332 (char=? #\? (string-ref s i))) 333 (f (fx- i 1))] 334 [else (let f ([i i]) 335 (cond 336 [(fx=? i -1) sym] 337 [(char-numeric? (string-ref s i)) (f (fx- i 1))] 338 [else (string->symbol (substring s 0 (fx+ i 1)))]))]))))) 339 340 (define build-id 341 (lambda (who x x*) 342 (define ->str 343 (lambda (x) 344 (cond 345 [(string? x) x] 346 [(identifier? x) (symbol->string (syntax->datum x))] 347 [(symbol? x) (symbol->string x)] 348 [else (error who "invalid input ~s" x)]))) 349 (apply string-append (->str x) (map ->str x*)))) 350 351 (define $construct-id 352 (lambda (who str->sym tid x x*) 353 (unless (identifier? tid) 354 (error who "template argument ~s is not an identifier" tid)) 355 (datum->syntax tid (str->sym (build-id who x x*))))) 356 357 (define-who construct-id 358 (lambda (tid x . x*) 359 ($construct-id who string->symbol tid x x*))) 360 361 (define-who construct-unique-id 362 (lambda (tid x . x*) 363 ($construct-id who gensym tid x x*))) 364 365 (define-syntax partition-syn 366 (lambda (x) 367 (syntax-case x () 368 [(_ ls-expr () e0 e1 ...) #'(begin ls-expr e0 e1 ...)] 369 [(_ ls-expr ([set pred] ...) e0 e1 ...) 370 (with-syntax ([(pred ...) 371 (let f ([preds #'(pred ...)]) 372 (if (null? (cdr preds)) 373 (if (free-identifier=? (car preds) #'otherwise) 374 (list #'(lambda (x) #t)) 375 preds) 376 (cons (car preds) (f (cdr preds)))))]) 377 #'(let-values ([(set ...) 378 (let f ([ls ls-expr]) 379 (if (null? ls) 380 (let ([set '()] ...) (values set ...)) 381 (let-values ([(set ...) (f (cdr ls))]) 382 (cond 383 [(pred (car ls)) 384 (let ([set (cons (car ls) set)]) 385 (values set ...))] 386 ... 387 [else (error 'partition-syn 388 "no home for ~s" 389 (car ls))]))))]) 390 e0 e1 ...))]))) 391 392 (define gentemp 393 (lambda () 394 (car (generate-temporaries '(#'t))))) 395 396 (define bound-id-member? 397 (lambda (id id*) 398 (and (not (null? id*)) 399 (or (bound-identifier=? id (car id*)) 400 (bound-id-member? id (cdr id*)))))) 401 402 (define bound-id-union ; seems to be unneeded 403 (lambda (ls1 ls2) 404 (cond 405 [(null? ls1) ls2] 406 [(bound-id-member? (car ls1) ls2) (bound-id-union (cdr ls1) ls2)] 407 [else (cons (car ls1) (bound-id-union (cdr ls1) ls2))]))) 408 409 (define syntax->source-info 410 (lambda (stx) 411 (let ([si (syntax->source-information stx)]) 412 (and si 413 (cond 414 [(and (source-information-position-line si) 415 (source-information-position-column si)) 416 (format "~s line ~s, char ~s of ~a" 417 (source-information-type si) 418 (source-information-position-line si) 419 (source-information-position-column si) 420 (source-information-source-file si))] 421 [(source-information-byte-offset-start si) 422 (format "~s byte position ~s of ~a" 423 (source-information-type si) 424 (source-information-byte-offset-start si) 425 (source-information-source-file si))] 426 [(source-information-char-offset-start si) 427 (format "~s character position ~s of ~a" 428 (source-information-type si) 429 (source-information-char-offset-start si) 430 (source-information-source-file si))] 431 [else (format "in ~a" (source-information-source-file si))])))))) 432