Compare commits
77 Commits
v6.3-excep
...
master
Matthew Butterick
@ -0,0 +1,72 @@
|
||||
name: CI
|
||||
|
||||
on: [push, pull_request]
|
||||
|
||||
jobs:
|
||||
run:
|
||||
name: "Build using Racket '${{ matrix.racket-version }}' (${{ matrix.racket-variant }})"
|
||||
runs-on: ubuntu-latest
|
||||
continue-on-error: ${{ matrix.xfail == 'yes' }}
|
||||
strategy:
|
||||
fail-fast: false
|
||||
matrix:
|
||||
racket-version: ["6.7", "6.8", "6.9", "6.11", "6.12", "7.0", "7.1", "7.2", "7.3", "7.4", "7.5", "7.6", "7.7", "7.8", "7.9", "8.0", "8.1", "current"]
|
||||
racket-variant: ["BC", "CS"]
|
||||
# CS builds are only provided for versions 7.4 and up so avoid
|
||||
# running the job for prior versions.
|
||||
exclude:
|
||||
- {racket-version: "6.6", racket-variant: "CS"}
|
||||
- {racket-version: "6.7", racket-variant: "CS"}
|
||||
- {racket-version: "6.8", racket-variant: "CS"}
|
||||
- {racket-version: "6.9", racket-variant: "CS"}
|
||||
- {racket-version: "6.10.1", racket-variant: "CS"}
|
||||
- {racket-version: "6.11", racket-variant: "CS"}
|
||||
- {racket-version: "6.12", racket-variant: "CS"}
|
||||
- {racket-version: "7.0", racket-variant: "CS"}
|
||||
- {racket-version: "7.1", racket-variant: "CS"}
|
||||
- {racket-version: "7.2", racket-variant: "CS"}
|
||||
- {racket-version: "7.3", racket-variant: "CS"}
|
||||
include:
|
||||
- {racket-version: "6.7", racket-variant: "BC", xfail: "yes"}
|
||||
- {racket-version: "7.7", racket-variant: "CS", xfail: "yes"}
|
||||
- {racket-version: "7.8", racket-variant: "CS", xfail: "yes"}
|
||||
- {racket-version: "7.9", racket-variant: "CS", xfail: "yes"}
|
||||
- {racket-version: "current", racket-variant: "BC", xfail: "yes"}
|
||||
- {racket-version: "current", racket-variant: "CS", xfail: "yes"}
|
||||
env:
|
||||
DISPLAY: :99
|
||||
|
||||
steps:
|
||||
- name: Checkout
|
||||
uses: actions/checkout@master
|
||||
|
||||
- uses: Bogdanp/setup-racket@v0.11
|
||||
with:
|
||||
distribution: 'full'
|
||||
version: ${{ matrix.racket-version }}
|
||||
variant: ${{ matrix.racket-variant }}
|
||||
|
||||
- name: Install package and its dependencies
|
||||
run: raco pkg install --deps search-auto https://github.com/mbutterick/br-parser-tools.git?path=br-parser-tools-lib
|
||||
- name: install brag
|
||||
run: raco pkg install --deps search-auto https://github.com/mbutterick/brag.git?path=brag
|
||||
- name: install br-macro
|
||||
run: raco pkg install --deps search-auto https://github.com/mbutterick/beautiful-racket.git?path=beautiful-racket-macro
|
||||
- name: install br lib
|
||||
run: raco pkg install --deps search-auto https://github.com/mbutterick/beautiful-racket.git?path=beautiful-racket-lib
|
||||
- name: install br demo
|
||||
run: raco pkg install --deps search-auto https://github.com/mbutterick/beautiful-racket.git?path=beautiful-racket-demo
|
||||
- name: install br
|
||||
run: raco pkg install --deps search-auto https://github.com/mbutterick/beautiful-racket.git?path=beautiful-racket
|
||||
|
||||
- name: Start virtual framebuffer
|
||||
run: Xvfb "$DISPLAY" -screen 0 1280x1024x24 &
|
||||
|
||||
- name: Run the brm tests
|
||||
run: raco test -p beautiful-racket-macro
|
||||
- name: Run the lib tests
|
||||
run: raco test -p beautiful-racket-lib
|
||||
- name: Run the demo tests
|
||||
run: raco test -p beautiful-racket-demo
|
||||
- name: Run the br tests
|
||||
run: raco test -p beautiful-racket
|
||||
@ -1,58 +0,0 @@
|
||||
# adapted from
|
||||
# https://github.com/greghendershott/travis-racket/blob/master/.travis.yml
|
||||
# Thanks Greg!
|
||||
|
||||
language: c
|
||||
sudo: false
|
||||
|
||||
env:
|
||||
global:
|
||||
- RACKET_DIR=~/racket
|
||||
matrix:
|
||||
# - RACKET_VERSION=6.0
|
||||
# - RACKET_VERSION=6.1
|
||||
# - RACKET_VERSION=6.2
|
||||
- RACKET_VERSION=6.3
|
||||
# - RACKET_VERSION=6.4
|
||||
# - RACKET_VERSION=6.5
|
||||
- RACKET_VERSION=6.6
|
||||
# - RACKET_VERSION=6.7
|
||||
# - RACKET_VERSION=6.8
|
||||
- RACKET_VERSION=6.9
|
||||
# - RACKET_VERSION=6.10
|
||||
# - RACKET_VERSION=6.11
|
||||
- RACKET_VERSION=6.12
|
||||
- RACKET_VERSION=7.0
|
||||
- RACKET_VERSION=7.1
|
||||
- RACKET_VERSION=HEAD
|
||||
- RACKET_VERSION=HEADCS
|
||||
|
||||
# You may want to test against certain versions of Racket, without
|
||||
# having them count against the overall success/failure.
|
||||
matrix:
|
||||
allow_failures:
|
||||
#- env: RACKET_VERSION=HEAD
|
||||
- env: RACKET_VERSION=HEADCS
|
||||
# Fast finish: Overall build result is determined as soon as any of
|
||||
# its rows have failed, or, all of its rows that aren't allowed to
|
||||
# fail have succeeded.
|
||||
fast_finish: true
|
||||
|
||||
before_install:
|
||||
- "export DISPLAY=:99.0" # needed for testing with `racket/gui`
|
||||
- "sh -e /etc/init.d/xvfb start" # needed for testing with `racket/gui`
|
||||
- git clone https://github.com/mbutterick/travis-racket.git
|
||||
- cat travis-racket/install-racket.sh | bash # pipe to bash not sh!
|
||||
- export PATH="${RACKET_DIR}/bin:${PATH}" #install-racket.sh can't set for us
|
||||
|
||||
script:
|
||||
- cd .. # Travis did a cd into the dir. Back up, for the next:
|
||||
# don't rely on package server
|
||||
- travis_retry raco pkg install --deps search-auto https://github.com/mbutterick/br-parser-tools.git?path=br-parser-tools-lib
|
||||
- travis_retry raco pkg install --deps search-auto https://github.com/mbutterick/brag.git?path=brag
|
||||
- travis_retry raco pkg install --deps search-auto https://github.com/mbutterick/beautiful-racket.git?path=beautiful-racket-lib
|
||||
- raco test -p beautiful-racket-lib
|
||||
- travis_retry raco pkg install --deps search-auto https://github.com/mbutterick/beautiful-racket.git?path=beautiful-racket-demo
|
||||
- raco test -p beautiful-racket-demo
|
||||
- travis_retry raco pkg install --deps search-auto https://github.com/mbutterick/beautiful-racket.git?path=beautiful-racket
|
||||
- raco test -p beautiful-racket
|
||||
@ -0,0 +1,9 @@
|
||||
MIT License for `beautiful-racket`
|
||||
|
||||
© 2016-2019 Matthew Butterick
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the “Software”), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
|
||||
@ -1,9 +1,6 @@
|
||||
#lang brag
|
||||
|
||||
top : (func-def | func-app)*
|
||||
func-def : /"fun" var /"(" vars /")" /"=" expr
|
||||
/vars : var [/"," var]
|
||||
expr : var "+" var | value
|
||||
@value : var | INT | func-app
|
||||
func-app : var /"(" value [/"," value] /")"
|
||||
@var : ID
|
||||
top : (fun | app)*
|
||||
fun : /"fun" ID /"(" ID [/"," ID] /")" /"=" expr
|
||||
expr : ID /"+" ID | app
|
||||
app : ID /"(" (ID | INT) [/"," ID] /")"
|
||||
@ -1,4 +1,6 @@
|
||||
#lang algebra-demo
|
||||
fun f(x,y) = x + y
|
||||
fun g(z) = f(z,z)
|
||||
g(10)
|
||||
fun f(x,y) = x + y
|
||||
# fun f(x,y) = x * y
|
||||
fun g(zz) = f(zz,zz)
|
||||
g(10)
|
||||
g(23)
|
||||
@ -0,0 +1,26 @@
|
||||
#lang br/quicklang
|
||||
|
||||
(module reader br
|
||||
(provide read-syntax)
|
||||
(define (read-syntax name port)
|
||||
(define s-exprs (let loop ([toks null])
|
||||
(define tok (read port))
|
||||
(if (eof-object? tok)
|
||||
(reverse toks)
|
||||
(loop (cons tok toks)))))
|
||||
(strip-bindings
|
||||
(with-syntax ([(EXPR ...) s-exprs])
|
||||
#'(module read-only-mod conjunction-demo
|
||||
EXPR ...)))))
|
||||
|
||||
(define (convert-expr x)
|
||||
(cond
|
||||
[(list? x) (map convert-expr x)]
|
||||
[(number? x) 42]
|
||||
[(string? x) "whee"]
|
||||
[else 'kaboom]))
|
||||
|
||||
(define-macro (my-module-begin EXPR ...)
|
||||
#'(#%module-begin
|
||||
(convert-expr 'EXPR) ...))
|
||||
(provide (rename-out [my-module-begin #%module-begin]))
|
||||
@ -0,0 +1,4 @@
|
||||
#lang conjunction-demo
|
||||
|
||||
"hello world"
|
||||
(+ 1 (* 2 (- x)))
|
||||
@ -0,0 +1,40 @@
|
||||
#lang br
|
||||
(require racket/file)
|
||||
|
||||
#|
|
||||
(define src (file->string "source.txt"))
|
||||
|
||||
(define strs (string-split src))
|
||||
|
||||
(define toks (map (λ (str) (or (string->number str) (string->symbol str))) strs))
|
||||
|
||||
(define expr (list (second toks) (first toks) (third toks)))
|
||||
|
||||
(eval expr (make-base-namespace))
|
||||
|#
|
||||
|
||||
#|
|
||||
(eval
|
||||
(match (for/list ([str (in-list (string-split (file->string "source.txt")))])
|
||||
(or (string->number str) (string->symbol str)))
|
||||
[(list num1 op num2) (list op num1 num2)])
|
||||
(make-base-namespace))
|
||||
|#
|
||||
|
||||
(define (eval-src src)
|
||||
(eval
|
||||
(match (for/list ([str (in-list (string-split src))])
|
||||
(or (string->number str) (string->symbol str)))
|
||||
[(list num1 op num2) (list op num1 num2)]) (make-base-namespace)))
|
||||
|
||||
|
||||
(module reader br
|
||||
(provide read-syntax)
|
||||
(define (read-syntax name ip)
|
||||
`(module mod "main.rkt"
|
||||
,(port->string ip))))
|
||||
|
||||
(provide #%datum #%top-interaction (rename-out [mb #%module-begin]))
|
||||
(define-macro (mb SRC)
|
||||
#'(#%module-begin
|
||||
(eval-src SRC)))
|
||||
@ -0,0 +1,2 @@
|
||||
#lang dyadic-demo
|
||||
12 + 34
|
||||
@ -0,0 +1 @@
|
||||
12 + 34
|
||||
@ -0,0 +1,13 @@
|
||||
#lang br
|
||||
|
||||
(define (convert-expr x)
|
||||
(cond
|
||||
[(list? x) (map convert-expr x)]
|
||||
[(number? x) 42]
|
||||
[(string? x) "whee"]
|
||||
[else 'kaboom]))
|
||||
|
||||
(define-macro (my-module-begin EXPR ...)
|
||||
#'(#%module-begin
|
||||
(convert-expr 'EXPR) ...))
|
||||
(provide (rename-out [my-module-begin #%module-begin]))
|
||||
@ -0,0 +1,4 @@
|
||||
#lang s-exp expand-only-demo
|
||||
|
||||
"hello world"
|
||||
(+ 1 (* 2 (- x)))
|
||||
@ -0,0 +1,18 @@
|
||||
#lang br
|
||||
(provide #%top-interaction #%module-begin
|
||||
(rename-out [my-datum #%datum]
|
||||
[my-datum #%top]
|
||||
[my-app #%app]))
|
||||
|
||||
(define-macro (my-datum . THING)
|
||||
(define datum (syntax->datum #'THING))
|
||||
(cond
|
||||
[(string? datum) #'"whee"]
|
||||
[(number? datum) #'42]
|
||||
[else #''kaboom]))
|
||||
|
||||
(define-macro (my-app FUNC . ARGS)
|
||||
#'(list FUNC . ARGS))
|
||||
|
||||
(module reader syntax/module-reader
|
||||
injunction-demo)
|
||||
@ -0,0 +1,4 @@
|
||||
#lang injunction-demo
|
||||
|
||||
"hello world"
|
||||
(+ 1 (* 2 (- x)))
|
||||
@ -0,0 +1,18 @@
|
||||
#lang br/quicklang
|
||||
|
||||
(module reader br
|
||||
(provide (rename-out [rs read-syntax]))
|
||||
(define (rs src ip)
|
||||
(define toks (for/list ([tok (in-port (λ (p) (read-syntax src ip)) ip)])
|
||||
tok))
|
||||
(strip-context
|
||||
(with-syntax ([(PT ...) toks])
|
||||
#'(module _ mirror-demo
|
||||
PT ...)))))
|
||||
|
||||
(provide (except-out (all-from-out br/quicklang) #%module-begin)
|
||||
(rename-out [mb #%module-begin]))
|
||||
|
||||
(define-macro (mb PT ...)
|
||||
#'(#%module-begin
|
||||
PT ...))
|
||||
@ -0,0 +1,4 @@
|
||||
#lang mirror-demo
|
||||
|
||||
"hello world"
|
||||
(+ 1 (* 2 (- 3)))
|
||||
@ -0,0 +1,2 @@
|
||||
#lang numberstring-demo
|
||||
56833458
|
||||
@ -1,11 +1,12 @@
|
||||
#lang brag
|
||||
|
||||
top : (func-def | func-app)*
|
||||
func-def : /"fun" var /"(" vars /")" /"=" expr
|
||||
/vars : [var (/"," var)*]
|
||||
@expr : sum
|
||||
sum : [sum ("+" | "-")] product
|
||||
product : [product ("*" | "/")] value
|
||||
@value : var | INT | func-app | /"(" expr /")"
|
||||
func-app : var /"(" [expr (/"," expr)*] /")"
|
||||
top : (fun | app)*
|
||||
fun : /"fun" var /"(" argvars /")" /"=" expr
|
||||
/argvars : [var (/"," var)*]
|
||||
@expr : add-or-sub
|
||||
add-or-sub : [add-or-sub ("+" | "-")] mult-or-div
|
||||
mult-or-div : [mult-or-div ("*" | "/")] value
|
||||
@value : var | int | app | /"(" expr /")"
|
||||
int : ["-"] INT
|
||||
app : var /"(" [expr (/"," expr)*] /")"
|
||||
@var : ID
|
||||
@ -0,0 +1,13 @@
|
||||
#lang br
|
||||
(module reader br
|
||||
(provide read-syntax)
|
||||
(define (read-syntax name port)
|
||||
(define s-exprs (let loop ([toks null])
|
||||
(define tok (read port))
|
||||
(if (eof-object? tok)
|
||||
(reverse toks)
|
||||
(loop (cons tok toks)))))
|
||||
(strip-bindings
|
||||
(with-syntax ([(EXPR ...) s-exprs])
|
||||
#'(module read-only-mod br
|
||||
EXPR ...)))))
|
||||
@ -0,0 +1,4 @@
|
||||
#lang read-only-demo
|
||||
|
||||
"hello world"
|
||||
(+ 1 (* 2 (- 3)))
|
||||
@ -0,0 +1,138 @@
|
||||
#lang br
|
||||
(require racket/stxparam)
|
||||
(provide (all-defined-out)
|
||||
#%app #%top #%datum #%top-interaction)
|
||||
|
||||
(define-macro top #'#%module-begin)
|
||||
|
||||
(define-macro-cases ternary
|
||||
[(_ EXPR) #'EXPR]
|
||||
[(_ COND TRUE-EXPR FALSE-EXPR) #'(if COND TRUE-EXPR FALSE-EXPR)])
|
||||
|
||||
(define-macro-cases logical-or
|
||||
[(_ VAL) #'VAL]
|
||||
[(_ L "||" R) #'(or L R)])
|
||||
|
||||
(define-macro-cases logical-and
|
||||
[(_ VAL) #'VAL]
|
||||
[(_ L "&&" R) #'(and L R)])
|
||||
|
||||
(define-macro (my-app ID ARG ...)
|
||||
#'(error 'boom))
|
||||
|
||||
(define-macro-cases var
|
||||
[(_ ID VAL) #'(define ID VAL)]
|
||||
[(_ ID ... VAL) #'(begin (define ID VAL) ...)])
|
||||
|
||||
(define (add/concat . xs)
|
||||
(cond
|
||||
[(andmap number? xs) (let ([sum (apply + xs)])
|
||||
(if (and (integer? sum) (inexact? sum))
|
||||
(inexact->exact sum)
|
||||
sum))]
|
||||
[(ormap string? xs) (string-join (map ~a xs) "")]))
|
||||
|
||||
(define-macro-cases add-or-sub
|
||||
[(_ LEFT "+" RIGHT) #'(add/concat LEFT RIGHT)]
|
||||
[(_ LEFT "-" RIGHT) #'(- LEFT RIGHT)]
|
||||
[(_ OTHER) #'OTHER])
|
||||
|
||||
(define-macro-cases mult-or-div
|
||||
[(_ LEFT "*" RIGHT) #'(* LEFT RIGHT)]
|
||||
[(_ LEFT "/" RIGHT) #'(/ LEFT RIGHT)]
|
||||
[(_ OTHER) #'OTHER])
|
||||
|
||||
(define-macro (object (K V) ...)
|
||||
#'(make-hash (list (cons K V) ...)))
|
||||
|
||||
(define-syntax-parameter return
|
||||
(λ (stx) (error 'not-parameterized)))
|
||||
|
||||
(define-macro (fun (ARG ...) STMT ...)
|
||||
(syntax/loc caller-stx
|
||||
(λ (ARG ...)
|
||||
(let/cc return-cc
|
||||
(syntax-parameterize ([return (make-rename-transformer #'return-cc)])
|
||||
(void) STMT ...)))))
|
||||
|
||||
(define-macro (defun ID (ARG ...) STMT ...)
|
||||
#'(define ID (fun (ARG ...) STMT ...)))
|
||||
|
||||
(define (resolve-deref base . keys)
|
||||
(for/fold ([val base])
|
||||
([key (in-list keys)])
|
||||
(cond
|
||||
[(and
|
||||
(hash? val)
|
||||
(cond
|
||||
[(hash-ref val key #f)]
|
||||
[(hash-ref val (symbol->string key) #f)]
|
||||
[else #f]))]
|
||||
[else (error 'deref-failure)])))
|
||||
|
||||
(define-macro (deref (BASE KEY ...))
|
||||
#'(resolve-deref BASE 'KEY ...))
|
||||
|
||||
(define-macro app #'#%app)
|
||||
|
||||
(define-macro-cases if-else
|
||||
[(_ COND TSTMT ... "else" FSTMT ...) #'(cond
|
||||
[COND TSTMT ...]
|
||||
[else FSTMT ...])]
|
||||
[(_ COND STMT ...) #'(when COND STMT ...)])
|
||||
|
||||
(define-macro-cases equal-or-not
|
||||
[(_ VAL) #'VAL]
|
||||
[(_ L "==" R) #'(equal? L R)]
|
||||
[(_ L "!=" R) #'(not (equal? L R))])
|
||||
|
||||
(define-macro-cases gt-or-lt
|
||||
[(_ VAL) #'VAL]
|
||||
[(_ L "<" R) #'(< L R)]
|
||||
[(_ L "<=" R) #'(<= L R)]
|
||||
[(_ L ">" R) #'(> L R)]
|
||||
[(_ L ">=" R) #'(>= L R)])
|
||||
|
||||
(define-macro (while COND STMT ...)
|
||||
#'(let loop ()
|
||||
(when COND
|
||||
STMT ...
|
||||
(loop))))
|
||||
|
||||
(define (alert x) (displayln (format "ALERT! ~a" x)))
|
||||
|
||||
#;(require racket/gui)
|
||||
#;(define (alert text)
|
||||
(define dialog (instantiate dialog% ("Alert")))
|
||||
(new message% [parent dialog] [label text])
|
||||
(define panel (new horizontal-panel% [parent dialog]
|
||||
[alignment '(center center)]))
|
||||
(new button% [parent panel] [label "Ok"]
|
||||
[callback (lambda (button event)
|
||||
(send dialog show #f))])
|
||||
(send dialog show #t))
|
||||
|
||||
(define-macro-cases increment
|
||||
[(_ ID) #'ID]
|
||||
[(_ "++" ID) #'(let ()
|
||||
(set! ID (add1 ID))
|
||||
ID)]
|
||||
[(_ "--" ID) #'(let ()
|
||||
(set! ID (sub1 ID))
|
||||
ID)]
|
||||
[(_ ID "++") #'(begin0
|
||||
ID
|
||||
(set! ID (add1 ID)))]
|
||||
[(_ ID "--") #'(begin0
|
||||
ID
|
||||
(set! ID (sub1 ID)))])
|
||||
|
||||
|
||||
(define-macro-cases reassignment
|
||||
[(_ ID) #'ID]
|
||||
[(_ ID "+=" EXPR) #'(let ()
|
||||
(set! ID (+ ID EXPR))
|
||||
ID)]
|
||||
[(_ ID "-=" EXPR) #'(let ()
|
||||
(set! ID (- ID EXPR))
|
||||
ID)])
|
||||
@ -0,0 +1,31 @@
|
||||
#lang brag
|
||||
|
||||
top : @statement*
|
||||
statement : (var | expr | return | defun) /";" | if-else | while
|
||||
var : /"var" (varname /"=")+ expr
|
||||
@expr : reassignment
|
||||
reassignment : ID [("+=" | "-=") expr] | ternary
|
||||
ternary : expr /"?" expr /":" expr | logical-or
|
||||
logical-or : [logical-or "||"] logical-and
|
||||
logical-and : [logical-and "&&"] equal-or-not
|
||||
equal-or-not : [equal-or-not ("!=" | "==")] gt-or-lt
|
||||
gt-or-lt : [gt-or-lt ("<" | "<=" | ">" | ">=")] add-or-sub
|
||||
add-or-sub : [add-or-sub ("+" | "-")] mult-or-div
|
||||
mult-or-div : [mult-or-div ("*" | "/")] value
|
||||
@value : NUMBER | STRING | object
|
||||
| fun | app | increment | varname | /"(" expr /")"
|
||||
increment : ("++" | "--") varname | varname ("++" | "--")
|
||||
object : /"{" @kvs /"}"
|
||||
kvs : [kv (/"," kv)*]
|
||||
/kv : expr /":" expr
|
||||
defun : /"function" ID /"(" varnames /")" @block
|
||||
fun : /"function" /"(" varnames /")" @block
|
||||
/varnames : [varname (/"," varname)*]
|
||||
@varname : ID | deref
|
||||
deref : DEREF
|
||||
block : /"{" @statement* /"}"
|
||||
return : /"return" expr
|
||||
app : varname /"(" @exprs /")"
|
||||
exprs : [expr (/"," expr)*]
|
||||
if-else : /"if" /"(" expr /")" @block ["else" @block]
|
||||
while : /"while" /"(" expr /")" @block
|
||||
@ -0,0 +1,4 @@
|
||||
#lang info
|
||||
|
||||
(define compile-omit-paths '("less-rackety.rkt" "test.rkt"))
|
||||
(define test-omit-paths '("less-rackety.rkt" "test.rkt"))
|
||||
@ -0,0 +1,43 @@
|
||||
#lang br/quicklang
|
||||
(require "grammar.rkt" brag/support)
|
||||
|
||||
(module+ reader
|
||||
(provide read-syntax))
|
||||
|
||||
(define-lex-abbrev reserved-toks
|
||||
(:or "var" "=" ";" "{" "}" "//" "/*" "*/"
|
||||
"+" "*" "/" "-"
|
||||
"'" "\""
|
||||
":" "," "(" ")"
|
||||
"if" "else" "while" "?"
|
||||
"==" "!=" "<=" "<" ">=" ">" "&&" "||"
|
||||
"function"
|
||||
"return" "++" "--" "+=" "-="))
|
||||
|
||||
(define-lex-abbrev digits (:+ (char-set "0123456789")))
|
||||
|
||||
(define tokenize-1
|
||||
(lexer-srcloc
|
||||
[(:or (from/stop-before "//" "\n")
|
||||
(from/to "/*" "*/")) (token 'COMMENT #:skip? #t)]
|
||||
[reserved-toks lexeme]
|
||||
[(:seq (:? "-") (:or (:seq (:? digits) "." digits)
|
||||
(:seq digits (:? "."))))
|
||||
(token 'NUMBER (string->number lexeme))]
|
||||
[(:seq (:+ (:- (:or alphabetic punctuation digits) reserved-toks)))
|
||||
(if (string-contains? lexeme ".")
|
||||
(token 'DEREF (map string->symbol (string-split lexeme ".")))
|
||||
(token 'ID (string->symbol lexeme)))]
|
||||
[(:or (from/to "\"" "\"") (from/to "'" "'"))
|
||||
(token 'STRING (string-trim lexeme (substring lexeme 0 1)))]
|
||||
[whitespace (token 'WHITE #:skip? #t)]
|
||||
[any-char lexeme]))
|
||||
|
||||
(define (read-syntax src ip)
|
||||
(port-count-lines! ip)
|
||||
(lexer-file-path ip)
|
||||
(define parse-tree (parse src (λ () (tokenize-1 ip))))
|
||||
(strip-bindings
|
||||
(with-syntax ([PT parse-tree])
|
||||
#'(module scriptish-mod scriptish-demo/expander
|
||||
PT))))
|
||||
@ -0,0 +1,21 @@
|
||||
#lang scriptish-demo
|
||||
|
||||
-1; // line comment
|
||||
10 ;
|
||||
|
||||
/* multi
|
||||
// line
|
||||
comment */
|
||||
2;
|
||||
|
||||
var al = -.123;
|
||||
var bo = "foo";
|
||||
var cy = 1.;
|
||||
var da = 'bar';
|
||||
al;bo;cy;da;
|
||||
|
||||
cy + cy + cy;
|
||||
al+cy*al-cy/100;
|
||||
cy++;
|
||||
cy + cy + bo + da;
|
||||
bo+cy+cy+da;
|
||||
@ -0,0 +1,34 @@
|
||||
#lang scriptish-demo
|
||||
|
||||
var x = 42;
|
||||
var s = "string";
|
||||
|
||||
x + x; // prints 84
|
||||
s + x; // prints "string42"
|
||||
|
||||
var thing = {
|
||||
"foo" : 42,
|
||||
'bar' : function(x) {
|
||||
return x + 15;
|
||||
}
|
||||
};
|
||||
|
||||
thing.foo; // prints 42
|
||||
thing.bar; // prints #<procedure:...test.rkt:11:12>
|
||||
thing.bar(3); // prints 18
|
||||
|
||||
if ( thing.foo == 42 ) {
|
||||
// prints "The correct answer is 42"
|
||||
alert("The correct answer is " + thing.foo);
|
||||
} else {
|
||||
alert("Nope");
|
||||
}
|
||||
|
||||
var idx = 0;
|
||||
while ( idx != 50 ) {
|
||||
if ( thing.bar(idx) == 35 ) {
|
||||
// prints "Calamity at 20!"
|
||||
alert("Calamity at " + idx + "!");
|
||||
}
|
||||
idx++;
|
||||
}
|
||||
@ -0,0 +1,38 @@
|
||||
#lang txtadv-demo
|
||||
|
||||
===VERBS===
|
||||
|
||||
north, n
|
||||
"go north"
|
||||
|
||||
south, s
|
||||
"go south"
|
||||
|
||||
get _, grab _, take _
|
||||
"take"
|
||||
|
||||
===THINGS===
|
||||
|
||||
---cactus---
|
||||
get
|
||||
"You win!"
|
||||
|
||||
===PLACES===
|
||||
|
||||
---meadow---
|
||||
"Welcome to the Cactus Game! You're standing in a meadow. There is a desert to the south."
|
||||
[]
|
||||
|
||||
south
|
||||
desert
|
||||
|
||||
---desert---
|
||||
"You're in a desert. There is nothing for miles around."
|
||||
[cactus]
|
||||
|
||||
north
|
||||
meadow
|
||||
|
||||
===START===
|
||||
|
||||
meadow
|
||||
@ -0,0 +1,5 @@
|
||||
#lang racket/base
|
||||
|
||||
(module reader racket/base
|
||||
(require "reader.rkt")
|
||||
(provide (all-from-out "reader.rkt")))
|
||||
@ -0,0 +1,9 @@
|
||||
#lang info
|
||||
|
||||
;; for unknown reason "indent.rkt"
|
||||
;; started causing CI failures
|
||||
;; consistently on 6.7, 7.7CS, 7.8CS, 7.9CS
|
||||
;; I assume it has something to do with the fact that
|
||||
;; it imports `framework` and `racket/gui`,
|
||||
;; OTOH why does it fail in these?
|
||||
(define test-omit-paths '("indent.rkt"))
|
||||
@ -0,0 +1,245 @@
|
||||
#lang racket/base
|
||||
(require racket/function
|
||||
(for-syntax racket/base
|
||||
syntax/parse
|
||||
"private/generate-literals.rkt"
|
||||
syntax/define))
|
||||
(provide (all-defined-out)
|
||||
(for-syntax with-shared-id))
|
||||
|
||||
(module+ test (require rackunit))
|
||||
|
||||
(begin-for-syntax
|
||||
;; expose the caller context within br:define macros with syntax parameter
|
||||
(require (for-syntax racket/base) racket/stxparam)
|
||||
(provide caller-stx)
|
||||
(define-syntax-parameter caller-stx (λ(stx) (error 'caller-stx-not-parameterized))))
|
||||
|
||||
(define-syntax (define-cases stx)
|
||||
(syntax-parse stx
|
||||
#:literals (syntax)
|
||||
[(_ id:id)
|
||||
(raise-syntax-error 'define-cases "no cases given" (syntax->datum #'id))]
|
||||
[(_ id:id [(_ . pat-args:expr) . body:expr] ...)
|
||||
#'(define id
|
||||
(case-lambda
|
||||
[pat-args . body] ...
|
||||
[rest-pat (apply raise-arity-error 'id (normalize-arity (map length '(pat-args ...))) rest-pat)]))]
|
||||
[else (raise-syntax-error
|
||||
'define-cases
|
||||
"no matching case for calling pattern"
|
||||
(syntax->datum stx))]))
|
||||
|
||||
|
||||
(module+ test
|
||||
(define-cases f
|
||||
[(_ arg) (add1 arg)]
|
||||
[(_ arg1 arg2) (+ arg1 arg2)]
|
||||
[(_ . any) 'boing])
|
||||
(check-equal? (f 42) 43)
|
||||
(check-equal? (f 42 5) 47)
|
||||
(check-equal? (f 42 5 'zonk) 'boing)
|
||||
|
||||
(define-cases f-one-arg
|
||||
[(_ arg) (add1 arg)])
|
||||
(check-exn exn:fail:contract:arity? (λ _ (f-one-arg 1 2 3))))
|
||||
|
||||
|
||||
(define-syntax-rule (debug-define-macro (ID . PAT-ARGS) BODY)
|
||||
(define-macro (ID . PAT-ARGS)
|
||||
#`(begin
|
||||
(for-each displayln
|
||||
(list
|
||||
(format "input pattern = #'~a" '#,'(ID . PAT-ARGS))
|
||||
(format "output pattern = #'~a" (cadr '#,'BODY))
|
||||
(format "invoked as = ~a" (syntax->datum #'(ID . PAT-ARGS)))
|
||||
(format "expanded as = ~a" '#,(syntax->datum BODY))
|
||||
(format "evaluated as = ~a" #,BODY)))
|
||||
#,BODY)))
|
||||
|
||||
|
||||
(module+ test
|
||||
(require racket/port)
|
||||
(parameterize ([current-output-port (open-output-nowhere)])
|
||||
(check-equal? (let ()
|
||||
(debug-define-macro (foo X Y Z)
|
||||
#'(apply + (list X Y Z)))
|
||||
(foo 1 2 3)) 6)
|
||||
(check-equal? (let ()
|
||||
(debug-define-macro (foo X ...) #'(apply * (list X ...)))
|
||||
(foo 10 11 12)) 1320)))
|
||||
|
||||
|
||||
(begin-for-syntax
|
||||
(begin-for-syntax
|
||||
(require (for-syntax racket/base))
|
||||
(define-syntax-rule (make-shared-syntax-macro caller-stx)
|
||||
#'(syntax-rules stx
|
||||
[(_ form)
|
||||
#'(datum->syntax caller-stx (if (syntax? form)
|
||||
(syntax-e form)
|
||||
form))]))))
|
||||
|
||||
(module+ test
|
||||
(define-macro (dirty-maker ARG)
|
||||
(with-syntax ([dirty-bar (datum->syntax caller-stx 'dirty-bar)])
|
||||
#'(define dirty-bar (* ARG 2))))
|
||||
(dirty-maker 42)
|
||||
(check-equal? dirty-bar 84))
|
||||
|
||||
|
||||
(begin-for-syntax
|
||||
(define-syntax-rule (with-shared-id (id ...) . body)
|
||||
(with-syntax ([id (datum->syntax caller-stx 'id)] ...)
|
||||
. body)))
|
||||
|
||||
|
||||
;; `syntax-parse` classes shared by `define-macro` and `define-macro-cases`
|
||||
(begin-for-syntax
|
||||
(require syntax/parse)
|
||||
|
||||
(define-syntax-class syntaxed-id
|
||||
#:literals (syntax quasisyntax)
|
||||
#:description "id in syntaxed form"
|
||||
(pattern ([~or syntax quasisyntax] name:id)))
|
||||
|
||||
(define-syntax-class syntaxed-thing
|
||||
#:literals (syntax quasisyntax)
|
||||
#:description "some datum in syntaxed form"
|
||||
(pattern ([~or syntax quasisyntax] thing:expr)))
|
||||
|
||||
(define-syntax-class else-clause
|
||||
#:literals (else)
|
||||
(pattern [else . body:expr]))
|
||||
|
||||
(define-syntax-class transformer-func
|
||||
#:literals (lambda λ)
|
||||
(pattern ([~or lambda λ] (arg:id) . body:expr))))
|
||||
|
||||
|
||||
(define-syntax (define-macro stx)
|
||||
(syntax-parse stx
|
||||
[(_ id:id stxed-id:syntaxed-id)
|
||||
#'(define-syntax id (make-rename-transformer stxed-id))]
|
||||
[(_ id:id func:transformer-func)
|
||||
#'(define-syntax id func)]
|
||||
[(_ id:id func-id:id)
|
||||
#'(define-syntax id func-id)]
|
||||
[(_ id:id stxed-thing:syntaxed-thing)
|
||||
#'(define-macro id (λ (stx) stxed-thing))]
|
||||
[(_ (id:id . patargs:expr) . body:expr)
|
||||
(with-syntax ([id (syntax-property #'id 'caller 'define-macro)])
|
||||
#'(define-macro-cases id [(id . patargs) (begin . body)]))]
|
||||
[else (raise-syntax-error
|
||||
'define-macro
|
||||
"no matching case for calling pattern"
|
||||
(syntax->datum stx))]))
|
||||
|
||||
|
||||
(define-syntax (define-macro-cases stx)
|
||||
(define (error-source stx) (or (syntax-property stx 'caller) 'define-macro-cases))
|
||||
(syntax-parse stx
|
||||
[(_ id:id)
|
||||
(raise-syntax-error (error-source #'id) "no cases given" (syntax->datum #'id))]
|
||||
[(_ id:id leading-pat:expr ... else-pat:else-clause trailing-pat0:expr trailing-pat:expr ...)
|
||||
(raise-syntax-error (error-source #'id) "`else` clause must be last" (syntax->datum #'id))]
|
||||
[(_ id:id (pat:expr . result-exprs:expr) ... else-clause:else-clause)
|
||||
(unless (ellipses-follow-wildcards-or-subpatterns? #'(pat ...))
|
||||
(raise-syntax-error (error-source #'id) "ellipsis in pattern can only appear after wildcard or subpattern" (syntax->datum stx)))
|
||||
(with-syntax ([(PAT ...) (map (λ (x) (literalize-pat x #'~literal)) (syntax->list #'(pat ...)))])
|
||||
#'(define-macro id
|
||||
(λ (stx)
|
||||
(define result
|
||||
(syntax-parameterize ([caller-stx (make-rename-transformer #'stx)])
|
||||
(syntax-parse (syntax-case stx () [any #'any])
|
||||
[PAT . result-exprs] ...
|
||||
else-clause)))
|
||||
(if (syntax? result)
|
||||
result
|
||||
(datum->syntax #'id result)))))]
|
||||
[(_ id:id pat-clause:expr ...) ; macro without `else` clause will reach this branch
|
||||
#'(define-macro-cases id
|
||||
pat-clause ...
|
||||
[else (raise-syntax-error
|
||||
'id
|
||||
"no matching case for calling pattern"
|
||||
(syntax->datum caller-stx))])]
|
||||
[else (raise-syntax-error
|
||||
(error-source #'id)
|
||||
"no matching case for calling pattern"
|
||||
(syntax->datum stx))]))
|
||||
|
||||
|
||||
(module+ test
|
||||
(define-macro plus (λ (stx) #'+))
|
||||
(check-equal? (plus 42) +)
|
||||
(define-macro plusser #'plus)
|
||||
(check-equal? (plusser 42) +)
|
||||
(check-equal? plusser +)
|
||||
(define-macro (times [nested ARG]) #`(* ARG ARG))
|
||||
(check-equal? (times [nested 10]) 100)
|
||||
(define-macro timeser #'times)
|
||||
(check-equal? (timeser [nested 12]) 144)
|
||||
(define-macro fortytwo #`42)
|
||||
(check-equal? fortytwo 42)
|
||||
(check-equal? (let ()
|
||||
(define-macro (foo X)
|
||||
(with-syntax ([zam #'+])
|
||||
#'(zam X X))) (foo 42)) 84)
|
||||
(begin
|
||||
(define-macro (redefine ID) #'(define ID 42))
|
||||
(redefine zoombar)
|
||||
(check-equal? zoombar 42))
|
||||
|
||||
;; use caller-stx parameter to introduce identifier unhygienically
|
||||
(define-macro (zam ARG1 ARG2 ARG3)
|
||||
(with-syntax ([dz (datum->syntax caller-stx 'dirty-zam)])
|
||||
#`(define dz 'got-dirty-zam)))
|
||||
|
||||
(zam 'this 'that 42)
|
||||
(check-equal? dirty-zam 'got-dirty-zam)
|
||||
|
||||
(define-macro (add X) #'(+ X X))
|
||||
(check-equal? (add 5) 10)
|
||||
(define-macro (add-b 9X) #'(+ 9X 9X))
|
||||
(check-equal? (add-b 5) 10)
|
||||
(define-macro-cases add-again [(_ X) #'(+ X X)])
|
||||
(check-equal? (add-again 5) 10)
|
||||
(define-macro-cases add-3rd [(_ X) #'(+ X X)])
|
||||
(check-equal? (add-3rd 5) 10)
|
||||
(define-macro add-4th #'add-3rd)
|
||||
(check-equal? (add-4th 5) 10)
|
||||
(define foo-val 'got-foo-val)
|
||||
(define (foo-func) 'got-foo-func)
|
||||
(define-macro-cases op
|
||||
[(_ "+") #''got-plus]
|
||||
[(_ ARG) #''got-something-else]
|
||||
[(_) #'(foo-func)]
|
||||
[_ #'foo-val])
|
||||
|
||||
(check-equal? (op "+") 'got-plus)
|
||||
(check-equal? (op 42) 'got-something-else)
|
||||
(check-equal? (op) 'got-foo-func)
|
||||
(check-equal? op 'got-foo-val)
|
||||
|
||||
(define-macro-cases elseop
|
||||
[(_ ARG) #''got-arg]
|
||||
[else #''got-else])
|
||||
|
||||
(check-equal? (elseop "+") 'got-arg)
|
||||
(check-equal? (elseop "+" 42) 'got-else)
|
||||
|
||||
(check-exn exn:fail:syntax? (λ () (expand-once #'(define-macro-cases no-cases))))
|
||||
|
||||
(check-exn exn:fail:syntax? (λ () (expand-once #'(define-macro-cases badelseop
|
||||
[else #''got-else]
|
||||
[(_ _arg) #''got-arg]))))
|
||||
|
||||
(define-macro-cases no-else-macro
|
||||
[(_ ARG) #''got-arg])
|
||||
(check-exn exn:fail:syntax? (λ _ (expand-once #'(no-else-macro 'arg1 'arg2)))))
|
||||
|
||||
(define-macro (define-unhygienic-macro (ID PAT ...) BODY ... STX-OBJECT)
|
||||
#'(define-macro (ID PAT ...)
|
||||
BODY ...
|
||||
(datum->syntax caller-stx (syntax->datum STX-OBJECT))))
|
||||
@ -0,0 +1,11 @@
|
||||
#lang info
|
||||
|
||||
(define collection 'multi)
|
||||
|
||||
(define version "1.5")
|
||||
|
||||
;; base v6.7 dependency needs to be called 6.6.0.900
|
||||
;; due to strange little bug in `raco pkg install`
|
||||
(define deps '(["base" #:version "6.6.0.900"]))
|
||||
|
||||
(define build-deps '("rackunit-lib"))
|
||||
Loading…
Reference in New Issue