tidying
parent
18081e6d6e
commit
5b894d8ae8
@ -1,26 +1,26 @@
|
||||
#lang s-exp "bf-expander.rkt"
|
||||
#lang s-exp "expander.rkt"
|
||||
(bf-program
|
||||
(op "+")
|
||||
(op "+")
|
||||
(op "+")
|
||||
(op "+")
|
||||
(op "+")
|
||||
(op "+")
|
||||
(op "+")
|
||||
(op "+")
|
||||
(loop
|
||||
(bf-op "+")
|
||||
(bf-op "+")
|
||||
(bf-op "+")
|
||||
(bf-op "+")
|
||||
(bf-op "+")
|
||||
(bf-op "+")
|
||||
(bf-op "+")
|
||||
(bf-op "+")
|
||||
(bf-loop
|
||||
"["
|
||||
(op ">")
|
||||
(op "+")
|
||||
(op "+")
|
||||
(op "+")
|
||||
(op "+")
|
||||
(op "+")
|
||||
(op "+")
|
||||
(op "+")
|
||||
(op "+")
|
||||
(op "<")
|
||||
(op "-")
|
||||
(bf-op ">")
|
||||
(bf-op "+")
|
||||
(bf-op "+")
|
||||
(bf-op "+")
|
||||
(bf-op "+")
|
||||
(bf-op "+")
|
||||
(bf-op "+")
|
||||
(bf-op "+")
|
||||
(bf-op "+")
|
||||
(bf-op "<")
|
||||
(bf-op "-")
|
||||
"]")
|
||||
(op ">")
|
||||
(op "."))
|
||||
(bf-op ">")
|
||||
(bf-op "."))
|
||||
@ -1,21 +0,0 @@
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base br/syntax) br/define racket/match)
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define-macro (define-exn EXN-ID BASE-EXN)
|
||||
(with-pattern ([RAISE-EXN-ID (prefix-id "raise-" #'EXN-ID)])
|
||||
#'(begin
|
||||
(define-struct (EXN-ID BASE-EXN)
|
||||
(a-srcloc) #:transparent
|
||||
#:property prop:exn:srclocs
|
||||
(lambda (a-struct)
|
||||
(match a-struct
|
||||
[(struct EXN-ID
|
||||
(msg marks a-srcloc))
|
||||
(list a-srcloc)])))
|
||||
(define RAISE-EXN-ID
|
||||
(case-lambda
|
||||
[(srcloc)
|
||||
(raise (EXN-ID (format "error: ~a" 'EXN-ID) (current-continuation-marks) srcloc))]
|
||||
[()
|
||||
(raise (EXN-ID (format "error: ~a" 'EXN-ID) (current-continuation-marks)))])))))
|
||||
@ -1,73 +0,0 @@
|
||||
#lang br
|
||||
(require racket/struct (for-syntax br/datum))
|
||||
(provide define-datatype cases occurs-free?)
|
||||
|
||||
(define-macro (define-datatype BASE-TYPE BASE-TYPE-PREDICATE?
|
||||
(SUBTYPE [FIELD FIELD-PREDICATE?] ...) ...)
|
||||
#'(begin
|
||||
(struct BASE-TYPE () #:transparent #:mutable)
|
||||
(struct SUBTYPE BASE-TYPE (FIELD ...) #:transparent #:mutable
|
||||
#:guard (λ(FIELD ... name)
|
||||
(unless (FIELD-PREDICATE? FIELD)
|
||||
(error name (format "arg ~a is not ~a" FIELD 'FIELD-PREDICATE?))) ...
|
||||
(values FIELD ...))) ...))
|
||||
|
||||
|
||||
(define-datatype lc-exp lc-exp?
|
||||
(var-exp [var symbol?])
|
||||
(lambda-exp [bound-var symbol?] [body lc-exp?])
|
||||
(app-exp [rator lc-exp?] [rand lc-exp?]))
|
||||
|
||||
|
||||
#;(define-syntax (cases stx)
|
||||
(syntax-case stx (else)
|
||||
[(_ _base-type INPUT-VAR
|
||||
[SUBTYPE (POSITIONAL-VAR ...) . _body] ...
|
||||
[else . _else-body])
|
||||
(inject-syntax ([#'(_subtype? ...) (suffix-id #'(SUBTYPE ...) "?")])
|
||||
#'(cond
|
||||
[(_subtype? INPUT-VAR) (match-let ([(list POSITIONAL-VAR ...) (struct->list INPUT-VAR)])
|
||||
. _body)] ...
|
||||
[else . _else-body]))]
|
||||
[(_ _base-type INPUT-VAR
|
||||
SUBTYPE-CASE ...)
|
||||
#'(cases _base-type INPUT-VAR
|
||||
SUBTYPE-CASE ...
|
||||
[else (void)])]))
|
||||
|
||||
|
||||
(define-macro-cases cases
|
||||
[(_ BASE-TYPE INPUT-VAR
|
||||
[SUBTYPE (POSITIONAL-VAR ...) . BODY] ...
|
||||
[else . ELSE-BODY])
|
||||
(with-syntax ([(SUBTYPE? ...) (suffix-id #'(SUBTYPE ...) "?")])
|
||||
#'(cond
|
||||
[(SUBTYPE? INPUT-VAR) (match-let ([(list POSITIONAL-VAR ...) (struct->list INPUT-VAR)])
|
||||
. BODY)] ...
|
||||
[else . ELSE-BODY]))]
|
||||
[(_ BASE-TYPE INPUT-VAR
|
||||
SUBTYPE-CASE ...)
|
||||
#'(cases BASE-TYPE INPUT-VAR
|
||||
SUBTYPE-CASE ...
|
||||
[else (void)])])
|
||||
|
||||
|
||||
(define (occurs-free? search-var exp)
|
||||
(cases lc-exp exp
|
||||
[var-exp (var) (eqv? var search-var)]
|
||||
[lambda-exp (bound-var body)
|
||||
(and (not (eqv? search-var bound-var))
|
||||
(occurs-free? search-var body))]
|
||||
[app-exp (rator rand)
|
||||
(or
|
||||
(occurs-free? search-var rator)
|
||||
(occurs-free? search-var rand))]))
|
||||
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(check-true (occurs-free? 'foo (var-exp 'foo)))
|
||||
(check-false (occurs-free? 'foo (var-exp 'bar)))
|
||||
(check-false (occurs-free? 'foo (lambda-exp 'foo (var-exp 'bar))))
|
||||
(check-true (occurs-free? 'foo (lambda-exp 'bar (var-exp 'foo))))
|
||||
(check-true (occurs-free? 'foo (lambda-exp 'bar (lambda-exp 'zim (lambda-exp 'zam (var-exp 'foo)))))))
|
||||
@ -1,26 +0,0 @@
|
||||
#lang racket
|
||||
(provide (except-out (all-from-out racket) #%module-begin)
|
||||
(rename-out [loader-module-begin #%module-begin]))
|
||||
|
||||
#|
|
||||
|
||||
br/load makes it possible to invoke a quick #lang by its pathname (without installing it as a collection)
|
||||
|
||||
#lang br/load "path.rkt"
|
||||
|
||||
Should simply delegate the reader & semantics.
|
||||
|
||||
|#
|
||||
|
||||
(define-syntax-rule (loader-module-begin loadpath expr ...)
|
||||
(#%module-begin
|
||||
(module loader-module loadpath
|
||||
expr ...)
|
||||
(require 'loader-module)
|
||||
|
||||
(module reader racket/base
|
||||
(require '(submod loadpath reader))
|
||||
(provide (all-from-out '(submod loadpath reader))))))
|
||||
|
||||
(module reader syntax/module-reader
|
||||
br/load)
|
||||
@ -1,127 +0,0 @@
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base br/syntax racket/syntax) syntax/strip-context racket/function)
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define (->syntax x)
|
||||
(if (syntax? x) x (datum->syntax #f x)))
|
||||
|
||||
|
||||
(define (context stx)
|
||||
(hash-ref (syntax-debug-info stx) 'context))
|
||||
|
||||
(define-syntax-rule (scopes stx)
|
||||
(format "~a = ~a" 'stx
|
||||
(cons (syntax->datum stx)
|
||||
(for/list ([scope (in-list (context stx))])
|
||||
scope))))
|
||||
|
||||
(define (syntax-find stx stx-or-datum)
|
||||
(unless (syntax? stx)
|
||||
(raise-argument-error 'syntax-find "not given syntax object as first argument" stx))
|
||||
(define datum
|
||||
(cond [(syntax? stx-or-datum) (syntax->datum stx-or-datum)]
|
||||
[(symbol? stx-or-datum) stx-or-datum]
|
||||
[else (raise-argument-error 'syntax-find "not given syntax or datum as second argument" stx-or-datum)]))
|
||||
(let/ec exit
|
||||
(let loop ([so stx])
|
||||
(cond
|
||||
[(eq? (syntax->datum so) datum) (exit so)]
|
||||
[(syntax->list so) => (curry map loop)]))))
|
||||
|
||||
(define-syntax (define-scope stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id)
|
||||
#'(define-scope id ())]
|
||||
[(_ id scope-ids)
|
||||
(with-syntax ([id-sis (suffix-id #'id "-sis")]
|
||||
[add-id (prefix-id "add-" #'id)]
|
||||
[flip-id (prefix-id "flip-" #'id)]
|
||||
[id-binding-form (suffix-id #'id "-binding-form")]
|
||||
[define-id (prefix-id "define-" #'id)]
|
||||
[with-id-identifiers (infix-id "with-" #'id "-identifiers")]
|
||||
[let-id-syntax (infix-id "let-" #'id "-syntax")]
|
||||
[with-id-binding-form (infix-id "with-" #'id "-binding-form")]
|
||||
[remove-id (prefix-id "remove-" #'id)]
|
||||
[id? (suffix-id #'id "?")]
|
||||
[id* (suffix-id #'id "*")]
|
||||
[(scope-id-sis ...) (suffix-id #'scope-ids "-sis")])
|
||||
#'(begin
|
||||
(define id-sis
|
||||
(let ([sis-in (list scope-id-sis ...)])
|
||||
(if (pair? sis-in)
|
||||
(apply append sis-in)
|
||||
(list
|
||||
(let ([si (make-syntax-introducer #t)])
|
||||
(list (procedure-rename (curryr si 'add) 'add-id)
|
||||
(procedure-rename (curryr si 'flip) 'flip-id)
|
||||
(procedure-rename (curryr si 'remove) 'remove-id)))))))
|
||||
(define add-id (λ(x) ((apply compose1 (map car id-sis)) (->syntax x))))
|
||||
(define flip-id (λ(x) ((apply compose1 (map cadr id-sis)) (->syntax x))))
|
||||
(define remove-id (λ(x) ((apply compose1 (map caddr id-sis)) (->syntax x))))
|
||||
(define (id x) (add-id (datum->syntax #f (syntax-e (->syntax x)))))
|
||||
(define (id-binding-form x) (syntax-local-introduce (id x)))
|
||||
(define (id* x) (replace-context (add-id (datum->syntax #f '_)) (->syntax x)))
|
||||
(define (id? x)
|
||||
(and
|
||||
(member (car (context (add-id (datum->syntax #f '_))))
|
||||
(context (->syntax x)))
|
||||
#t))
|
||||
(define-syntax-rule (with-id-identifiers (name (... ...)) . body)
|
||||
(with-syntax ([name (id* 'name)] (... ...)) . body))
|
||||
(define-syntax-rule (with-id-binding-form (name (... ...)) . body)
|
||||
(with-syntax ([name (id-binding-form 'name)] (... ...)) . body))
|
||||
(define-syntax-rule (let-id-syntax ([pat val] (... ...)) . body)
|
||||
(let-syntax ([pat (id* val)] (... ...)) . body))))]))
|
||||
|
||||
(define (scopes-equal? stxl stxr)
|
||||
;; "A bound-identifier=? comparison checks that two identifiers have exactly the same scope sets"
|
||||
(bound-identifier=? (datum->syntax stxl '_) (datum->syntax stxr '_)))
|
||||
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(define-scope red)
|
||||
|
||||
(define stx (datum->syntax #f 'x))
|
||||
|
||||
(define red-stx (add-red stx))
|
||||
(define double-red-stx (add-red (add-red stx)))
|
||||
|
||||
|
||||
(check-false (red? stx))
|
||||
(check-true (red? red-stx))
|
||||
(check-true (red? double-red-stx))
|
||||
(check-false (scopes-equal? stx red-stx))
|
||||
(check-true (scopes-equal? red-stx double-red-stx))
|
||||
(check-false (scopes-equal? red-stx (remove-red double-red-stx)))
|
||||
|
||||
|
||||
(define-scope blue) ; scope addition is commutative
|
||||
(define blue-stx (blue stx))
|
||||
(check-true (scopes-equal? (add-blue red-stx) (add-red blue-stx)))
|
||||
(check-true (scopes-equal? (remove-red (add-blue red-stx)) (remove-red (add-red blue-stx))))
|
||||
|
||||
|
||||
(define-scope green) ; replace scopes at outer layer
|
||||
(check-true (scopes-equal? (green red-stx) (green blue-stx)))
|
||||
|
||||
|
||||
;; replace scopes everywhere
|
||||
(check-true (scopes-equal? (car (syntax->list (green* #`(#,blue-stx #,red-stx))))
|
||||
(car (syntax->list (green* #`(#,red-stx #,blue-stx))))))
|
||||
|
||||
;; todo: test flipping
|
||||
|
||||
|
||||
(define-scope purple (red blue))
|
||||
|
||||
(check-true (purple? (add-purple stx)))
|
||||
(check-true (scopes-equal? (purple (green stx)) (add-blue (remove-green (add-red (add-green (add-blue stx))))))))
|
||||
|
||||
|
||||
(define-syntax (with-scopes stx)
|
||||
(syntax-case stx (syntax)
|
||||
[(_ (scope-id) (syntax expr))
|
||||
(with-syntax ([add-scope-id (format-id #'scope-id "add-~a" #'scope-id)])
|
||||
#'(add-scope-id expr))]))
|
||||
|
||||
@ -1,37 +0,0 @@
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base) racket/stxparam racket/splicing)
|
||||
(provide splicing-syntax-parameterize
|
||||
define-syntax-parameters
|
||||
define-language-variables
|
||||
define-language-variable
|
||||
inject-language-variables
|
||||
(rename-out [br:define-syntax-parameter define-syntax-parameter]))
|
||||
|
||||
(define-syntax (br:define-syntax-parameter stx)
|
||||
(syntax-case stx ()
|
||||
[(_ ID STX) #'(define-syntax-parameter ID STX)]
|
||||
[(_ [ID VAL]) #'(define-syntax-parameter ID (λ (stx) #'VAL))]
|
||||
[(_ ID) #'(define-syntax-parameter ID
|
||||
(λ (stx) (raise-syntax-error (syntax-e stx) "parameter not set")))]))
|
||||
|
||||
(define-syntax-rule (define-syntax-parameters ID ...)
|
||||
(begin (br:define-syntax-parameter ID) ...))
|
||||
|
||||
(define-syntax-rule (define-language-variable ID VAL)
|
||||
(br:define-syntax-parameter [ID VAL]))
|
||||
|
||||
(define-syntax-rule (define-language-variables [ID VAL] ...)
|
||||
(begin (define-language-variable ID VAL) ...))
|
||||
|
||||
(define-syntax (inject-language-variables stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (VAR-PARAM ...) LANG-CODE ...)
|
||||
(with-syntax ([(HOLDS-ORIG-PARAM-VALUE ...) (generate-temporaries #'(VAR-PARAM ...))]
|
||||
[(INTERNAL-NAME ...) (generate-temporaries #'(VAR-PARAM ...))])
|
||||
;; need to use splicing expressions in a module-begin to compose with requires etc. that might be in lang code
|
||||
#'(splicing-let ([HOLDS-ORIG-PARAM-VALUE VAR-PARAM] ...)
|
||||
(splicing-syntax-parameterize
|
||||
([VAR-PARAM (make-rename-transformer #'INTERNAL-NAME)] ...)
|
||||
(define INTERNAL-NAME HOLDS-ORIG-PARAM-VALUE) ...
|
||||
(provide (rename-out [INTERNAL-NAME VAR-PARAM] ...))
|
||||
LANG-CODE ...)))]))
|
||||
@ -1,20 +1,17 @@
|
||||
#lang racket/base
|
||||
(require racket/list "syntax-flatten.rkt")
|
||||
(require "syntax-flatten.rkt")
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define (upcased-and-capitalized? sym)
|
||||
(define str (symbol->string sym))
|
||||
(and (equal? (string-upcase str) str)
|
||||
(let ([first-letter (substring str 0 1)])
|
||||
(or (and (string->number first-letter) #t) ; leading digit OK
|
||||
(not (equal? (string-downcase first-letter) first-letter))))))
|
||||
;; generate literals for any symbols that are not ... or _ and not IN_CAPS
|
||||
(define (generate-literals pats)
|
||||
(for*/list ([pat-arg (in-list (syntax-flatten pats))]
|
||||
[pat-datum (in-value (syntax->datum pat-arg))]
|
||||
#:when (and (symbol? pat-datum)
|
||||
(not (memq pat-datum '(... _))) ; exempted from literality
|
||||
(let ([pat-str (symbol->string pat-datum)])
|
||||
(not (equal? (string-upcase pat-str) pat-str)))))
|
||||
pat-arg))
|
||||
|
||||
(define (generate-literals pats)
|
||||
;; generate literals for any symbols that are not ... or _
|
||||
(define pattern-arg-prefixer "_")
|
||||
(for*/list ([pat-arg (in-list (syntax-flatten pats))]
|
||||
[pat-datum (in-value (syntax->datum pat-arg))]
|
||||
#:when (and (symbol? pat-datum)
|
||||
(not (member pat-datum '(... _))) ; exempted from literality
|
||||
(not (upcased-and-capitalized? pat-datum))))
|
||||
pat-arg))
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(check-equal? (map syntax->datum (generate-literals #'(foo 42 BAR _ bar 3bar))) '(foo bar 3bar)))
|
||||
@ -1,44 +0,0 @@
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base racket/syntax br/syntax) br/define syntax/strip-context)
|
||||
(provide define-read-and-read-syntax test-reader)
|
||||
|
||||
(define (test-reader read-syntax-proc str)
|
||||
(syntax->datum (read-syntax-proc #f (open-input-string str))))
|
||||
|
||||
;; `define-read-functions` simplifies support for the standard reading API,
|
||||
;; which asks for `read` and `read-syntax`.
|
||||
;; in general, `read` is just the datum from the result of `read-syntax`.
|
||||
|
||||
(define-macro (define-read-and-read-syntax (PATH PORT) BODY ...)
|
||||
(let ([internal-prefix (gensym)])
|
||||
(with-syntax ([READ (datum->syntax caller-stx 'read)]
|
||||
[READ-SYNTAX (datum->syntax caller-stx 'read-syntax)]
|
||||
;; use prefixed names to prevent namespace collisions with possibly existing `read` & `read-syntax`
|
||||
[INTERNAL-READ (format-id #'here "~a-~a" internal-prefix 'read)]
|
||||
[INTERNAL-READ-SYNTAX (format-id #'here "~a-~a" internal-prefix 'read-syntax)])
|
||||
#'(begin
|
||||
(provide (rename-out [INTERNAL-READ READ]
|
||||
[INTERNAL-READ-SYNTAX READ-SYNTAX]))
|
||||
(define (calling-site-function PATH PORT)
|
||||
BODY ...) ; don't care whether this produces datum or syntax
|
||||
|
||||
(define INTERNAL-READ-SYNTAX
|
||||
(procedure-rename (λ (path port) ; rename proc so it looks right in the REPL (otherwise retains internal prefix name)
|
||||
;; because `read-syntax` must produce syntax
|
||||
;; coerce a datum result to syntax if needed (à la `with-syntax`)
|
||||
(define result-syntax (let ([output (calling-site-function path port)])
|
||||
(if (syntax? output)
|
||||
output
|
||||
(datum->syntax #f output))))
|
||||
;; because `read-syntax` must produce syntax without context
|
||||
;; see http://docs.racket-lang.org/guide/hash-lang_reader.html
|
||||
;; "a `read-syntax` function should return a syntax object with no lexical context"
|
||||
(strip-context result-syntax)) 'READ-SYNTAX))
|
||||
|
||||
(define INTERNAL-READ
|
||||
(procedure-rename (λ (port)
|
||||
; because `read` must produce a datum
|
||||
(let ([output (calling-site-function #f port)])
|
||||
(if (syntax? output)
|
||||
(syntax->datum output)
|
||||
output))) 'READ))))))
|
||||
Loading…
Reference in New Issue