├── doc ├── doc-site.css ├── doc-site.js ├── scribble-style.css ├── smol-step │ ├── synced.rktd │ ├── blueboxes.rktd │ ├── in.sxref │ ├── out0.sxref │ ├── provides.sxref │ ├── out1.sxref │ ├── stamp.sxref │ └── index.html ├── racket.css ├── scribble-common.js ├── manual-racket.css ├── manual-racket.js ├── scribble.css └── manual-style.css ├── main.rkt ├── tests ├── test.rkt ├── randomized-test.rkt └── utilities.rkt ├── .gitattributes ├── smol ├── fun │ ├── lang │ │ └── reader.rkt │ └── semantics.rkt ├── hof │ ├── lang │ │ └── reader.rkt │ └── semantics.rkt ├── state │ ├── lang │ │ └── reader.rkt │ └── semantics.rkt └── general-semantics.txt ├── error-racket.rkt ├── scribblings └── stacker.scrbl ├── .gitignore ├── info.rkt ├── error.rkt ├── .github └── workflows │ └── ci.yml ├── LICENSE ├── LICENSE-MIT ├── utilities.rkt ├── io.rkt ├── show.rkt ├── string-of-state.rkt ├── pict-loop.rkt ├── README.md ├── parse.rkt ├── pict-of-state.rkt ├── datatypes.rkt ├── s-exp-of-state.rkt └── runtime.rkt /doc/doc-site.css: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /doc/doc-site.js: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /doc/scribble-style.css: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket -------------------------------------------------------------------------------- /doc/smol-step/synced.rktd: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /tests/test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "./utilities.rkt") 3 | 4 | -------------------------------------------------------------------------------- /doc/smol-step/blueboxes.rktd: -------------------------------------------------------------------------------- 1 | 33 2 | ((3) 0 () 0 () () (h ! (equal))) 3 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | # Auto detect text files and perform LF normalization 2 | * text=auto 3 | -------------------------------------------------------------------------------- /smol/fun/lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp syntax/module-reader 2 | stacker/smol/fun/semantics -------------------------------------------------------------------------------- /smol/hof/lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp syntax/module-reader 2 | stacker/smol/hof/semantics -------------------------------------------------------------------------------- /smol/state/lang/reader.rkt: -------------------------------------------------------------------------------- 1 | #lang s-exp syntax/module-reader 2 | stacker/smol/state/semantics -------------------------------------------------------------------------------- /doc/smol-step/in.sxref: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LuKuangChen/stacker-on-racket/HEAD/doc/smol-step/in.sxref -------------------------------------------------------------------------------- /doc/smol-step/out0.sxref: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LuKuangChen/stacker-on-racket/HEAD/doc/smol-step/out0.sxref -------------------------------------------------------------------------------- /doc/smol-step/provides.sxref: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/LuKuangChen/stacker-on-racket/HEAD/doc/smol-step/provides.sxref -------------------------------------------------------------------------------- /doc/smol-step/out1.sxref: -------------------------------------------------------------------------------- 1 | racket/fasl:nrqolibscribble/render-struct.rktdeserialize-info:mobile-root-v0ncnh!equal -------------------------------------------------------------------------------- /error-racket.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide catch) 3 | (define (catch thunk handler) 4 | (with-handlers ([(λ (x) #t) 5 | handler]) 6 | (thunk))) 7 | -------------------------------------------------------------------------------- /doc/smol-step/stamp.sxref: -------------------------------------------------------------------------------- 1 | ("bfa0118e958a253c31998b69d6f541c0b72725b7b47e85602ebfda0564a78b7be4fa6ff5de6b37ef" "6ae901c6c4e0ed41271708ceddebc8279f114d6a7d94189e0d9104671bf011ef204bc5c4178b449a" "35e8f141a35c25e707062c7e64f9adeed57060a1") -------------------------------------------------------------------------------- /scribblings/stacker.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | @require[@for-label[stacker 3 | racket/base]] 4 | 5 | @title{stacker} 6 | @author{lukc} 7 | 8 | @defmodule[stacker] 9 | 10 | Package Description Here 11 | -------------------------------------------------------------------------------- /smol/fun/semantics.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (define enable-tco? #t) 4 | (define hide-closure? #t) 5 | (define hide-env-label? #t) 6 | (define hide-fun-addr? #t) 7 | (define defvar-lambda-as-deffun? #t) 8 | (define set!-lambda-as-def? #t) 9 | (define set!-other-as-def? #t) 10 | 11 | (include "../general-semantics.txt") 12 | -------------------------------------------------------------------------------- /smol/hof/semantics.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (define enable-tco? #t) 4 | (define hide-closure? #f) 5 | (define hide-env-label? #t) 6 | (define hide-fun-addr? #t) 7 | (define defvar-lambda-as-deffun? #f) 8 | (define set!-lambda-as-def? #f) 9 | (define set!-other-as-def? #f) 10 | 11 | (include "../general-semantics.txt") 12 | -------------------------------------------------------------------------------- /smol/state/semantics.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (define enable-tco? #t) 4 | (define hide-closure? #t) 5 | (define hide-env-label? #t) 6 | (define hide-fun-addr? #t) 7 | (define defvar-lambda-as-deffun? #t) 8 | (define set!-lambda-as-def? #t) 9 | (define set!-other-as-def? #f) 10 | 11 | (include "../general-semantics.txt") 12 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | **/compiled/* 3 | 4 | *.rkt~ 5 | *.rkt#* 6 | .#*.rkt 7 | 8 | *.ss~ 9 | *.ss#* 10 | .#*.ss 11 | 12 | *.scm~ 13 | *.scm#* 14 | .#*.scm 15 | *.rktd 16 | *.rktd 17 | *.html 18 | *.sxref 19 | tests/smol-fun-tests.rkt 20 | tests/smol-hof-tests.rkt 21 | tests/smol-local-tests.rkt 22 | tests/smol-state-tests.rkt 23 | tests/smol-fun-tests.rkt 24 | tests/smol-hof-tests.rkt 25 | tests/smol-local-tests.rkt 26 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | (define collection "stacker") 3 | (define deps '("base" "plait" "pict-lib" "pprint" "gui-lib" "draw-lib" "redex-gui-lib" "sandbox-lib" "testing-util-lib" "rackunit-lib")) 4 | (define build-deps '("scribble-lib" "racket-doc" "rackunit-lib")) 5 | (define scribblings '(("scribblings/stacker.scrbl" ()))) 6 | (define pkg-desc "Description Here") 7 | (define version "0.0") 8 | (define pkg-authors '(lukc)) 9 | (define license '(Apache-2.0 OR MIT)) 10 | -------------------------------------------------------------------------------- /error.rkt: -------------------------------------------------------------------------------- 1 | #lang plait 2 | 3 | (require (rename-in 4 | (typed-in "./error-racket.rkt" 5 | [catch : ((-> 'a) ('error -> 'a) -> 'a)]) 6 | [catch raw-catch])) 7 | (require (rename-in 8 | (typed-in racket 9 | [raise : ('a -> 'b)]) 10 | [raise raw-raise])) 11 | 12 | (define-type Exception 13 | (exn-tc [msg : String]) 14 | (exn-rt [msg : String]) 15 | (exn-internal [where : Symbol] [what : String])) 16 | 17 | (define (raise [e : Exception]) : 'a 18 | (raw-raise e)) 19 | (define (catch [main : (-> 'a)] [handle : (Exception -> 'a)]) : 'a 20 | (raw-catch main handle)) -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | on: [push, pull_request] 2 | name: CI 3 | jobs: 4 | build: 5 | name: "Build on Racket '${{ matrix.racket-version }}' (${{ matrix.racket-variant }})" 6 | runs-on: ubuntu-latest 7 | continue-on-error: ${{ matrix.experimental || false }} 8 | strategy: 9 | fail-fast: false 10 | matrix: 11 | racket-version: ["stable", "current"] 12 | racket-variant: ["BC", "CS"] 13 | include: 14 | - racket-version: current 15 | experimental: true 16 | steps: 17 | - uses: actions/checkout@v2 18 | - uses: Bogdanp/setup-racket@v1.7 19 | with: 20 | architecture: x64 21 | distribution: full 22 | variant: ${{ matrix.racket-variant }} 23 | version: ${{ matrix.racket-version }} 24 | - name: Installing stacker and its dependencies 25 | run: raco pkg install --no-docs --auto --name stacker 26 | - name: Compiling stacker and building its docs 27 | run: raco setup --check-pkg-deps --unused-pkg-deps stacker 28 | - name: Testing stacker 29 | run: raco test -x -p stacker 30 | -------------------------------------------------------------------------------- /smol/general-semantics.txt: -------------------------------------------------------------------------------- 1 | (provide (rename-out [my-module-begin #%module-begin]) 2 | (rename-out [my-top-interaction #%top-interaction])) 3 | 4 | (require "../../s-exp-of-state.rkt") 5 | (require "../../pict-of-state.rkt") 6 | (require "../../parse.rkt") 7 | (require "../../runtime.rkt") 8 | 9 | (define (my-pict-of-state state) 10 | ((;(dynamic-require "../../pict-of-state.rkt" 'pict-of-state) 11 | pict-of-state 12 | hide-closure? 13 | hide-env-label?) 14 | ((s-exp-of-state hide-fun-addr? defvar-lambda-as-deffun? set!-lambda-as-def? set!-other-as-def?) state))) 15 | 16 | (define (run tracing? e) 17 | (define check void) 18 | (eval tracing? enable-tco? check my-pict-of-state (parse e))) 19 | 20 | (define-syntax (my-module-begin stx) 21 | (syntax-case stx () 22 | [(_ #:no-trace form ...) 23 | #'(#%module-begin (run #f '(form ...)))] 24 | [(_ form ...) 25 | #'(#%module-begin (run #t '(form ...)))])) 26 | 27 | (define-syntax (my-top-interaction stx) 28 | (syntax-case stx () 29 | [(_ . form) 30 | #'(#%top-interaction . (displayln "Please run programs in the editor window."))])) 31 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2022 Lu, Kuang-Chen 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /LICENSE-MIT: -------------------------------------------------------------------------------- 1 | stacker 2 | 3 | MIT License 4 | 5 | Copyright (c) 2022 lukc 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a copy 8 | of this software and associated documentation files (the "Software"), to deal 9 | in the Software without restriction, including without limitation the rights 10 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 11 | copies of the Software, and to permit persons to whom the Software is 12 | furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in all 15 | copies or substantial portions of the Software. 16 | 17 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 18 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 19 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 20 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 21 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 22 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 23 | SOFTWARE. 24 | -------------------------------------------------------------------------------- /utilities.rkt: -------------------------------------------------------------------------------- 1 | #lang plait 2 | 3 | (require (rename-in (typed-in racket [format : (String 'a -> String)]) 4 | [format raw-format])) 5 | 6 | (define-syntax let-values 7 | (syntax-rules () 8 | [(let-values (((x ...) e)) body) 9 | (let ([tmp e]) 10 | (local ((define-values (x ...) tmp)) 11 | body))])) 12 | 13 | (define (displayln x) 14 | (begin 15 | (display x) 16 | (display "\n"))) 17 | 18 | (define (string-of any) 19 | (format "~a" any)) 20 | 21 | (define (string-join t s*) 22 | (ind-List s* 23 | "" 24 | (lambda (_IH s) 25 | (let ([string*-of-s* (map (lambda (s) (string-append t s)) s*)]) 26 | (string-append s 27 | (ind-List string*-of-s* 28 | "" 29 | (lambda (IH elm) 30 | (string-append elm IH)))))))) 31 | 32 | (define (format template datum) 33 | (raw-format template datum)) 34 | 35 | (define (ind-List (x* : (Listof 'a)) (base : 'b) (step : ('b 'a -> 'b))) 36 | (foldr (λ (x IH) (step IH x)) base x*)) 37 | 38 | 39 | (define (hash-set* base ⟨k×v⟩*) 40 | (ind-List ⟨k×v⟩* 41 | base 42 | (λ (IH ⟨k×v⟩) 43 | (hash-set IH (fst ⟨k×v⟩) (snd ⟨k×v⟩))))) 44 | 45 | (define (hash-ref* h k*) 46 | (hash-set* (hash (list)) 47 | (map (lambda (k) 48 | (values k (some-v (hash-ref h k)))) 49 | k*))) 50 | 51 | (define-type (Dec 'x 'y) 52 | (yes [it : 'x]) 53 | (no [it : 'y])) 54 | (define (get-last xs) 55 | (type-case (Listof 'x) (reverse xs) 56 | (empty 57 | (no (values))) 58 | ((cons x xs) 59 | (yes (values (reverse xs) x))))) -------------------------------------------------------------------------------- /io.rkt: -------------------------------------------------------------------------------- 1 | #lang plait 2 | (define-type-alias Id Symbol) 3 | 4 | (define-type Constant 5 | (c-void) 6 | (c-str [it : String]) 7 | (c-num [it : Number]) 8 | (c-bool [it : Boolean]) 9 | (c-char [it : Char]) 10 | (c-vec [it : (Listof Constant)]) 11 | (c-list [it : (Listof Constant)])) 12 | (define-type-alias Program ((Listof Def) * (Listof Expr))) 13 | (define (program d* e*) (pair d* e*)) 14 | (define-type Def 15 | [d-fun [fun : Id] [arg* : (Listof Id)] 16 | [def* : (Listof Def)] 17 | [prelude* : (Listof Expr)] 18 | [result : Expr]] 19 | [d-var [var : Id] [val : Expr]]) 20 | (define-type Expr 21 | (e-con [c : Constant]) 22 | (e-var [x : Id]) 23 | (e-fun [arg* : (Listof Id)] 24 | [def* : (Listof Def)] 25 | [prelude* : (Listof Expr)] 26 | [result : Expr]) 27 | (e-app [fun : Expr] [arg* : (Listof Expr)]) 28 | (e-let [bind* : (Listof Bind)] 29 | [def* : (Listof Def)] 30 | [prelude* : (Listof Expr)] 31 | [result : Expr]) 32 | (e-let* [bind* : (Listof Bind)] 33 | [def* : (Listof Def)] 34 | [prelude* : (Listof Expr)] 35 | [result : Expr]) 36 | (e-letrec [bind* : (Listof Bind)] 37 | [def* : (Listof Def)] 38 | [prelude* : (Listof Expr)] 39 | [result : Expr]) 40 | (e-set! [var : Id] [val : Expr]) 41 | (e-begin [prelude* : (Listof Expr)] [result : Expr]) 42 | (e-if [cnd : Expr] [thn : Expr] [els : Expr]) 43 | (e-cond [cnd-thn* : (Listof (Expr * Expr))] [els : (Optionof Expr)])) 44 | (define (bind x e) (values x e)) 45 | (define-type-alias Bind (Id * Expr)) 46 | (define (var-of-bind bind) (fst bind)) 47 | (define (val-of-bind bind) (snd bind)) 48 | (define-type Obs 49 | (o-void) 50 | (o-con [it : Constant]) 51 | (o-vec [it : (Vectorof Obs)]) 52 | (o-list [it : (Listof Obs)]) 53 | (o-fun [it : (Optionof String)]) 54 | (o-rec [id : Number] [content : Obs]) 55 | (o-var [id : Number]) 56 | (o-exn [it : String])) 57 | -------------------------------------------------------------------------------- /show.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | ;; input/output 3 | 4 | (provide string-of-o) 5 | (require "io.rkt") 6 | (require (only-in plait some-v some?)) 7 | 8 | (define (string-of-o o) 9 | (cond 10 | [(o-exn? o) 11 | (format 12 | "error: please run the same program under `#lang smol/hof` for details." 13 | #;(o-exn-it o))] 14 | [(o-con? o) (string-of-c (o-con-it o))] 15 | [(o-vec? o) (format "'#(~a)" (string-join (vector->list (vector-map string-of-o-internal (o-vec-it o))) " "))] 16 | [(o-list? o) (format "'(~a)" (string-join (map string-of-o-internal (o-list-it o)) " "))] 17 | [(o-fun? o) 18 | #; 19 | (if (some? (o-fun-it o)) 20 | (some-v (o-fun-it o)) 21 | "#") 22 | (if (some? (o-fun-it o)) 23 | (format "#" (some-v (o-fun-it o))) 24 | "#")] 25 | [(o-void? o) "#"] 26 | [(o-rec? o) (format "#~a=~a" (o-rec-id o) (string-of-o (o-rec-content o)))] 27 | [(o-var? o) (format "#~a#" (o-var-id o))] 28 | [else 29 | (displayln o) 30 | (displayln (o-rec? o)) 31 | (error 'show "internal error ~a" o)])) 32 | (define (string-of-o-internal o) 33 | (cond 34 | [(o-con? o) (string-of-c (o-con-it o))] 35 | [(o-vec? o) (format "#(~a)" (string-join (vector->list (vector-map string-of-o-internal (o-vec-it o))) " "))] 36 | [(o-list? o) (format "(~a)" (string-join (map string-of-o-internal (o-list-it o)) " "))] 37 | [(o-fun? o) "#"] 38 | [(o-void? o) "#"] 39 | [(o-rec? o) (format "#~a=~a" (o-rec-id o) (string-of-o-internal (o-rec-content o)))] 40 | [(o-var? o) (format "#~a#" (o-var-id o))] 41 | [else (error 'show "internal error ~a" o)])) 42 | (define (string-of-c c) 43 | (define p (open-output-string)) 44 | (write (pre-string-of-c c) p) 45 | (get-output-string p)) 46 | (define (pre-string-of-c c) 47 | (cond 48 | [(c-str? c) (c-str-it c)] 49 | [(c-num? c) (c-num-it c)] 50 | [(c-bool? c) (c-bool-it c)] 51 | [else (error 'show "internal error" c)])) 52 | -------------------------------------------------------------------------------- /string-of-state.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide string-of-s-exp block) 3 | (require pprint) 4 | 5 | (define block (gensym 'block)) 6 | 7 | (define (string-of-s-exp e) 8 | (pretty-format (doc-of-s-exp e) 17)) 9 | (define (doc-of-s-exp e) 10 | (match e 11 | [`(,maybe-block ,@body) 12 | #:when (eqv? maybe-block block) 13 | (apply v-append (map doc-of-s-exp body))] 14 | [`(quote ,e) 15 | (align (h-append (text "'") (doc-of-s-exp e) (text "")))] 16 | [`(,defvar/set! ,x ,e) 17 | #:when (memv defvar/set! '(defvar defvar-1 set!)) 18 | (align 19 | (nest 2 (vs-append (h-append (text (format "(~a " defvar/set!)) (doc-of-s-exp x)) 20 | (h-append (doc-of-s-exp e) (text ")")))))] 21 | [`(,deffun? ,head ,@body) 22 | #:when (memv deffun? '(deffun deffun-1 define)) 23 | (align 24 | (nest 2 (vs-append (h-append (text (format "(~a " deffun?)) (doc-of-s-exp head)) 25 | (h-append (vs-concat (map doc-of-s-exp body)) (text ")")))))] 26 | [`(cond ,@cases) 27 | (align (h-append 28 | (text "(cond") 29 | (nest 2 30 | (h-append 31 | line 32 | (v-concat (map doc-of-case cases)) 33 | (text ")")))))] 34 | [`(begin ,e) 35 | (doc-of-s-exp e)] 36 | [`(begin ,@e*) 37 | (align 38 | (nest 2 (v-append (text "(begin ") 39 | (h-append (v-concat (map doc-of-s-exp e*)) (text ")")))))] 40 | [`(lambda (,@arg*) ,body) 41 | (align (nest 2 (v-append (h-append (text "(lambda ") (doc-of-s-exp arg*)) 42 | (h-append (doc-of-s-exp body) 43 | (text ")")))))] 44 | [`(if ,cnd ,thn ,els) 45 | (align (h-append (text "(if ") 46 | (align (v-append (doc-of-s-exp cnd) 47 | (doc-of-s-exp thn) 48 | (doc-of-s-exp els))) 49 | (text ")")))] 50 | [else 51 | (if (list? e) 52 | (h-append (text "(") (apply hs-append (map doc-of-s-exp e)) (text ")")) 53 | (let* ([p (open-output-string)] 54 | [_ (write e p)]) 55 | (text (get-output-string p))))])) 56 | (define (doc-of-case case) 57 | ;;; (match-define `(,cnd ,@cont) case) 58 | (h-append 59 | (text "[") 60 | (align 61 | (v-concat (map doc-of-s-exp case))) 62 | (text "]"))) -------------------------------------------------------------------------------- /tests/randomized-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "./utilities.rkt") 3 | (require redex) 4 | 5 | ;; KC: honestly I find the randomized test not very useful because distribution of programs is not 6 | ;; very good. 7 | 8 | (define-language smol/hof 9 | (program 10 | ::= (def ... expr ...)) 11 | (def 12 | ::= (defvar id expr) 13 | (deffun (id_fun id_arg ...) def ... expr ... expr)) 14 | (expr 15 | ::= id 16 | constant 17 | (if expr expr expr) 18 | (lambda (id ...) def ... expr ... expr) 19 | (λ (id ...) def ... expr ... expr) 20 | (let ((id expr) ...) def ... expr ... expr) 21 | (letrec ((id expr) ...) def ... expr ... expr) 22 | (begin expr ... expr) 23 | (o1 expr) 24 | (o2 expr expr) 25 | (o3 expr expr expr) 26 | (o* expr ...) 27 | (expr expr ...)) 28 | (constant 29 | ::= 30 | string 31 | number 32 | ;;; have to disable this because redex doesn't understand #() 33 | ;; #(datum ...) 34 | (quote (datum ...))) 35 | (datum 36 | ::= 37 | string 38 | number 39 | ;;; have to disable this because redex doesn't understand #() 40 | ;;; #(datum ...) 41 | (datum ...)) 42 | (o1 43 | ::= 44 | left 45 | right 46 | vec-len) 47 | (o2 48 | ::= 49 | equal? 50 | + 51 | - 52 | * 53 | mpair 54 | set-left! 55 | set-right! 56 | vec-ref 57 | cons 58 | map 59 | filter) 60 | (o3 61 | ::= 62 | vec-set! 63 | ;;; foldl 64 | ;;; foldr 65 | ) 66 | (o* 67 | ::= 68 | mvec 69 | list) 70 | (id 71 | ::= 72 | ;; they creates too many spam tests 73 | ;;; empty 74 | ;;; o1 75 | ;;; o2 76 | ;;; o3 77 | ;;; o* 78 | variable-not-otherwise-mentioned)) 79 | 80 | (define gen (generate-term smol/hof program)) 81 | (define (run-test n) 82 | (for ([i (in-range n)]) 83 | (let ([program (generate-term smol/hof program #:i-th i)]) 84 | (test-equivalent program)))) 85 | (run-test 1000) 86 | 87 | ;;; (define-metafunction smol/hof 88 | ;;; smol-agree-with-smol-step : program -> boolean 89 | ;;; [(smol-agree-with-smol-step program) 90 | ;;; ,(let* ([oe-standard (eval-in-smol (term program))] 91 | ;;; [oe-step (eval-in-smol-step (term program))] 92 | ;;; [r (equal? oe-standard oe-step)]) 93 | ;;; (begin 94 | ;;; (when (not r) 95 | ;;; (displayln "! Program") 96 | ;;; (writeln (term program)) 97 | ;;; (displayln "!! Output differs (smol vs smol-step)") 98 | ;;; (writeln oe-standard) 99 | ;;; (writeln oe-step)) 100 | ;;; r))]) 101 | 102 | ;;; (redex-check smol/hof 103 | ;;; program 104 | ;;; (term (smol-agree-with-smol-step program)) 105 | ;;; #:attempts 100) -------------------------------------------------------------------------------- /pict-loop.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide pict-loop) 3 | (require pict) 4 | (require racket/gui) 5 | 6 | (define-values (forward! 7 | backward! 8 | what-is-now 9 | add-future 10 | has-past? 11 | has-future?) 12 | (let ([past '()] 13 | [future '()] 14 | [now #f]) 15 | (values 16 | (lambda () 17 | (if (and now (pair? future)) 18 | (begin 19 | (set! past (cons now past)) 20 | (set! now (car future)) 21 | (set! future (cdr future))) 22 | (error 'forward-into-nowhere))) 23 | (lambda () 24 | (if (and now (pair? past)) 25 | (begin 26 | (set! future (cons now future)) 27 | (set! now (car past)) 28 | (set! past (cdr past))) 29 | (error 'backward-into-nowhere))) 30 | (lambda () now) 31 | (lambda (item) 32 | (cond 33 | [(not now) 34 | (set! now item) 35 | now] 36 | [(empty? future) 37 | (set! future (cons item future)) 38 | (forward!)] 39 | [else 40 | (error 'pict-manager)])) 41 | (lambda () 42 | (pair? past)) 43 | (lambda () 44 | (pair? future))))) 45 | 46 | 47 | 48 | (define (pict-loop state terminate? forward pict-of-state) 49 | (define the-frame (new frame% [label "Stacker"])) 50 | (send the-frame create-status-line) 51 | (define button-panel 52 | (new horizontal-panel% 53 | [parent the-frame])) 54 | (define the-canvas 55 | (new canvas% 56 | [parent the-frame] 57 | [paint-callback 58 | (lambda (canvas dc) 59 | (let ([current-pict (what-is-now)]) 60 | (when current-pict 61 | (send dc clear) 62 | (send canvas min-width (add1 (inexact->exact (ceiling (pict-width current-pict))))) 63 | (send canvas min-height (add1 (inexact->exact (ceiling (pict-height current-pict))))) 64 | (send the-prev-button enable (has-past?)) 65 | (send the-next-button enable (or (has-future?) (not (terminate? state)))) 66 | (send the-frame set-status-text (if (terminate? state) "terminated" "still running")) 67 | (send the-frame resize 10 10) 68 | (draw-pict current-pict dc 1 1))))])) 69 | (define the-prev-button 70 | (new button% 71 | [label "Previous"] 72 | [parent button-panel] 73 | [callback 74 | (lambda (_button _event) 75 | (let ([item (backward!)]) 76 | (send the-frame refresh)))])) 77 | (define the-next-button 78 | (new button% 79 | [label "Next"] 80 | [parent button-panel] 81 | [callback 82 | (lambda (_button _event) 83 | (if (has-future?) 84 | (forward!) 85 | (unless (terminate? state) 86 | (step!))) 87 | (send the-frame refresh))])) 88 | (define (step!) 89 | (set! state (forward state)) 90 | (add-future (pict-of-state state))) 91 | (add-future (pict-of-state state)) 92 | (send the-frame show #t)) -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # stacker 2 | 3 | **⚠️⚠️⚠️ This (DrRacket-based) stacker has been superseded by a new, web-based stacker ⚠️⚠️⚠️** 4 | > https://github.com/LuKuangChen/stacker-2023 5 | 6 | ----- 7 | 8 | Another implementation of smol. This implementation presents the execution with a stack-based model. 9 | 10 | ## How to install, update, and uninstall 11 | 12 | Please follow these instructions to **install** or **update** 13 | 14 | 1. Make sure you are in the `DrRacket` app. 15 | 2. Go to the menu `File` | `Package Manager...`. A window will pop up. 16 | 3. Make sure you are in the `Do What I Mean` tab of the pop-up window. 17 | 4. Set the `Package Source` field to `Stacker` (or `https://github.com/LuKuangChen/stacker.git`) 18 | 5. Click the `Show Details` button. 19 | 6. Set the `Dependencies Mode` field to `Auto`. 20 | 7. Click the `Install` button. (If you have already installed, you will see "Update" instead of "Install".) Most buttons will grey out immediately (except the `Abort Install`). 21 | 8. After the color of those buttons comes back, you can close the pop-up window. This usually takes less than 1 min. 22 | 23 | Alternatively, you if the `raco` tool is availabe, you can install by running `raco pkg install Stacker`. 24 | 25 | To **uninstall** 26 | 27 | 1. Make sure you are in the `DrRacket` app. 28 | 2. Go to the menu `File` | `Package Manager...`. A window will pop up. 29 | 3. Make sure you are in the `Currently Installed` tab of the pop-up window. 30 | 4. Set the `Filter` field to `stacker`. 31 | 5. Select the first result. 32 | 6. Click the `Remove` button. A confirmation window will pop up. 33 | 7. Click the `Remove` button in the confirmation window. Most buttons will grey out immediately (except the `Abort Install`). 34 | 8. After the color of those buttons comes back, you can close the pop-up window. This usually takes less than 1 min. 35 | 36 | ## How to test whether an installation is successful? 37 | 38 | First, make sure you are in the Racket language: 39 | 40 | 1. Make sure you are in the `DrRacket` app. 41 | 2. Go to the menu `Language` | `Choose Language...`. A window will pop up. 42 | 3. Select `The Racket Language`. 43 | 4. Click the `OK` button. 44 | 45 | Run the following program in DrRacket 46 | 47 | ```racket 48 | #lang stacker/smol/hof 49 | 50 | (defvar x 2) 51 | (defvar y 3) 52 | (+ x y) 53 | ``` 54 | 55 | You should see a screenshot like this. 56 | 57 | image 58 | 59 | ## Usage 60 | 61 | Usually, you will use the Stacker like other Racket `#lang`s. 62 | 63 | ``` 64 | #lang stacker/smol/hof 65 | 66 | (deffun (fact n) 67 | (if (zero? n) 68 | 1 69 | (* (fact (- n 1)) n))) 70 | (fact 3) 71 | ``` 72 | 73 | If you *only* want to see the (final) result, you can ask the stacker not to show the stack+heap configurations (note the second line). 74 | This way you don't need to click through the configurations and hence can see the result sooner. 75 | 76 | ``` 77 | #lang stacker/smol/hof 78 | #:no-trace 79 | 80 | (deffun (fact n) 81 | (if (zero? n) 82 | 1 83 | (* (fact (- n 1)) n))) 84 | (fact 3) 85 | ``` 86 | 87 | ## Language Levels 88 | 89 | 1. `fun` 90 | 2. `state` adds mutable variables and mutable vectors 91 | 3. `hof` adds first-class functions and `let{,rec,*}` 92 | 93 | ## Grammar 94 | 95 | Here is a glossary of `smol` grammar, where `d` stands for definitions, `e` stands for expressions, `c` stands for constants, and `x` and `f` are identifiers (variables). 96 | 97 | ``` 98 | d ::= (defvar x e) 99 | | (deffun (f x ...) body) 100 | e ::= c 101 | | x 102 | | (lambda (x ...) body) 103 | | (λ (x ...) body) 104 | | (let ([x e] ...) body) 105 | | (letrec ([x e] ...) body) 106 | | (let* ([x e] ...) body) 107 | | (begin e ... e) 108 | | (set! x e) 109 | | (if e e e) 110 | | (cond [e e] ... [else e]) 111 | | (cond [e e] ...) 112 | | (e e ...) 113 | 114 | body ::= d ... e ... e 115 | program ::= d ... e ... 116 | ``` 117 | -------------------------------------------------------------------------------- /tests/utilities.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide (all-defined-out)) 3 | (require racket/sandbox) 4 | 5 | (define (eval-in-stacker/smol program) 6 | (parameterize ([sandbox-output 'string] 7 | [sandbox-eval-limits (list 10 #f)] 8 | [sandbox-propagate-exceptions #f] 9 | (sandbox-path-permissions 10 | (list* 11 | (list 'exists "/lib64") 12 | (list 'exists "/usr/lib64") 13 | (list 'exists (current-directory)) 14 | (list 'exists "/System") 15 | (sandbox-path-permissions)))) 16 | (define ev (make-module-evaluator 17 | `(module m stacker/smol/hof/semantics 18 | #:no-trace 19 | ,@program))) 20 | (normalize (get-output ev)))) 21 | 22 | (define (eval-in-smol program) 23 | (define port (open-output-string)) 24 | (parameterize ([sandbox-output port] 25 | [sandbox-eval-limits (list 10 #f)] 26 | [sandbox-propagate-exceptions #f]) 27 | ;; sandbox-propagate-exceptions fails to catch some errors (e.g. `(defvar equal? equal?)`) 28 | (with-handlers ([any/c (lambda (e) "error")]) 29 | (define ev (make-module-evaluator 30 | `(module m smol/hof/semantics 31 | ,@program))) 32 | (normalize (get-output-string port))))) 33 | 34 | (define (test-equivalent program) 35 | (displayln ";; Program") 36 | (writeln program) 37 | (with-handlers ([(lambda (_) #f) 38 | (lambda (e) 39 | (displayln ";; exception") 40 | (displayln e) 41 | (newline))]) 42 | (let* ([oe-standard (eval-in-smol program)] 43 | [oe-step (eval-in-stacker/smol program)]) 44 | (cond 45 | [(not (equal? oe-standard oe-step)) 46 | (displayln "-----------------------------") 47 | (displayln ";; smol") 48 | (writeln oe-standard) 49 | (displayln "-----------------------------") 50 | (displayln ";; stacker/smol") 51 | (writeln oe-step)] 52 | [else 53 | (display "Both smol and stacker output: ") 54 | (writeln oe-standard)]))) 55 | (newline)) 56 | 57 | (define (test-expect/smol program expect) 58 | (with-handlers ([any/c (lambda (e) 59 | (displayln ";; exception") 60 | (displayln e) 61 | (newline))]) 62 | (let* ([result (eval-in-smol program)] 63 | [expect (normalize-expect expect)] 64 | [r (equal? result expect)]) 65 | (when (not r) 66 | (begin 67 | (displayln ";; Program") 68 | (writeln program) 69 | (displayln "-----------------------------") 70 | (displayln ";; smol actual") 71 | (writeln result) 72 | (displayln ";; expected") 73 | (writeln expect) 74 | (newline)))))) 75 | 76 | (define (test-expect/stacker/smol program expect) 77 | (with-handlers ([any/c (lambda (e) 78 | (displayln ";; exception") 79 | (displayln e) 80 | (newline))]) 81 | (let* ([result (eval-in-stacker/smol program)] 82 | [r (equal? result (normalize-expect expect))]) 83 | (when (not r) 84 | (begin 85 | (displayln ";; Program") 86 | (writeln program) 87 | (displayln "-----------------------------") 88 | (displayln ";; stacker/smol actual") 89 | (writeln result) 90 | (displayln ";; expected") 91 | (writeln expect) 92 | (newline)))))) 93 | 94 | (define (normalize output) 95 | ((compose 96 | (lambda (output) 97 | (regexp-replace* #rx" $" output "")) 98 | (lambda (output) 99 | (regexp-replace* #rx"\n" output " ")) 100 | (lambda (output) 101 | (regexp-replace* #rx"#" output "#")) 102 | (lambda (output) 103 | (regexp-replace* #rx"error:[^\n]*" output "error")) 104 | ) 105 | output)) 106 | 107 | (define (normalize-expect expect) 108 | (string-append expect "")) -------------------------------------------------------------------------------- /doc/racket.css: -------------------------------------------------------------------------------- 1 | 2 | /* See the beginning of "scribble.css". */ 3 | 4 | /* Monospace: */ 5 | .RktIn, .RktRdr, .RktPn, .RktMeta, 6 | .RktMod, .RktKw, .RktVar, .RktSym, 7 | .RktRes, .RktOut, .RktCmt, .RktVal, 8 | .RktBlk { 9 | font-family: monospace; 10 | white-space: inherit; 11 | } 12 | 13 | /* Serif: */ 14 | .inheritedlbl { 15 | font-family: serif; 16 | } 17 | 18 | /* Sans-serif: */ 19 | .RBackgroundLabelInner { 20 | font-family: sans-serif; 21 | } 22 | 23 | /* ---------------------------------------- */ 24 | /* Inherited methods, left margin */ 25 | 26 | .inherited { 27 | width: 100%; 28 | margin-top: 0.5em; 29 | text-align: left; 30 | background-color: #ECF5F5; 31 | } 32 | 33 | .inherited td { 34 | font-size: 82%; 35 | padding-left: 1em; 36 | text-indent: -0.8em; 37 | padding-right: 0.2em; 38 | } 39 | 40 | .inheritedlbl { 41 | font-style: italic; 42 | } 43 | 44 | /* ---------------------------------------- */ 45 | /* Racket text styles */ 46 | 47 | .RktIn { 48 | color: #cc6633; 49 | background-color: #eeeeee; 50 | } 51 | 52 | .RktInBG { 53 | background-color: #eeeeee; 54 | } 55 | 56 | .RktRdr { 57 | } 58 | 59 | .RktPn { 60 | color: #843c24; 61 | } 62 | 63 | .RktMeta { 64 | color: black; 65 | } 66 | 67 | .RktMod { 68 | color: black; 69 | } 70 | 71 | .RktOpt { 72 | color: black; 73 | font-style: italic; 74 | } 75 | 76 | .RktKw { 77 | color: black; 78 | } 79 | 80 | .RktErr { 81 | color: red; 82 | font-style: italic; 83 | } 84 | 85 | .RktVar { 86 | color: #262680; 87 | font-style: italic; 88 | } 89 | 90 | .RktSym { 91 | color: #262680; 92 | } 93 | 94 | .RktSymDef { /* used with RktSym at def site */ 95 | } 96 | 97 | .RktValLink { 98 | text-decoration: none; 99 | color: blue; 100 | } 101 | 102 | .RktValDef { /* used with RktValLink at def site */ 103 | } 104 | 105 | .RktModLink { 106 | text-decoration: none; 107 | color: blue; 108 | } 109 | 110 | .RktStxLink { 111 | text-decoration: none; 112 | color: black; 113 | } 114 | 115 | .RktStxDef { /* used with RktStxLink at def site */ 116 | } 117 | 118 | .RktRes { 119 | color: #0000af; 120 | } 121 | 122 | .RktOut { 123 | color: #960096; 124 | } 125 | 126 | .RktCmt { 127 | color: #c2741f; 128 | } 129 | 130 | .RktVal { 131 | color: #228b22; 132 | } 133 | 134 | /* ---------------------------------------- */ 135 | /* Some inline styles */ 136 | 137 | .together { 138 | width: 100%; 139 | } 140 | 141 | .prototype, .argcontract, .RBoxed { 142 | white-space: nowrap; 143 | } 144 | 145 | .prototype td { 146 | vertical-align: text-top; 147 | } 148 | 149 | .RktBlk { 150 | white-space: inherit; 151 | text-align: left; 152 | } 153 | 154 | .RktBlk tr { 155 | white-space: inherit; 156 | } 157 | 158 | .RktBlk td { 159 | vertical-align: baseline; 160 | white-space: inherit; 161 | } 162 | 163 | .argcontract td { 164 | vertical-align: text-top; 165 | } 166 | 167 | .highlighted { 168 | background-color: #ddddff; 169 | } 170 | 171 | .defmodule { 172 | width: 100%; 173 | background-color: #F5F5DC; 174 | } 175 | 176 | .specgrammar { 177 | float: right; 178 | } 179 | 180 | .RBibliography td { 181 | vertical-align: text-top; 182 | } 183 | 184 | .leftindent { 185 | margin-left: 1em; 186 | margin-right: 0em; 187 | } 188 | 189 | .insetpara { 190 | margin-left: 1em; 191 | margin-right: 1em; 192 | } 193 | 194 | .Rfilebox { 195 | } 196 | 197 | .Rfiletitle { 198 | text-align: right; 199 | margin: 0em 0em 0em 0em; 200 | } 201 | 202 | .Rfilename { 203 | border-top: 1px solid #6C8585; 204 | border-right: 1px solid #6C8585; 205 | padding-left: 0.5em; 206 | padding-right: 0.5em; 207 | background-color: #ECF5F5; 208 | } 209 | 210 | .Rfilecontent { 211 | margin: 0em 0em 0em 0em; 212 | } 213 | 214 | .RpackageSpec { 215 | padding-right: 0.5em; 216 | } 217 | 218 | /* ---------------------------------------- */ 219 | /* For background labels */ 220 | 221 | .RBackgroundLabel { 222 | float: right; 223 | width: 0px; 224 | height: 0px; 225 | } 226 | 227 | .RBackgroundLabelInner { 228 | position: relative; 229 | width: 25em; 230 | left: -25.5em; 231 | top: 0px; 232 | text-align: right; 233 | color: white; 234 | z-index: 0; 235 | font-weight: bold; 236 | } 237 | 238 | .RForeground { 239 | position: relative; 240 | left: 0px; 241 | top: 0px; 242 | z-index: 1; 243 | } 244 | 245 | /* ---------------------------------------- */ 246 | /* History */ 247 | 248 | .SHistory { 249 | font-size: 82%; 250 | } 251 | -------------------------------------------------------------------------------- /doc/smol-step/index.html: -------------------------------------------------------------------------------- 1 | 2 | smol-step
•smol-step
smol-step
8.5
  top  contents  ← prev  up  next → 

smol-step

lukc

 (require smol-step) package: smol-step

Package Description Here

  top  contents  ← prev  up  next → 
 
-------------------------------------------------------------------------------- /parse.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide parse) 3 | (require "io.rkt") 4 | (require syntax/parse) 5 | (require (only-in plait pair some none)) 6 | 7 | (define-syntax-class constant 8 | (pattern x:string) 9 | (pattern x:number) 10 | (pattern x:boolean) 11 | (pattern x:char) 12 | (pattern #(c:literal ...)) 13 | (pattern ((~datum quote) #(c:literal ...))) 14 | (pattern ((~datum quote) (c:literal ...)))) 15 | (define-syntax-class literal 16 | (pattern x:string) 17 | (pattern x:number) 18 | (pattern x:boolean) 19 | (pattern x:char) 20 | (pattern #(c:literal ...)) 21 | (pattern #(c:literal ...)) 22 | (pattern (c:literal ...))) 23 | (define-syntax-class d 24 | (pattern ((~datum defvar) x:identifier e:e)) 25 | (pattern ((~datum deffun) (x1:identifier x2:identifier ...) d1:d ... e1:e ... e2:e))) 26 | (define-syntax-class e 27 | (pattern x:identifier) 28 | (pattern ((~datum lambda) (x:identifier ...) d:d ... e1:e ... e2:e)) 29 | (pattern ((~datum λ) (x:identifier ...) d:d ... e1:e ... e2:e)) 30 | (pattern (e1:e e2:e ...)) 31 | (pattern ((~datum let) ([x:identifier e1:e] ...) d:d ... e2:e ... e3:e)) 32 | (pattern ((~datum let*) ([x:identifier e1:e] ...) d:d ... e2:e ... e3:e)) 33 | (pattern ((~datum letrec) ([x:identifier e1:e] ...) d:d ... e2:e ... e3:e)) 34 | (pattern ((~datum begin) e1:e ... e2:e)) 35 | (pattern ((~datum set!) x:identifier e)) 36 | (pattern ((~datum if) e1:e e2:e e3:e)) 37 | (pattern ((~datum cond) [cnd:e when-cond:e] ... [(~datum else) when-else:e])) 38 | (pattern ((~datum cond) [cnd:e when-cond:e] ...)) 39 | (pattern c:constant)) 40 | (define-syntax-class p 41 | (pattern (d:d ... e:e ...))) 42 | 43 | (define (parse prog) 44 | (syntax-parse prog 45 | [(d:d ... e:e ...) 46 | (program (parse-d* #'(d ...)) 47 | (parse-e* #'(e ...)))])) 48 | (define (parse-x* x*) (map parse-x (syntax-e x*))) 49 | (define (parse-x x) (syntax->datum x)) 50 | (define (parse-e* expr*) 51 | (map parse-e (syntax-e expr*))) 52 | (define (parse-x&e* x&e*) 53 | (map parse-x&e (syntax-e x&e*))) 54 | (define (parse-e&e* e&e*) 55 | (map parse-e&e (syntax-e e&e*))) 56 | (define (parse-x&e x&e) 57 | (syntax-parse x&e 58 | [[x:id e:e] 59 | (bind (parse-x #'x) 60 | (parse-e #'e))])) 61 | (define (parse-e&e e&e) 62 | (syntax-parse e&e 63 | [[e1:e e2:e] 64 | (pair (parse-e #'e1) 65 | (parse-e #'e2))])) 66 | (define (parse-d* d) 67 | (map parse-d (syntax-e d))) 68 | (define (parse-d def) 69 | (syntax-parse def 70 | [((~datum defvar) x:id e:e) 71 | (d-var (parse-x #'x) (parse-e #'e))] 72 | [((~datum deffun) (x1:identifier x2:identifier ...) d:d ... e1:e ... e2:e) 73 | (d-fun (parse-x #'x1) 74 | (parse-x* #'(x2 ...)) 75 | (parse-d* #'(d ...)) 76 | (parse-e* #'(e1 ...)) 77 | (parse-e #'e2))])) 78 | (define (parse-e expr) 79 | (syntax-parse expr 80 | [((~datum lambda) (x:identifier ...) d:d ... e1:e ... e2:e) 81 | (e-fun (parse-x* #'(x ...)) 82 | (parse-d* #'(d ...)) 83 | (parse-e* #'(e1 ...)) 84 | (parse-e #'e2))] 85 | [((~datum λ) (x:identifier ...) d:d ... e1:e ... e2:e) 86 | (e-fun (parse-x* #'(x ...)) 87 | (parse-d* #'(d ...)) 88 | (parse-e* #'(e1 ...)) 89 | (parse-e #'e2))] 90 | [((~datum let) ([x:identifier e1:e] ...) d:d ... e2:e ... e3:e) 91 | (e-let (parse-x&e* #'([x e1] ...)) 92 | (parse-d* #'(d ...)) 93 | (parse-e* #'(e2 ...)) 94 | (parse-e #'e3))] 95 | [((~datum let*) ([x:identifier e1:e] ...) d:d ... e2:e ... e3:e) 96 | (e-let* (parse-x&e* #'([x e1] ...)) 97 | (parse-d* #'(d ...)) 98 | (parse-e* #'(e2 ...)) 99 | (parse-e #'e3))] 100 | [((~datum letrec) ([x:identifier e1:e] ...) d:d ... e2:e ... e3:e) 101 | (e-letrec (parse-x&e* #'([x e1] ...)) 102 | (parse-d* #'(d ...)) 103 | (parse-e* #'(e2 ...)) 104 | (parse-e #'e3))] 105 | [((~datum begin) e1:e ... e2:e) 106 | (e-begin (parse-e* #'(e1 ...)) 107 | (parse-e #'e2))] 108 | [((~datum set!) x:identifier e1:e) 109 | (e-set! (parse-x #'x) (parse-e #'e1))] 110 | [((~datum if) e1:e e2:e e3:e) 111 | (e-if (parse-e #'e1) (parse-e #'e2) (parse-e #'e3))] 112 | [((~datum cond) [cnd:e when-cond:e] ... [(~datum else) when-else:e]) 113 | (e-cond (parse-e&e* #'([cnd when-cond] ...)) 114 | (some (parse-e #'when-else)))] 115 | [((~datum cond) [cnd:e when-cond:e] ...) 116 | (e-cond (parse-e&e* #'([cnd when-cond] ...)) 117 | (none))] 118 | [((~datum quote) x:id) 119 | (e-con (parse-con #''x))] 120 | [c:constant 121 | (e-con (parse-con #'c))] 122 | [(e1:e e2:e ...) 123 | (e-app (parse-e #'e1) 124 | (parse-e* #'(e2 ...)))] 125 | [x:identifier 126 | (e-var (syntax->datum #'x))])) 127 | (define (parse-con con) 128 | (syntax-parse con 129 | [x:number 130 | (c-num (syntax-e #'x))] 131 | [x:boolean 132 | (c-bool (syntax-e #'x))] 133 | [x:char 134 | (c-char (syntax-e #'x))] 135 | [x:string 136 | (c-str (syntax-e #'x))] 137 | [((~datum quote) (x:literal ...)) 138 | (c-list (map parse-literal (syntax-e #'(x ...))))] 139 | [((~datum quote) #(x:literal ...)) 140 | (c-vec (map parse-literal (syntax-e #'(x ...))))] 141 | [#(x:literal ...) 142 | (c-vec (map parse-literal (syntax-e #'(x ...))))])) 143 | (define (parse-literal con) 144 | (syntax-parse con 145 | [x:number 146 | (c-num (syntax-e #'x))] 147 | [x:boolean 148 | (c-bool (syntax-e #'x))] 149 | [x:char 150 | (c-char (syntax-e #'x))] 151 | [x:string 152 | (c-str (syntax-e #'x))] 153 | [#(x:literal ...) 154 | (c-vec (map parse-literal (syntax-e #'(x ...))))] 155 | [(x:literal ...) 156 | (c-list (map parse-literal (syntax-e #'(x ...))))])) 157 | -------------------------------------------------------------------------------- /doc/scribble-common.js: -------------------------------------------------------------------------------- 1 | // Common functionality for PLT documentation pages 2 | 3 | // Page Parameters ------------------------------------------------------------ 4 | 5 | var page_query_string = location.search.substring(1); 6 | 7 | var page_args = 8 | ((function(){ 9 | if (!page_query_string) return []; 10 | var args = page_query_string.split(/[&;]/); 11 | for (var i=0; i= 0) args[i] = [a.substring(0,p), a.substring(p+1)]; 15 | else args[i] = [a, false]; 16 | } 17 | return args; 18 | })()); 19 | 20 | function GetPageArg(key, def) { 21 | for (var i=0; i= 0 && cur.substring(0,eql) == key) 78 | return unescape(cur.substring(eql+1)); 79 | } 80 | return def; 81 | } 82 | } 83 | 84 | function SetCookie(key, val) { 85 | try { 86 | localStorage[key] = val; 87 | } catch(e) { 88 | var d = new Date(); 89 | d.setTime(d.getTime()+(365*24*60*60*1000)); 90 | try { 91 | document.cookie = 92 | key + "=" + escape(val) + "; expires="+ d.toGMTString() + "; path=/"; 93 | } catch (e) {} 94 | } 95 | } 96 | 97 | // note that this always stores a directory name, ending with a "/" 98 | function SetPLTRoot(ver, relative) { 99 | var root = location.protocol + "//" + location.host 100 | + NormalizePath(location.pathname.replace(/[^\/]*$/, relative)); 101 | SetCookie("PLT_Root."+ver, root); 102 | } 103 | 104 | // adding index.html works because of the above 105 | function GotoPLTRoot(ver, relative) { 106 | var u = GetCookie("PLT_Root."+ver, null); 107 | if (u == null) return true; // no cookie: use plain up link 108 | // the relative path is optional, default goes to the toplevel start page 109 | if (!relative) relative = "index.html"; 110 | location = u + relative; 111 | return false; 112 | } 113 | 114 | // Utilities ------------------------------------------------------------------ 115 | 116 | var normalize_rxs = [/\/\/+/g, /\/\.(\/|$)/, /\/[^\/]*\/\.\.(\/|$)/]; 117 | function NormalizePath(path) { 118 | var tmp, i; 119 | for (i = 0; i < normalize_rxs.length; i++) 120 | while ((tmp = path.replace(normalize_rxs[i], "/")) != path) path = tmp; 121 | return path; 122 | } 123 | 124 | // `noscript' is problematic in some browsers (always renders as a 125 | // block), use this hack instead (does not always work!) 126 | // document.write(""); 127 | 128 | // Interactions --------------------------------------------------------------- 129 | 130 | function DoSearchKey(event, field, ver, top_path) { 131 | var val = field.value; 132 | if (event && event.key === 'Enter') { 133 | var u = GetCookie("PLT_Root."+ver, null); 134 | if (u == null) u = top_path; // default: go to the top path 135 | u += "search/index.html?q=" + encodeURIComponent(val); 136 | u = MergePageArgsIntoUrl(u); 137 | location = u; 138 | return false; 139 | } 140 | return true; 141 | } 142 | 143 | function TocviewToggle(glyph, id) { 144 | var s = document.getElementById(id).style; 145 | var expand = s.display == "none"; 146 | s.display = expand ? "block" : "none"; 147 | glyph.innerHTML = expand ? "▼" : "►"; 148 | } 149 | 150 | function TocsetToggle() { 151 | document.body.classList.toggle("tocsetoverlay"); 152 | } 153 | 154 | // Page Init ------------------------------------------------------------------ 155 | 156 | // Note: could make a function that inspects and uses window.onload to chain to 157 | // a previous one, but this file needs to be required first anyway, since it 158 | // contains utilities for all other files. 159 | var on_load_funcs = []; 160 | function AddOnLoad(fun) { on_load_funcs.push(fun); } 161 | window.onload = function() { 162 | for (var i=0; i tr:first-child > td > .together { 186 | border-top: 0px; /* erase border on first instance of together */ 187 | } 188 | 189 | .RktBlk { 190 | white-space: pre; 191 | text-align: left; 192 | } 193 | 194 | .highlighted { 195 | font-size: 1rem; 196 | background-color: #fee; 197 | } 198 | 199 | .defmodule { 200 | font-family: 'Fira-Mono', monospace; 201 | padding: 0.25rem 0.75rem 0.25rem 0.5rem; 202 | margin-bottom: 1rem; 203 | width: 100%; 204 | background-color: #ebf0f4; 205 | } 206 | 207 | .defmodule a { 208 | color: #444; 209 | } 210 | 211 | 212 | .defmodule td span.hspace:first-child { 213 | position: absolute; 214 | width: 0; 215 | display: inline-block; 216 | } 217 | 218 | .defmodule .RpackageSpec .Smaller, 219 | .defmodule .RpackageSpec .stt { 220 | font-size: 1rem; 221 | } 222 | 223 | /* make parens ordinary color in defmodule */ 224 | .defmodule .RktPn { 225 | color: inherit; 226 | } 227 | 228 | .specgrammar { 229 | float: none; 230 | padding-left: 1em; 231 | } 232 | 233 | 234 | .RBibliography td { 235 | vertical-align: text-top; 236 | padding-top: 1em; 237 | } 238 | 239 | .leftindent { 240 | margin-left: 2rem; 241 | margin-right: 0em; 242 | } 243 | 244 | .insetpara { 245 | margin-left: 1em; 246 | margin-right: 1em; 247 | } 248 | 249 | .SCodeFlow .Rfilebox { 250 | margin-left: -1em; /* see 17.2 of guide, module languages */ 251 | } 252 | 253 | .Rfiletitle { 254 | text-align: right; 255 | background-color: #eee; 256 | } 257 | 258 | .SCodeFlow .Rfiletitle { 259 | border-top: 1px dotted gray; 260 | border-right: 1px dotted gray; 261 | } 262 | 263 | 264 | .Rfilename { 265 | border-top: 0; 266 | border-right: 0; 267 | padding-left: 0.5em; 268 | padding-right: 0.5em; 269 | background-color: inherit; 270 | } 271 | 272 | .Rfilecontent { 273 | margin: 0.5em; 274 | } 275 | 276 | .RpackageSpec { 277 | padding-right: 0; 278 | } 279 | 280 | /* ---------------------------------------- */ 281 | /* For background labels */ 282 | 283 | .RBackgroundLabel { 284 | float: right; 285 | width: 0px; 286 | height: 0px; 287 | } 288 | 289 | .RBackgroundLabelInner { 290 | position: relative; 291 | width: 25em; 292 | left: -25.5em; 293 | top: 0.20rem; /* sensitive to monospaced font choice */ 294 | text-align: right; 295 | z-index: 0; 296 | font-weight: 300; 297 | font-family: 'Fira-Mono', monospace; 298 | font-size: 0.9rem; 299 | color: gray; 300 | } 301 | 302 | 303 | .RpackageSpec .Smaller { 304 | font-weight: 300; 305 | font-family: 'Fira-Mono', monospace; 306 | font-size: 0.9rem; 307 | } 308 | 309 | .RForeground { 310 | position: relative; 311 | left: 0px; 312 | top: 0px; 313 | z-index: 1; 314 | } 315 | 316 | /* ---------------------------------------- */ 317 | /* For section source modules & tags */ 318 | 319 | .RPartExplain { 320 | background: #eee; 321 | font-size: 0.9rem; 322 | margin-top: 0.2rem; 323 | padding: 0.2rem; 324 | text-align: left; 325 | } 326 | -------------------------------------------------------------------------------- /doc/manual-racket.js: -------------------------------------------------------------------------------- 1 | /* For the Racket manual style */ 2 | 3 | AddOnLoad(function() { 4 | /* Look for header elements that have x-source-module and x-part tag. 5 | For those elements, add a hidden element that explains how to 6 | link to the section, and set the element's onclick() to display 7 | the explanation. */ 8 | var tag_names = ["h1", "h2", "h3", "h4", "h5"]; 9 | for (var j = 0; j < tag_names.length; j++) { 10 | elems = document.getElementsByTagName(tag_names[j]); 11 | for (var i = 0; i < elems.length; i++) { 12 | var elem = elems.item(i); 13 | AddPartTitleOnClick(elem); 14 | } 15 | } 16 | }) 17 | 18 | // cache of source urls 19 | var cache = {}; 20 | 21 | function ParseSource(source, mod_path, single_collection) { 22 | 23 | var source_url = new URL(source); 24 | 25 | if (source_url.protocol == "github:") { 26 | // browser URL parser only works with http(s) URLs 27 | source_url = new URL("https" + source.substring(6)); 28 | var host = source_url.host; 29 | var url_path = source_url.pathname.substring(1).split("/"); 30 | if (!(url_path.length >= 2)) return null; 31 | var user = url_path.shift(); 32 | var repo = url_path.shift(); 33 | var branch = url_path.shift(); 34 | var source_path = url_path.join("/"); 35 | } 36 | else if (("https:" == source_url.protocol) || ("git:" == source_url.protocol)) { 37 | // browser URL parser only works with http(s) URLs 38 | if ("git:" == source_url.protocol) 39 | source_url = new URL("https" + source.substring(3)); 40 | 41 | var host = source_url.host; 42 | var source_path = source_url.searchParams.get("path"); 43 | var branch = (source_url.hash || "#master").substring(1); 44 | var url_path = source_url.pathname.substring(1).split("/"); 45 | if (url_path.length < 2) throw [source_url.pathname, url_path]; 46 | var user = url_path.shift(); 47 | var repo = url_path.shift(); 48 | var mtch = repo.match(/(.*)\.git$/); 49 | if (mtch) repo = mtch[1]; 50 | 51 | } 52 | else return null; 53 | 54 | var mod_path_re = /^\(lib "(.+)"\)$/; 55 | 56 | var mod_path_elems = mod_path && mod_path.match(mod_path_re)[1].split("/"); 57 | 58 | if (!user || !repo || !mod_path_elems) 59 | return null; 60 | if (single_collection) 61 | mod_path_elems.shift(); 62 | 63 | var file_path = mod_path_elems.join("/"); 64 | 65 | 66 | if (source_path) { 67 | file_path = source_path + "/" + file_path; 68 | } 69 | 70 | return { user: user, 71 | repo: repo, 72 | file_path: file_path, 73 | branch: branch, 74 | host: host }; 75 | } 76 | 77 | function AddSourceElement(pkg_url, info) { 78 | info.appendChild(document.createTextNode("Document source ")); 79 | var url_line = document.createElement("div"); 80 | var a = document.createElement("a"); 81 | a.href = pkg_url; 82 | a.style.whiteSpace = "nowrap"; 83 | a.appendChild(document.createTextNode(pkg_url)); 84 | addSpan(url_line, "\xA0", "RktRdr"); 85 | url_line.appendChild(a); 86 | info.appendChild(url_line); 87 | } 88 | 89 | var prefixes = { "github.com": "tree", 90 | "gitlab.com": "-/blob" }; 91 | 92 | 93 | function AddSourceUrl(source, mod_path, collection, info) { 94 | // multi is encoded as an array, empty as false 95 | single_collection = (typeof collection === "string"); 96 | 97 | var parsed = source && mod_path && ParseSource(source, mod_path, single_collection); 98 | 99 | if (!parsed) return; 100 | 101 | prefix = prefixes.hasOwnProperty(parsed.host) && prefixes[parsed.host]; 102 | if (!prefix) return; 103 | 104 | var correct_url = "https://" + [parsed.host, parsed.user, parsed.repo, prefix, parsed.branch, parsed.file_path].join("/"); 105 | 106 | if (info) AddSourceElement(correct_url, info); 107 | } 108 | 109 | function addSpan(dest, str, cn) { 110 | var s = document.createElement("span"); 111 | s.className = cn; 112 | s.style.whiteSpace = "nowrap"; 113 | s.appendChild(document.createTextNode(str)); 114 | dest.appendChild(s); 115 | } 116 | 117 | 118 | // test cases 119 | if (false) { 120 | console.log(ParseSource("git://gitlab.com/benn/foo?path=xxx", 121 | '(lib "asn1/scribblings/asn1.scrbl")', 122 | false)) 123 | console.log(ParseSource("github://github.com/carl-eastlund/mischief/master", 124 | '(lib "asn1/scribblings/asn1.scrbl")', 125 | false)) 126 | console.log(ParseSource("github://github.com/carl-eastlund/mischief/stable/dir", 127 | '(lib "asn1/scribblings/asn1.scrbl")', 128 | false)) 129 | 130 | console.log(ParseSource("git://github.com/racket/racket/?path=pkgs/racket-doc", 131 | '(lib "asn1/scribblings/asn1.scrbl")', 132 | false)); 133 | 134 | console.log(ParseSource("git://github.com/rmculpepper/asn1.git?path=asn1-doc", 135 | '(lib "asn1/scribblings/asn1.scrbl")', 136 | true)); 137 | console.log(ParseSource("git://github.com/rmculpepper/asn1", 138 | '(lib "asn1/scribblings/asn1.scrbl")', 139 | true)); 140 | console.log(ParseSource("git://github.com/rmculpepper/asn1", 141 | '(lib "asn1/scribblings/asn1.scrbl")', 142 | false)); 143 | } 144 | 145 | function AddPartTitleOnClick(elem) { 146 | var mod_path = elem.getAttribute("x-source-module"); 147 | var tag = elem.getAttribute("x-part-tag"); 148 | var source_pkg = elem.getAttribute("x-source-pkg"); 149 | 150 | // create here to share 151 | var info = document.createElement("div"); 152 | 153 | 154 | // tag is not needed, but this way we can add the element in only one place 155 | // avoid failing on browser that don't have `fetch` 156 | if (mod_path && source_pkg && tag && window.fetch) { 157 | 158 | var cached = cache[mod_path] 159 | if (cached) { 160 | AddSourceElement(cached[0], mod_path, cached[1], info); 161 | } 162 | else { 163 | fetch("https://pkgs.racket-lang.org/pkg/" + source_pkg + ".json") 164 | .then(function (response) { return response.json(); }) 165 | .then(function (data) { 166 | var vers = data["versions"] || {}; 167 | var def = vers["default"] || {}; 168 | var source = def["source"] || undefined; 169 | var collection = data["collection"]; 170 | if (source) { 171 | cache[mod_path] = [source, collection]; 172 | AddSourceUrl(source, mod_path, collection, info); 173 | } 174 | }); 175 | } 176 | } 177 | 178 | if (mod_path && tag) { 179 | // Might not be present: 180 | var prefixes = elem.getAttribute("x-part-prefixes"); 181 | 182 | info.className = "RPartExplain"; 183 | 184 | /* The "top" tag refers to a whole document: */ 185 | var is_top = (tag == "\"top\""); 186 | info.appendChild(document.createTextNode("Link to this " 187 | + (is_top ? "document" : "section") 188 | + " with ")); 189 | 190 | /* Break `secref` into two lines if the module path and tag 191 | are long enough: */ 192 | var is_long = (is_top ? false : ((mod_path.length 193 | + tag.length 194 | + (prefixes ? (16 + prefixes.length) : 0)) 195 | > 60)); 196 | 197 | var line1 = document.createElement("div"); 198 | var line1x = ((is_long && prefixes) ? document.createElement("div") : line1); 199 | var line2 = (is_long ? document.createElement("div") : line1); 200 | 201 | /* Construct a `secref` call with suitable syntax coloring: */ 202 | addSpan(line1, "\xA0@", "RktRdr"); 203 | addSpan(line1, (is_top ? "other-doc" : "secref"), "RktSym"); 204 | addSpan(line1, "[", "RktPn"); 205 | if (!is_top) 206 | addSpan(line1, tag, "RktVal"); 207 | if (is_long) { 208 | /* indent additional lines: */ 209 | if (prefixes) 210 | addSpan(line1x, "\xA0\xA0\xA0\xA0\xA0\xA0\xA0\xA0", "RktPn"); 211 | addSpan(line2, "\xA0\xA0\xA0\xA0\xA0\xA0\xA0\xA0", "RktPn"); 212 | } 213 | if (prefixes) { 214 | addSpan(line1x, " #:tag-prefixes ", "RktPn"); 215 | addSpan(line1x, "'", "RktVal"); 216 | addSpan(line1x, prefixes, "RktVal"); 217 | } 218 | if (!is_top) 219 | addSpan(line2, " #:doc ", "RktPn"); 220 | addSpan(line2, "'", "RktVal"); 221 | addSpan(line2, mod_path, "RktVal"); 222 | addSpan(line2, "]", "RktPn"); 223 | 224 | info.appendChild(line1); 225 | if (is_long) 226 | info.appendChild(line1x); 227 | if (is_long) 228 | info.appendChild(line2); 229 | 230 | info.style.display = "none"; 231 | 232 | /* Add the new element afterthe header: */ 233 | var n = elem.nextSibling; 234 | if (n) 235 | elem.parentNode.insertBefore(info, n); 236 | else 237 | elem.parentNode.appendChild(info); 238 | 239 | /* Clicking the header shows the explanation element: */ 240 | elem.onclick = function () { 241 | if (info.style.display == "none") 242 | info.style.display = "block"; 243 | else 244 | info.style.display = "none"; 245 | } 246 | } 247 | } 248 | -------------------------------------------------------------------------------- /doc/scribble.css: -------------------------------------------------------------------------------- 1 | 2 | /* This file is used by default by all Scribble documents. 3 | See also "manual.css", which is added by default by the 4 | `scribble/manual` language. */ 5 | 6 | /* CSS seems backward: List all the classes for which we want a 7 | particular font, so that the font can be changed in one place. (It 8 | would be nicer to reference a font definition from all the places 9 | that we want it.) 10 | 11 | As you read the rest of the file, remember to double-check here to 12 | see if any font is set. */ 13 | 14 | /* Monospace: */ 15 | .maincolumn, .refpara, .refelem, .tocset, .stt, .hspace, .refparaleft, .refelemleft { 16 | font-family: monospace; 17 | } 18 | 19 | /* Serif: */ 20 | .main, .refcontent, .tocview, .tocsub, .sroman, i { 21 | font-family: serif; 22 | } 23 | 24 | /* Sans-serif: */ 25 | .version, .versionNoNav, .ssansserif { 26 | font-family: sans-serif; 27 | } 28 | .ssansserif { 29 | font-size: 80%; 30 | font-weight: bold; 31 | } 32 | 33 | /* Emphasis: alternate italics and normal as we nest */ 34 | .emph { 35 | font-style: italic; 36 | } 37 | .emph .emph { 38 | font-style: normal; 39 | } 40 | .emph .emph .emph { 41 | font-style: italic; 42 | } 43 | .emph .emph .emph .emph { 44 | font-style: normal; 45 | } 46 | .emph .emph .emph .emph .emph { 47 | font-style: italic; 48 | } 49 | .emph .emph .emph .emph .emph .emph { 50 | font-style: normal; 51 | } 52 | 53 | /* ---------------------------------------- */ 54 | 55 | p, .SIntrapara { 56 | display: block; 57 | margin: 1em 0; 58 | } 59 | 60 | h2 { /* per-page main title */ 61 | margin-top: 0; 62 | } 63 | 64 | h3, h4, h5, h6, h7, h8 { 65 | margin-top: 1.75em; 66 | margin-bottom: 0.5em; 67 | } 68 | 69 | .SSubSubSubSection { 70 | font-weight: bold; 71 | font-size: 0.83em; /* should match h5; from HTML 4 reference */ 72 | } 73 | 74 | /* Needed for browsers like Opera, and eventually for HTML 4 conformance. 75 | This means that multiple paragraphs in a table element do not have a space 76 | between them. */ 77 | table p { 78 | margin-top: 0; 79 | margin-bottom: 0; 80 | } 81 | 82 | /* ---------------------------------------- */ 83 | /* Main */ 84 | 85 | body { 86 | color: black; 87 | background-color: #ffffff; 88 | } 89 | 90 | table td { 91 | padding-left: 0; 92 | padding-right: 0; 93 | } 94 | 95 | .maincolumn { 96 | width: 43em; 97 | margin-right: -40em; 98 | margin-left: 15em; 99 | } 100 | 101 | .main { 102 | text-align: left; 103 | } 104 | 105 | /* ---------------------------------------- */ 106 | /* Navigation */ 107 | 108 | .navsettop, .navsetbottom { 109 | background-color: #f0f0e0; 110 | padding: 0.25em 0 0.25em 0; 111 | } 112 | 113 | .navsettop { 114 | margin-bottom: 1.5em; 115 | border-bottom: 2px solid #e0e0c0; 116 | } 117 | 118 | .navsetbottom { 119 | margin-top: 2em; 120 | border-top: 2px solid #e0e0c0; 121 | } 122 | 123 | .navleft { 124 | margin-left: 1ex; 125 | position: relative; 126 | float: left; 127 | white-space: nowrap; 128 | } 129 | .navright { 130 | margin-right: 1ex; 131 | position: relative; 132 | float: right; 133 | white-space: nowrap; 134 | } 135 | .nonavigation { 136 | color: #e0e0e0; 137 | } 138 | 139 | .navleft .tocsettoggle { 140 | display: none; 141 | } 142 | 143 | .searchform { 144 | display: inline; 145 | margin: 0; 146 | padding: 0; 147 | } 148 | 149 | .nosearchform { 150 | display: none; 151 | } 152 | 153 | .searchbox { 154 | width: 16em; 155 | margin: 0px; 156 | padding: 0px; 157 | background-color: #eee; 158 | border: 1px solid #ddd; 159 | vertical-align: middle; 160 | } 161 | 162 | .searchbox::placeholder { 163 | text-align: center; 164 | } 165 | 166 | #contextindicator { 167 | position: fixed; 168 | background-color: #c6f; 169 | color: #000; 170 | font-family: monospace; 171 | font-weight: bold; 172 | padding: 2px 10px; 173 | display: none; 174 | right: 0; 175 | bottom: 0; 176 | } 177 | 178 | /* ---------------------------------------- */ 179 | /* Version */ 180 | 181 | .versionbox { 182 | position: relative; 183 | float: right; 184 | left: 2em; 185 | height: 0em; 186 | width: 13em; 187 | margin: 0em -13em 0em 0em; 188 | } 189 | .version { 190 | font-size: small; 191 | } 192 | .versionNoNav { 193 | font-size: xx-small; /* avoid overlap with author */ 194 | } 195 | 196 | .version:before, .versionNoNav:before { 197 | content: "Version "; 198 | } 199 | 200 | /* ---------------------------------------- */ 201 | /* Margin notes */ 202 | 203 | .refpara, .refelem { 204 | position: relative; 205 | float: right; 206 | left: 2em; 207 | height: 0em; 208 | width: 13em; 209 | margin: 0em -13em 0em 0em; 210 | } 211 | 212 | .refpara, .refparaleft { 213 | top: -1em; 214 | } 215 | 216 | .refcolumn { 217 | background-color: #F5F5DC; 218 | display: block; 219 | position: relative; 220 | width: 13em; 221 | font-size: 85%; 222 | border: 0.5em solid #F5F5DC; 223 | margin: 0 0 0 0; 224 | white-space: normal; /* in case margin note is inside code sample */ 225 | } 226 | 227 | .refcontent { 228 | margin: 0 0 0 0; 229 | } 230 | 231 | .refcontent p { 232 | margin-top: 0; 233 | margin-bottom: 0; 234 | } 235 | 236 | .refparaleft, .refelemleft { 237 | position: relative; 238 | float: left; 239 | right: 2em; 240 | height: 0em; 241 | width: 13em; 242 | margin: 0em 0em 0em -13em; 243 | } 244 | 245 | .refcolumnleft { 246 | background-color: #F5F5DC; 247 | display: block; 248 | position: relative; 249 | width: 13em; 250 | font-size: 85%; 251 | border: 0.5em solid #F5F5DC; 252 | margin: 0 0 0 0; 253 | } 254 | 255 | 256 | /* ---------------------------------------- */ 257 | /* Table of contents, inline */ 258 | 259 | .toclink { 260 | text-decoration: none; 261 | color: blue; 262 | font-size: 85%; 263 | } 264 | 265 | .toptoclink { 266 | text-decoration: none; 267 | color: blue; 268 | font-weight: bold; 269 | } 270 | 271 | /* ---------------------------------------- */ 272 | /* Table of contents, left margin */ 273 | 274 | .tocset { 275 | position: relative; 276 | float: left; 277 | width: 12.5em; 278 | margin-right: 2em; 279 | } 280 | .tocset td { 281 | vertical-align: text-top; 282 | } 283 | 284 | .tocview { 285 | text-align: left; 286 | background-color: #f0f0e0; 287 | } 288 | 289 | .tocsub { 290 | text-align: left; 291 | margin-top: 0.5em; 292 | background-color: #f0f0e0; 293 | } 294 | 295 | .tocviewlist, .tocsublist { 296 | margin-left: 0.2em; 297 | margin-right: 0.2em; 298 | padding-top: 0.2em; 299 | padding-bottom: 0.2em; 300 | } 301 | .tocviewlist table { 302 | font-size: 82%; 303 | } 304 | 305 | .tocviewlisttopspace { 306 | margin-bottom: 1em; 307 | } 308 | 309 | .tocviewsublist, .tocviewsublistonly, .tocviewsublisttop, .tocviewsublistbottom { 310 | margin-left: 0.4em; 311 | border-left: 1px solid #bbf; 312 | padding-left: 0.8em; 313 | } 314 | .tocviewsublist { 315 | margin-bottom: 1em; 316 | } 317 | .tocviewsublist table, 318 | .tocviewsublistonly table, 319 | .tocviewsublisttop table, 320 | .tocviewsublistbottom table { 321 | font-size: 75%; 322 | } 323 | 324 | .tocviewtitle * { 325 | font-weight: bold; 326 | } 327 | 328 | .tocviewlink { 329 | text-decoration: none; 330 | color: blue; 331 | } 332 | 333 | .tocviewselflink { 334 | text-decoration: underline; 335 | color: blue; 336 | } 337 | 338 | .tocviewtoggle { 339 | text-decoration: none; 340 | color: blue; 341 | font-size: 75%; /* looks better, and avoids bounce when toggling sub-sections due to font alignments */ 342 | } 343 | 344 | .tocsublist td { 345 | padding-left: 1em; 346 | text-indent: -1em; 347 | } 348 | 349 | .tocsublinknumber { 350 | font-size: 82%; 351 | } 352 | 353 | .tocsublink { 354 | font-size: 82%; 355 | text-decoration: none; 356 | } 357 | 358 | .tocsubseclink { 359 | font-size: 82%; 360 | text-decoration: none; 361 | } 362 | 363 | .tocsubnonseclink { 364 | font-size: 82%; 365 | text-decoration: none; 366 | padding-left: 0.5em; 367 | } 368 | 369 | .tocsubtitle { 370 | font-size: 82%; 371 | font-style: italic; 372 | margin: 0.2em; 373 | } 374 | 375 | /* ---------------------------------------- */ 376 | /* Some inline styles */ 377 | 378 | .indexlink { 379 | text-decoration: none; 380 | } 381 | 382 | .nobreak { 383 | white-space: nowrap; 384 | } 385 | 386 | pre { margin-left: 2em; } 387 | blockquote { margin-left: 2em; } 388 | 389 | ol { list-style-type: decimal; } 390 | ol ol { list-style-type: lower-alpha; } 391 | ol ol ol { list-style-type: lower-roman; } 392 | ol ol ol ol { list-style-type: upper-alpha; } 393 | 394 | .SCodeFlow { 395 | display: block; 396 | margin-left: 1em; 397 | margin-bottom: 0em; 398 | margin-right: 1em; 399 | margin-top: 0em; 400 | white-space: nowrap; 401 | } 402 | 403 | .SVInsetFlow { 404 | display: block; 405 | margin-left: 0em; 406 | margin-bottom: 0em; 407 | margin-right: 0em; 408 | margin-top: 0em; 409 | } 410 | 411 | .SubFlow { 412 | display: block; 413 | margin: 0em; 414 | } 415 | 416 | .boxed { 417 | width: 100%; 418 | background-color: #E8E8FF; 419 | } 420 | 421 | .hspace { 422 | } 423 | 424 | .slant { 425 | font-style: oblique; 426 | } 427 | 428 | .badlink { 429 | text-decoration: underline; 430 | color: red; 431 | } 432 | 433 | .plainlink { 434 | text-decoration: none; 435 | color: blue; 436 | } 437 | 438 | .techoutside { text-decoration: underline; color: #b0b0b0; } 439 | .techoutside:hover { text-decoration: underline; color: blue; } 440 | 441 | /* .techinside:hover doesn't work with FF, .techinside:hover> 442 | .techinside doesn't work with IE, so use both (and IE doesn't 443 | work with inherit in the second one, so use blue directly) */ 444 | .techinside { color: black; } 445 | .techinside:hover { color: blue; } 446 | .techoutside:hover>.techinside { color: inherit; } 447 | 448 | .SCentered { 449 | text-align: center; 450 | } 451 | 452 | .imageleft { 453 | float: left; 454 | margin-right: 0.3em; 455 | } 456 | 457 | .Smaller { 458 | font-size: 82%; 459 | } 460 | 461 | .Larger { 462 | font-size: 122%; 463 | } 464 | 465 | /* A hack, inserted to break some Scheme ids: */ 466 | .mywbr { 467 | display: inline-block; 468 | height: 0; 469 | width: 0; 470 | font-size: 1px; 471 | } 472 | 473 | .compact li p { 474 | margin: 0em; 475 | padding: 0em; 476 | } 477 | 478 | .noborder img { 479 | border: 0; 480 | } 481 | 482 | .SVerbatim { 483 | white-space: nowrap; 484 | } 485 | 486 | .SAuthorListBox { 487 | position: relative; 488 | float: right; 489 | left: 2em; 490 | top: -2.5em; 491 | height: 0em; 492 | width: 13em; 493 | margin: 0em -13em 0em 0em; 494 | } 495 | .SAuthorList { 496 | font-size: 82%; 497 | } 498 | .SAuthorList:before { 499 | content: "by "; 500 | } 501 | .author { 502 | display: inline; 503 | white-space: nowrap; 504 | } 505 | 506 | /* print styles : hide the navigation elements */ 507 | @media print { 508 | .tocset, 509 | .navsettop, 510 | .navsetbottom { display: none; } 511 | .maincolumn { 512 | width: auto; 513 | margin-right: 13em; 514 | margin-left: 0; 515 | } 516 | } 517 | -------------------------------------------------------------------------------- /pict-of-state.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide pict-of-state) 3 | (require pict) 4 | (require (rename-in pict [text pict-text])) 5 | (require racket/draw) 6 | (require (only-in framework editor:get-current-preferred-font-size)) 7 | 8 | ;;; This color palette has been checked with 9 | ;;; https://color.adobe.com/zh/create/color-accessibility 10 | ;; dark and light blue (#0000C8 & #0000FF) 11 | (define color-A-D (make-object color% 0 0 200)) 12 | (define color-A-L (make-object color% 0 0 255)) 13 | ;; dark and light yellow (#FFBB00 & #FFDF40) 14 | (define color-B-D (make-object color% 255 187 0)) 15 | (define color-B-L (make-object color% 255 223 64)) 16 | ;; red (#FF7D6C) 17 | (define color-C (make-object color% 255 127 121)) 18 | ;; dark and light green (#C1E197 & #41BC76) 19 | (define color-D-D (make-object color% 65 188 118)) 20 | (define color-D-L (make-object color% 193 225 151)) 21 | ;; black and white 22 | (define color-black (make-object color% 0 0 0)) 23 | (define color-white (make-object color% 255 255 255)) 24 | (define color-dark-grey (make-object color% 100 100 100)) 25 | (define color-light-grey (make-object color% 155 155 155)) 26 | 27 | ;; These color palettes for texts have been checked with 28 | ;; https://webaim.org/resources/contrastchecker/ 29 | (struct text-palette (text background)) 30 | (define tp-A-D (text-palette color-white color-A-D)) 31 | (define tp-A-L (text-palette color-white color-A-L)) 32 | (define tp-B-D (text-palette color-black color-B-D)) 33 | (define tp-B-L (text-palette color-black color-B-L)) 34 | (define tp-C (text-palette color-black color-C)) 35 | (define tp-D-D (text-palette color-black color-D-D)) 36 | (define tp-D-L (text-palette color-black color-D-L)) 37 | (define tp-white (text-palette color-black color-white)) 38 | (define tp-black (text-palette color-white color-black)) 39 | (define tp-dark-grey (text-palette color-white color-dark-grey)) 40 | (define tp-light-grey (text-palette color-black color-light-grey)) 41 | 42 | (define tp-stack tp-black) 43 | (define tp-stack-frame tp-B-D) 44 | (define tp-calling tp-B-D) 45 | (define tp-called tp-A-D) 46 | (define tp-returning tp-A-D) 47 | (define tp-returned tp-A-D) 48 | (define tp-terminated tp-black) 49 | (define tp-errored tp-C) 50 | (define tp-mutating tp-A-D) 51 | 52 | (define tp-env tp-D-D) 53 | (define tp-fun tp-D-L) 54 | (define tp-mvec tp-dark-grey) 55 | (define tp-cons tp-light-grey) 56 | 57 | (define current-text-palette (make-parameter tp-white)) 58 | (define (current-text-color) 59 | (text-palette-text (current-text-palette))) 60 | (define (current-background-color) 61 | (text-palette-background (current-text-palette))) 62 | 63 | (define (text s) 64 | (pre-text s 'modern)) 65 | (define (pre-text s font-family) 66 | (define style 67 | (cons (current-text-color) 68 | (make-object font% 69 | (editor:get-current-preferred-font-size) 70 | font-family))) 71 | (if (equal? s "") 72 | (pict-text " " style) 73 | (apply vl-append 74 | (map 75 | (lambda (s) 76 | (pict-text s style)) 77 | (string-split s "\n"))))) 78 | 79 | (define (pict-of-state hide-closure? hide-env-label?) 80 | (define ((pict-of-focus heap) focus) 81 | (match focus 82 | [`("vec-setting" ,action ,env ,ectx) 83 | (parameterize ([current-text-palette tp-mutating]) 84 | (plate (vl-append padding 85 | (field-label "Changing a vector") 86 | (field-value action) 87 | #;(field-value (format "(vec-set! @~a ~a ~a)" addr i v)) 88 | #; 89 | (field-pict "(the" 90 | (ht-append 91 | padding 92 | (field-value i) 93 | (field-label "-th element will be") 94 | (field-value v) 95 | (field-label ")"))) 96 | (field "in context" ectx) 97 | (field "in environment @" env))))] 98 | [`("setting" ,x ,v ,env ,ectx) 99 | (parameterize ([current-text-palette tp-mutating]) 100 | (plate (vl-append padding 101 | (field-pict 102 | "Changing" 103 | (ht-append 104 | padding 105 | (field-value x) 106 | (field-label "to") 107 | (field-value v))) 108 | (field "in context" ectx) 109 | (field "in environment @" env))))] 110 | [`("setted" ,env ,ectx) 111 | (parameterize ([current-text-palette tp-calling]) 112 | (plate (vl-append padding 113 | (field "in context" ectx) 114 | (field "in environment @" env))))] 115 | [`("calling" ,app ,env ,ectx) 116 | (parameterize ([current-text-palette tp-calling]) 117 | (plate (vl-append padding 118 | (field "Calling" app) 119 | (field "in context" ectx) 120 | (field "in environment @" env))))] 121 | [`("called" ,body ,env) 122 | (parameterize ([current-text-palette tp-called]) 123 | (plate (vl-append padding 124 | (field-label "Evaluating the body") 125 | (field-value body) 126 | (field "in environment @" env))))] 127 | [`("returned" ,v ,env ,ectx) 128 | (parameterize ([current-text-palette tp-returned]) 129 | (plate (vl-append padding 130 | (field "Returned" v) 131 | (field "to contect" ectx) 132 | (field "in environment @" env))))] 133 | [`("returning" ,v) 134 | (parameterize ([current-text-palette tp-returning]) 135 | (plate (vl-append padding 136 | (field "Returning" v))))] 137 | [`("terminated" ,v*) 138 | (parameterize ([current-text-palette tp-terminated]) 139 | (plate (vl-append padding 140 | (field-label "Terminated") 141 | (field-value (string-join v* "\n")))))] 142 | [`("errored") 143 | (parameterize ([current-text-palette tp-errored]) 144 | (plate (vl-append padding 145 | (field-label "Errored"))))])) 146 | 147 | (define (main-pict stack focus heap) 148 | (bg (ht-append padding 149 | (vl-append padding 150 | ((pict-of-stack heap) stack) 151 | ((pict-of-focus heap) focus)) 152 | (pict-of-heap heap)))) 153 | 154 | (define (pict-of-state state) 155 | (define p 156 | (match state 157 | [`("vec-setting" ,action ,env ,ectx ,stack ,heap) 158 | (main-pict stack `("vec-setting" ,action ,env ,ectx) heap)] 159 | [`("setting" ,x ,v ,env ,ectx ,stack ,heap) 160 | (main-pict stack `("setting" ,x ,v ,env ,ectx) heap)] 161 | [`("setted" ,env ,ectx ,stack ,heap) 162 | (main-pict stack `("setted" ,env ,ectx) heap)] 163 | [`("calling" ,app ,env ,ectx ,stack ,heap) 164 | (main-pict stack `("calling" ,app ,env ,ectx) heap)] 165 | [`("called" ,body ,env ,stack ,heap) 166 | (main-pict stack `("called" ,body ,env) heap)] 167 | [`("returning" ,v ,stack ,heap) 168 | (main-pict stack `("returning" ,v) heap)] 169 | [`("returned" ,v ,env ,ectx ,stack ,heap) 170 | (main-pict stack `("returned" ,v ,env ,ectx) heap)] 171 | [`("terminated" ,v* ,heap) 172 | (main-pict empty `("terminated" ,v*) heap)] 173 | [`("errored" ,heap) 174 | (main-pict empty `("errored") heap)])) 175 | (define dim (max (pict-width p) (pict-height p))) 176 | (scale p (min 1.2 (/ 700 (pict-height p)) (/ 1200 (pict-width p))))) 177 | 178 | (define ((pict-of-stack heap) stack) 179 | (parameterize ([current-text-palette tp-stack]) 180 | (box 181 | (apply vl-append 182 | (field-label "Stack") 183 | (map (pict-of-sf heap) (reverse stack)))))) 184 | 185 | (define (is-env? heapitem) 186 | (match-define (list addr hv) heapitem) 187 | (match hv 188 | [`("env" ,@_) 189 | #t] 190 | [else 191 | #f])) 192 | 193 | (define (pict-of-heap heap) 194 | (pict-of-heapitem* heap)) 195 | 196 | (define (heapitem-interesting? item) 197 | (match-define `(,this-addr ,hv) item) 198 | (and (string? this-addr) ;; string addresses means the address is not primitive (symbol address) 199 | (if hide-closure? 200 | (not (is-closure? hv)) 201 | #t))) 202 | (define (is-closure? hv) 203 | (match hv 204 | [`("fun" ,@_) #t] 205 | [else #f])) 206 | (define (pict-of-heapitem* heapitems) 207 | (let-values ([(envs others) (partition is-env? 208 | (filter heapitem-interesting? heapitems))]) 209 | (ht-append 210 | padding 211 | (apply vl-append padding 212 | (map pict-of-heapitem envs)) 213 | (apply vl-append padding 214 | (map pict-of-heapitem others))))) 215 | (define (pict-of-heapitem item) 216 | (match-define `(,this-addr ,hv) item) 217 | (match hv 218 | [`("env" ,env ,bindings) 219 | (parameterize ([current-text-palette tp-env]) 220 | (plate (vl-append 221 | (field "@" this-addr) 222 | (if hide-env-label? 223 | (blank) 224 | (field-label "Environment Frame")) 225 | (field-pict "Bindings" (if (equal? this-addr '|@base-env|) 226 | (field-value '...) 227 | (apply vl-append padding 228 | (map pict-of-binding 229 | (filter (lambda (b) 230 | (match-define (list x v) b) 231 | (if hide-closure? 232 | (not (equal? (format "@~a" x) v)) 233 | #t)) 234 | bindings))))) 235 | (field "Rest @" env)) 236 | ))] 237 | [`("fun" ,env ,code) 238 | (parameterize ([current-text-palette tp-fun]) 239 | (plate (vl-append padding 240 | (field "@" this-addr) 241 | (field "Environment @" env) 242 | (field "Code" code)) 243 | ))] 244 | [`("vec" ,@vec) 245 | (parameterize ([current-text-palette tp-mvec]) 246 | (plate (vl-append padding 247 | (field "@" this-addr) 248 | (field-pict "mvec" (apply hb-append padding (map field-value vec)))) 249 | ))] 250 | [`("cons" ,v1 ,v2) 251 | (parameterize ([current-text-palette tp-cons]) 252 | (plate (vl-append padding 253 | (field "@" this-addr) 254 | (field-pict "cons" (apply hb-append padding (map field-value (list v1 v2))))) 255 | ))])) 256 | (define (plate p) 257 | (define w (pict-width p)) 258 | (define h (pict-height p)) 259 | (define r 10) 260 | (cc-superimpose 261 | (filled-rounded-rectangle 262 | (+ (pict-width p) (* r 2)) 263 | (+ (pict-height p) (* r 2)) 264 | r 265 | #:color (current-background-color)) 266 | p)) 267 | 268 | (define (box p) 269 | (frame (bg (pad padding p)))) 270 | (define (pict-of-binding binding) 271 | (match-define (list x v) binding) 272 | (ht-append padding 273 | (field-value x) 274 | (field-label "↦") 275 | (field-value v))) 276 | 277 | (define padding 5) 278 | 279 | (define (field-label name) 280 | (pre-text name 'system)) 281 | (define (field-value value) 282 | (parameterize ([current-text-palette tp-white]) 283 | (bg (text value)))) 284 | (define (field-pict name p) 285 | (ht-append padding (field-label name) p)) 286 | (define (field name value) 287 | (field-pict name (field-value value))) 288 | 289 | (define (bg p) 290 | (cc-superimpose 291 | (filled-rectangle 292 | (pict-width p) 293 | (pict-height p) 294 | #:draw-border? #f 295 | #:color (current-background-color)) 296 | p)) 297 | 298 | (define ((pict-of-sf heap) sf) 299 | (match-define (list env ectx ann) sf) 300 | (parameterize ([current-text-palette tp-stack-frame]) 301 | (bg (frame 302 | (pad padding 303 | (vl-append padding 304 | (field-label "Waiting for a value") 305 | (field "in context" ectx) 306 | (field "in environment @" env))))))) 307 | 308 | (define (pad n p) 309 | (hc-append (blank n) 310 | (vc-append (blank n) p (blank n)) 311 | (blank n))) 312 | 313 | pict-of-state) -------------------------------------------------------------------------------- /doc/manual-style.css: -------------------------------------------------------------------------------- 1 | 2 | /* See the beginning of "scribble.css". 3 | This file is used by the `scribble/manual` language, along with 4 | "manual-racket.css". */ 5 | 6 | @import url("manual-fonts.css"); 7 | 8 | * { 9 | margin: 0; 10 | padding: 0; 11 | } 12 | 13 | @media all {html {font-size: 15px;}} 14 | @media all and (max-width:940px){html {font-size: 14px;}} 15 | @media all and (max-width:850px){html {font-size: 13px;}} 16 | @media all and (max-width:830px){html {font-size: 12px;}} 17 | @media all and (max-width:740px){html {font-size: 11px;}} 18 | 19 | /* CSS seems backward: List all the classes for which we want a 20 | particular font, so that the font can be changed in one place. (It 21 | would be nicer to reference a font definition from all the places 22 | that we want it.) 23 | 24 | As you read the rest of the file, remember to double-check here to 25 | see if any font is set. */ 26 | 27 | /* Monospace: */ 28 | .maincolumn, .refpara, .refelem, .tocset, .stt, .hspace, .refparaleft, .refelemleft { 29 | font-family: 'Fira-Mono', monospace; 30 | white-space: inherit; 31 | font-size: 1rem; 32 | } 33 | 34 | /* embolden the "Racket Guide" and "Racket Reference" links on the TOC */ 35 | /* there isn't an obvious tag in the markup that designates the top TOC page, which is called "start.scrbl" */ 36 | /* nor a tag that designates these two links as special */ 37 | /* so we'll use this slightly tortured sibling selector that hooks onto the h2 tag */ 38 | h2[x-source-module='(lib "scribblings/main/start.scrbl")'] ~ table a[href="guide/index.html"], 39 | h2[x-source-module='(lib "scribblings/main/start.scrbl")'] ~ table a[href="reference/index.html"] { 40 | font-weight: bold; 41 | } 42 | 43 | 44 | h2 .stt { 45 | font-size: 2.3rem; 46 | /* prevent automatic bolding from h2 */ 47 | font-weight: 400; 48 | } 49 | 50 | .toptoclink .stt { 51 | font-size: inherit; 52 | } 53 | .toclink .stt { 54 | font-size: 90%; 55 | } 56 | 57 | .RpackageSpec .stt { 58 | font-weight: 300; 59 | font-family: 'Fira-Mono', monospace; 60 | font-size: 0.9rem; 61 | } 62 | 63 | h3 .stt, h4 .stt, h5 .stt { 64 | color: #333; 65 | font-size: 1.65rem; 66 | font-weight: 400; 67 | } 68 | 69 | 70 | /* Serif: */ 71 | .main, .refcontent, .tocview, .tocsub, .sroman, i { 72 | font-family: 'Charter-Racket', serif; 73 | font-size: 1.18rem; 74 | /* Don't use font-feature-settings with Charter, 75 | it fouls up loading for reasons mysterious */ 76 | /* font-feature-settings: 'tnum' 1, 'liga' 0; */ 77 | } 78 | 79 | 80 | /* Sans-serif: */ 81 | .version, .versionNoNav, .ssansserif { 82 | font-family: 'Fira', sans-serif; 83 | } 84 | 85 | /* used mostly for DrRacket menu commands */ 86 | .ssansserif { 87 | font-family: 'Fira', sans-serif; 88 | font-size: 0.9em; 89 | } 90 | 91 | .tocset .ssansserif { 92 | font-size: 100%; 93 | } 94 | 95 | /* ---------------------------------------- */ 96 | 97 | p, .SIntrapara { 98 | display: block; 99 | margin: 0 0 1em 0; 100 | line-height: 1.4; 101 | } 102 | 103 | .compact { 104 | padding: 0 0 1em 0; 105 | } 106 | 107 | li { 108 | list-style-position: outside; 109 | margin-left: 1.2em; 110 | } 111 | 112 | h1, h2, h3, h4, h5, h6, h7, h8 { 113 | font-family: 'Fira', sans-serif; 114 | font-weight: 300; 115 | font-size: 1.6rem; 116 | color: #333; 117 | margin-top: inherit; 118 | margin-bottom: 1rem; 119 | line-height: 1.25; 120 | 121 | } 122 | 123 | h3, h4, h5, h6, h7, h8 { 124 | border-top: 1px solid black; 125 | } 126 | 127 | 128 | 129 | h2 { /* per-page main title */ 130 | font-family: 'Cooper-Hewitt'; 131 | margin-top: 4rem; 132 | font-size: 2.3rem; 133 | font-weight: bold; 134 | line-height: 1.2; 135 | width: 90%; 136 | /* a little nudge to make text visually lower than 4rem rule in left margin */ 137 | position: relative; 138 | top: 6px; 139 | } 140 | 141 | h3, h4, h5, h6, h7, h8 { 142 | margin-top: 2em; 143 | padding-top: 0.1em; 144 | margin-bottom: 0.75em; 145 | } 146 | 147 | /* ---------------------------------------- */ 148 | /* Main */ 149 | 150 | body { 151 | color: black; 152 | background-color: white; 153 | } 154 | 155 | .maincolumn { 156 | width: auto; 157 | margin-top: 4rem; 158 | margin-left: 17rem; 159 | margin-right: 2rem; 160 | margin-bottom: 10rem; /* to avoid fixed bottom nav bar */ 161 | max-width: 700px; 162 | min-width: 370px; /* below this size, code samples don't fit */ 163 | } 164 | 165 | a { 166 | text-decoration: inherit; 167 | } 168 | 169 | a, .toclink, .toptoclink, .tocviewlink, .tocviewselflink, .tocviewtoggle, .plainlink, 170 | .techinside, .techoutside:hover, .techinside:hover { 171 | color: #07A; 172 | } 173 | 174 | a:hover { 175 | text-decoration: underline; 176 | } 177 | 178 | 179 | /* ---------------------------------------- */ 180 | /* Navigation */ 181 | 182 | .navsettop, .navsetbottom { 183 | left: 0; 184 | width: 15rem; 185 | height: 6rem; 186 | font-family: 'Fira', sans-serif; 187 | font-size: 0.9rem; 188 | border-bottom: 0px solid hsl(216, 15%, 70%); 189 | background-color: inherit; 190 | padding: 0; 191 | } 192 | 193 | .navsettop { 194 | position: fixed; 195 | z-index: 2; 196 | background: #a7b0be; 197 | top: 0; 198 | left: 0; 199 | margin-bottom: 0; 200 | border-bottom: 0; 201 | } 202 | 203 | .navsettop a, .navsetbottom a { 204 | color: black; 205 | } 206 | 207 | .navsettop a:hover, .navsetbottom a:hover { 208 | background: hsl(216, 78%, 95%); 209 | text-decoration: none; 210 | } 211 | 212 | .navleft, .navright { 213 | position: static; 214 | float: none; 215 | margin: 0; 216 | white-space: normal; 217 | } 218 | 219 | 220 | .navleft a { 221 | display: inline-block; 222 | } 223 | 224 | .navright a { 225 | display: inline-block; 226 | text-align: center; 227 | } 228 | 229 | .navleft a, .navright a, .navright span { 230 | display: inline-block; 231 | padding: 0.5rem; 232 | min-width: 1rem; 233 | } 234 | 235 | 236 | .navright { 237 | white-space: nowrap; 238 | } 239 | 240 | 241 | .navsetbottom { 242 | display: none; 243 | } 244 | 245 | .nonavigation { 246 | color: #889; 247 | } 248 | 249 | .searchform { 250 | display: block; 251 | margin: 0; 252 | padding: 0; 253 | border-bottom: 1px solid #eee; 254 | height: 4rem; 255 | } 256 | 257 | .nosearchform { 258 | margin: 0; 259 | padding: 0; 260 | height: 4rem; 261 | } 262 | 263 | .searchbox { 264 | font-size: 0.9rem; 265 | width: 12rem; 266 | margin: 1rem; 267 | padding: 0.25rem 0.4rem ; 268 | vertical-align: middle; 269 | background-color: white; 270 | font-family: 'Fira-Mono', monospace; 271 | } 272 | 273 | 274 | #search_box { 275 | font-family: 'Fira-Mono', monospace; 276 | font-size: 1rem; 277 | padding: 0.25rem 0.3rem ; 278 | } 279 | 280 | /* Default to local view. Global will specialize */ 281 | .plt_global_only { display: none; } 282 | .plt_local_only { display: block; } 283 | 284 | /* ---------------------------------------- */ 285 | /* Version */ 286 | 287 | .versionbox { 288 | position: absolute; 289 | float: none; 290 | top: 0.25rem; 291 | left: 17rem; 292 | z-index: 11000; 293 | height: 2em; 294 | font-size: 70%; 295 | font-weight: lighter; 296 | width: inherit; 297 | margin: 0; 298 | } 299 | .version, .versionNoNav { 300 | font-size: inherit; 301 | } 302 | .version:before, .versionNoNav:before { 303 | content: "v."; 304 | } 305 | 306 | 307 | /* ---------------------------------------- */ 308 | /* Margin notes */ 309 | 310 | /* cancel scribble.css styles: */ 311 | .refpara, .refelem { 312 | position: static; 313 | float: none; 314 | height: auto; 315 | width: auto; 316 | margin: 0; 317 | } 318 | 319 | .refcolumn { 320 | position: static; 321 | display: block; 322 | width: auto; 323 | font-size: inherit; 324 | margin: 2rem; 325 | margin-left: 2rem; 326 | padding: 0.5em; 327 | padding-left: 0.75em; 328 | padding-right: 1em; 329 | background: hsl(60, 29%, 94%); 330 | border: 1px solid #ccb; 331 | border-left: 0.4rem solid #ccb; 332 | } 333 | 334 | 335 | /* slightly different handling for margin-note* on narrow screens */ 336 | @media all and (max-width:1340px) { 337 | span.refcolumn { 338 | float: right; 339 | width: 50%; 340 | margin-left: 1rem; 341 | margin-bottom: 0.8rem; 342 | margin-top: 1.2rem; 343 | } 344 | 345 | } 346 | 347 | .refcontent, .refcontent p { 348 | line-height: 1.5; 349 | margin: 0; 350 | } 351 | 352 | .refcontent p + p { 353 | margin-top: 1em; 354 | } 355 | 356 | .refcontent a { 357 | font-weight: 400; 358 | } 359 | 360 | .refpara, .refparaleft { 361 | top: -1em; 362 | } 363 | 364 | 365 | @media all and (max-width:600px) { 366 | .refcolumn { 367 | margin-left: 0; 368 | margin-right: 0; 369 | } 370 | } 371 | 372 | 373 | @media all and (min-width:1340px) { 374 | .refcolumn { 375 | margin: 0 -22.5rem 1rem 0; 376 | float: right; 377 | clear: right; 378 | width: 18rem; 379 | } 380 | } 381 | 382 | .refcontent { 383 | font-family: 'Fira', sans-serif; 384 | font-size: 1rem; 385 | line-height: 1.6; 386 | margin: 0 0 0 0; 387 | } 388 | 389 | 390 | .refparaleft, .refelemleft { 391 | position: relative; 392 | float: left; 393 | right: 2em; 394 | height: 0em; 395 | width: 13em; 396 | margin: 0em 0em 0em 0em; 397 | display: contents; 398 | } 399 | 400 | .refcolumnleft { 401 | background-color: hsl(60, 29%, 94%); 402 | display: block; 403 | position: relative; 404 | width: 13em; 405 | font-size: 85%; 406 | border: 0.5em solid hsl(60, 29%, 94%); 407 | margin: 0 0 0 0; 408 | } 409 | 410 | 411 | /* ---------------------------------------- */ 412 | /* Table of contents, left margin */ 413 | 414 | .tocset { 415 | position: fixed; 416 | z-index: 2; 417 | overflow-y: scroll; 418 | float: none; 419 | left: 0; 420 | top: 0rem; 421 | bottom: 0; 422 | width: 14rem; 423 | padding: 0rem 0.5rem 0.5rem 0.5rem; 424 | background-color: hsl(216, 15%, 70%); 425 | border-top: 6rem solid hsl(216, 15%, 70%); 426 | } 427 | 428 | .tocset td { 429 | vertical-align: text-top; 430 | padding-bottom: 0.4rem; 431 | padding-left: 0.2rem; 432 | line-height: 1.1; 433 | font-family: 'Fira', sans-serif; 434 | } 435 | 436 | .tocset td a { 437 | color: black; 438 | font-weight: 400; 439 | } 440 | 441 | 442 | .tocview { 443 | text-align: left; 444 | background-color: inherit; 445 | margin-top: 1em; 446 | } 447 | 448 | 449 | .tocview td, .tocsub td { 450 | line-height: 1.3; 451 | } 452 | 453 | 454 | .tocview table, .tocsub table { 455 | width: 90%; 456 | } 457 | 458 | .tocset td a.tocviewselflink { 459 | font-weight: lighter; 460 | font-size: 110%; /* monospaced styles below don't need to enlarge */ 461 | color: white; 462 | } 463 | 464 | .tocviewselflink { 465 | text-decoration: none; 466 | } 467 | 468 | .tocsub { 469 | text-align: left; 470 | margin-top: 0.5em; 471 | background-color: inherit; 472 | } 473 | 474 | .tocviewlist, .tocsublist { 475 | margin-left: 0.2em; 476 | margin-right: 0.2em; 477 | padding-top: 0.2em; 478 | padding-bottom: 0.2em; 479 | } 480 | .tocviewlist table { 481 | font-size: 82%; 482 | } 483 | 484 | .tocviewlisttopspace { 485 | margin-bottom: 1em; 486 | } 487 | 488 | .tocviewsublist, .tocviewsublistonly, .tocviewsublisttop, .tocviewsublistbottom { 489 | margin-left: 0.4em; 490 | border-left: 1px solid #99a; 491 | padding-left: 0.8em; 492 | } 493 | .tocviewsublist { 494 | margin-bottom: 1em; 495 | } 496 | .tocviewsublist table, 497 | .tocviewsublistonly table, 498 | .tocviewsublisttop table, 499 | .tocviewsublistbottom table, 500 | table.tocsublist { 501 | font-size: 1rem; 502 | } 503 | 504 | .tocviewsublist td, 505 | .tocviewsublistbottom td, 506 | .tocviewsublisttop td, 507 | .tocsub td, 508 | .tocviewsublistonly td { 509 | font-size: 90%; 510 | } 511 | 512 | /* shrink the monospaced text (`stt`) within nav */ 513 | .tocviewsublist td .stt, 514 | .tocviewsublistbottom td .stt, 515 | .tocviewsublisttop td .stt, 516 | .tocsub td .stt, 517 | .tocviewsublistonly td .stt { 518 | font-size: 95%; 519 | } 520 | 521 | 522 | .tocviewtoggle { 523 | font-size: 75%; /* looks better, and avoids bounce when toggling sub-sections due to font alignments */ 524 | } 525 | 526 | .tocsublist td { 527 | padding-left: 0.5rem; 528 | padding-top: 0.25rem; 529 | text-indent: 0; 530 | } 531 | 532 | .tocsublinknumber { 533 | font-size: 100%; 534 | } 535 | 536 | .tocsublink { 537 | font-size: 82%; 538 | text-decoration: none; 539 | } 540 | 541 | .tocsubseclink { 542 | font-size: 100%; 543 | text-decoration: none; 544 | } 545 | 546 | .tocsubnonseclink { 547 | font-size: 82%; 548 | text-decoration: none; 549 | margin-left: 1rem; 550 | padding-left: 0; 551 | display: inline-block; 552 | } 553 | 554 | /* the label "on this page" */ 555 | .tocsubtitle { 556 | display: block; 557 | font-size: 62%; 558 | font-family: 'Fira', sans-serif; 559 | font-weight: bolder; 560 | font-style: normal; 561 | letter-spacing: 2px; 562 | text-transform: uppercase; 563 | margin: 0.5em; 564 | } 565 | 566 | .toptoclink { 567 | font-weight: bold; 568 | font-size: 110%; 569 | margin-bottom: 0.5rem; 570 | margin-top: 1.5rem; 571 | display: inline-block; 572 | } 573 | 574 | .toclink { 575 | font-size: inherit; 576 | } 577 | 578 | /* ---------------------------------------- */ 579 | /* Some inline styles */ 580 | 581 | .indexlink { 582 | text-decoration: none; 583 | } 584 | 585 | pre { 586 | margin-left: 2em; 587 | } 588 | 589 | blockquote { 590 | margin-left: 2em; 591 | margin-right: 2em; 592 | margin-bottom: 1em; 593 | } 594 | 595 | .SCodeFlow { 596 | border-left: 1px dotted black; 597 | padding-left: 1em; 598 | padding-right: 1em; 599 | margin-top: 1em; 600 | margin-bottom: 1em; 601 | margin-left: 0em; 602 | margin-right: 2em; 603 | white-space: nowrap; 604 | line-height: 1.5; 605 | } 606 | 607 | .SCodeFlow img { 608 | margin-top: 0.5em; 609 | margin-bottom: 0.5em; 610 | } 611 | 612 | /* put a little air between lines of code sample */ 613 | /* Fira Mono appears taller than Source Code Pro */ 614 | .SCodeFlow td { 615 | padding-bottom: 1px; 616 | } 617 | 618 | .boxed { 619 | margin: 0; 620 | margin-top: 2em; 621 | padding: 0.25em; 622 | padding-top: 0.3em; 623 | padding-bottom: 0.4em; 624 | background: #f3f3f3; 625 | box-sizing:border-box; 626 | border-top: 1px solid #99b; 627 | background: hsl(216, 78%, 95%); 628 | background: -moz-linear-gradient(to bottom left, hsl(0, 0%, 99%) 0%, hsl(216, 62%, 95%) 100%); 629 | background: -webkit-linear-gradient(to bottom left, hsl(0, 0%, 99%) 0%, hsl(216, 62%, 95%) 100%); 630 | background: -o-linear-gradient(to bottom left, hsl(0, 0%, 99%) 0%, hsl(216, 62%, 95%) 100%); 631 | background: -ms-linear-gradient(to bottom left, hsl(0, 0%, 99%) 0%, hsl(216, 62%, 95%) 100%); 632 | background: linear-gradient(to bottom left, hsl(0, 0%, 99%) 0%, hsl(216, 62%, 95%) 100%); 633 | } 634 | 635 | blockquote > blockquote.SVInsetFlow { 636 | /* resolves issue in e.g. /reference/notation.html */ 637 | margin-top: 0em; 638 | } 639 | 640 | .leftindent .SVInsetFlow { /* see e.g. section 4.5 of Racket Guide */ 641 | margin-top: 1em; 642 | margin-bottom: 1em; 643 | } 644 | 645 | .SVInsetFlow a, .SCodeFlow a { 646 | color: #07A; 647 | } 648 | 649 | .SubFlow { 650 | display: block; 651 | margin: 0em; 652 | } 653 | 654 | .boxed { 655 | width: 100%; 656 | background-color: inherit; 657 | } 658 | 659 | .techoutside { text-decoration: none; } 660 | 661 | .SAuthorListBox { 662 | position: static; 663 | float: none; 664 | font-family: 'Fira', sans-serif; 665 | font-weight: 300; 666 | font-size: 110%; 667 | margin-top: 1rem; 668 | margin-bottom: 2rem; 669 | width: 30rem; 670 | height: auto; 671 | } 672 | 673 | .author > a { /* email links within author block */ 674 | font-weight: inherit; 675 | color: inherit; 676 | } 677 | 678 | .SAuthorList { 679 | font-size: 82%; 680 | } 681 | .SAuthorList:before { 682 | content: "by "; 683 | } 684 | .author { 685 | display: inline; 686 | white-space: nowrap; 687 | } 688 | 689 | /* phone + tablet styles */ 690 | 691 | @media all and (max-width:720px){ 692 | 693 | 694 | @media all and (max-width:720px){ 695 | 696 | @media all {html {font-size: 15px;}} 697 | @media all and (max-width:700px){html {font-size: 14px;}} 698 | @media all and (max-width:630px){html {font-size: 13px;}} 699 | @media all and (max-width:610px){html {font-size: 12px;}} 700 | @media all and (max-width:550px){html {font-size: 11px;}} 701 | @media all and (max-width:520px){html {font-size: 10px;}} 702 | 703 | .navsettop, .navsetbottom { 704 | display: flex; 705 | position: absolute; 706 | width: 100%; 707 | height: 4rem; 708 | border: 0; 709 | background-color: hsl(216, 15%, 70%); 710 | align-items: center; 711 | } 712 | 713 | .tocsetoverlay .navsettop { 714 | position: fixed; 715 | } 716 | 717 | .navleft { 718 | flex: 1; 719 | } 720 | 721 | .searchform { 722 | display: inline; 723 | border: 0; 724 | } 725 | 726 | .searchbox { 727 | margin-top: 0; 728 | margin-bottom: 0; 729 | } 730 | 731 | .navleft .tocsettoggle { 732 | display: initial; 733 | } 734 | 735 | .navright { 736 | margin-right: 1.3rem; 737 | border: 0px solid red; 738 | } 739 | 740 | .navsetbottom { 741 | display: block; 742 | margin-top: 8rem; 743 | } 744 | 745 | .tocset { 746 | display: none; 747 | border-top-width: 4rem; 748 | } 749 | 750 | .tocsetoverlay .tocset { 751 | display: block; 752 | } 753 | 754 | .versionbox { 755 | top: 4.5rem; 756 | left: 1rem; /* same distance as main-column */ 757 | z-index: 1; 758 | height: 2em; 759 | font-size: 70%; 760 | font-weight: lighter; 761 | } 762 | 763 | 764 | .maincolumn { 765 | margin-left: 1em; 766 | margin-top: 7rem; 767 | margin-bottom: 0rem; 768 | } 769 | 770 | } 771 | 772 | } 773 | 774 | /* print styles : hide the navigation elements */ 775 | @media print { 776 | .tocset, 777 | .navsettop, 778 | .navsetbottom { display: none; } 779 | .maincolumn { 780 | width: auto; 781 | margin-right: 13em; 782 | margin-left: 0; 783 | } 784 | } 785 | -------------------------------------------------------------------------------- /datatypes.rkt: -------------------------------------------------------------------------------- 1 | #lang plait 2 | 3 | (require "io.rkt") 4 | (require "error.rkt") 5 | (require "utilities.rkt") 6 | (require (typed-in "show.rkt" [string-of-o : (Obs -> String)])) 7 | (require (typed-in racket 8 | [random : (Number -> Number)] 9 | [list->vector : ((Listof 'a) -> (Vectorof 'a))] 10 | [vector->list : ((Vectorof 'a) -> (Listof 'a))] 11 | [vector-map : (('a -> 'b) (Vectorof 'a) -> (Vectorof 'b))] 12 | [remove-duplicates : ((Listof 'a) -> (Listof 'a))])) 13 | 14 | (define-type Block 15 | (block [def* : (Listof (Id * Term))] 16 | [exp* : (Listof Term)] 17 | [out : Term])) 18 | 19 | (define-type-alias CompiledProgram ((Listof (Id * Term)) * (Listof Term))) 20 | (define-type Term 21 | (t-quote [v : Val]) 22 | (t-var [x : Id]) 23 | (t-fun [name : (Optionof Symbol)] 24 | [arg* : (Listof Id)] 25 | [body : Block]) 26 | (t-app [fun : Term] [arg* : (Listof Term)]) 27 | (t-let [bind* : (Listof (Id * Term))] [body : Block]) 28 | (t-letrec [bind* : (Listof (Id * Term))] [body : Block]) 29 | (t-set! [var : Id] [val : Term]) 30 | (t-seq [is-block : Boolean] [prelude* : (Listof Term)] [result : Term]) 31 | (t-if [cnd : Term] [thn : Term] [els : Term]) 32 | (t-cond [cnd-thn* : (Listof (Term * Term))] [els : (Optionof Term)])) 33 | (define (t-block prelude* result) 34 | (t-seq #t prelude* result)) 35 | (define (t-begin prelude* result) 36 | (t-seq #f prelude* result)) 37 | 38 | (define (t-or t1 t2) 39 | (t-if t1 40 | (t-quote (v-bool #t)) 41 | t2)) 42 | (define (t-and t1 t2) 43 | (t-if t1 44 | t2 45 | (t-quote (v-bool #f)))) 46 | 47 | (define-type-alias (Result 'a) 'a) 48 | (define-type Heap 49 | (heap-heap [it : (Hashof HeapAddress (Number * HeapValue))])) 50 | (define (empty-heap) : Heap 51 | (heap-heap (hash (list)))) 52 | (define the-heap-size 1000) 53 | (define (find-heap-addr the-heap [base : Number]) : Number 54 | (let ([propose (+ base (random the-heap-size))]) 55 | (type-case (Optionof (Number * HeapValue)) (hash-ref the-heap (ha-user propose)) 56 | [(none) propose] 57 | [(some hv) (find-heap-addr the-heap base)]))) 58 | (define (base-addr [hv : HeapValue]) 59 | (type-case HeapValue hv 60 | [(h-env env map) the-heap-size] 61 | [else 0])) 62 | (define (allocate! [a-heap : Heap] [hv : HeapValue]) : (Heap * HeapAddress) 63 | (let* ([a-heap (heap-heap-it a-heap)] 64 | [addr (ha-user (find-heap-addr a-heap (base-addr hv)))] 65 | [a-heap (hash-set a-heap addr (pair (length (hash-keys a-heap)) hv))]) 66 | (values (heap-heap a-heap) addr))) 67 | (define (heap-ref a-heap a-heap-address) : HeapValue 68 | (type-case (Optionof (Number * HeapValue)) (hash-ref (heap-heap-it a-heap) a-heap-address) 69 | [(none) 70 | (raise (exn-internal 'heap-ref (format "Invalid address ~a" a-heap-address)))] 71 | [(some hv) 72 | (snd hv)])) 73 | (define (heap-set [h : Heap] [ha : HeapAddress] [hv : HeapValue]) : Heap 74 | (let* ([h (heap-heap-it h)] 75 | [timestamp 76 | (type-case (Optionof (Number * HeapValue)) (hash-ref h ha) 77 | [(none) (length (hash-keys h))] 78 | [(some v) (fst v)])]) 79 | (heap-heap (hash-set h ha (pair timestamp hv))))) 80 | 81 | (define-type HeapAddress 82 | (ha-prim [it : PrimitiveHeapAddress]) 83 | (ha-user [it : Number])) 84 | (define-type PrimitiveHeapAddress 85 | (pa-empty) 86 | (pa-map) 87 | (pa-filter) 88 | (pa-memberp) 89 | (pa-foldl) 90 | (pa-foldr) 91 | (pa-andmap) 92 | (pa-ormap) 93 | (pa-base-env)) 94 | (define-type HeapValue 95 | (h-vec [it : (Vectorof Val)]) 96 | (h-cons [it : (Val * Val)]) 97 | (h-fun [env : Env] [name : (Optionof Symbol)] [arg* : (Listof Id)] [body : Block]) 98 | (h-env [parent : Env] [map : (Listof (Id * (Optionof Val)))])) 99 | (define-type Val 100 | (v-addr [it : HeapAddress]) 101 | (v-prim [name : PrimitiveOp]) 102 | (v-str [it : String]) 103 | (v-num [it : Number]) 104 | (v-char [it : Char]) 105 | (v-bool [it : Boolean]) 106 | (v-empty) 107 | (v-void)) 108 | (define (v-fun [the-heap : Heap] [env : Env] name arg* body) 109 | (let-values (((the-heap addr) (allocate! the-heap (h-fun env name arg* body)))) 110 | (values the-heap (v-addr addr)))) 111 | (define (v-vec [the-heap : Heap] it) 112 | (let-values (((the-heap addr) (allocate! the-heap (h-vec it)))) 113 | (values the-heap (v-addr addr)))) 114 | (define (v-cons [the-heap : Heap] it) 115 | (let-values (((the-heap addr) (allocate! the-heap (h-cons it)))) 116 | (values the-heap (v-addr addr)))) 117 | (define (v-list [the-heap : Heap] it) 118 | (if (empty? it) 119 | (values the-heap (v-empty)) 120 | (let-values (((the-heap v) (v-list the-heap (rest it)))) 121 | (let-values (((the-heap addr) (allocate! the-heap (h-cons (pair (first it) v))))) 122 | (values the-heap (v-addr addr)))))) 123 | 124 | (define-type PrimitiveOp 125 | (po-not) 126 | (po-left) 127 | (po-right) 128 | (po-vec-len) 129 | (po-string-length) 130 | (po-string-append) 131 | (po-string->list) 132 | (po-list->string) 133 | (po-eqp) 134 | (po-equalp) 135 | (po-zerop) 136 | (po-+) 137 | (po--) 138 | (po-*) 139 | (po-/) 140 | (po-<) 141 | (po->) 142 | (po-<=) 143 | (po->=) 144 | (po-=) 145 | (po-emptyp) 146 | (po-pairp) 147 | (po-mpair) 148 | (po-set-left!) 149 | (po-set-right!) 150 | (po-vec-ref) 151 | (po-consp) 152 | (po-cons) 153 | (po-vec-set!) 154 | (po-mvec) 155 | (po-first) 156 | (po-rest) 157 | (po-list)) 158 | 159 | (define-type-alias Env (Optionof HeapAddress)) 160 | (define (env-declare the-heap [env : Env] x*) 161 | (env-extend/declare the-heap env (map (lambda (x) (values x (none))) x*))) 162 | (define (env-extend the-heap [env : Env] [x&v* : (Listof (Id * Val))]) 163 | (env-extend/declare the-heap env (map2 pair (map fst x&v*) (map some (map snd x&v*))))) 164 | (define (env-extend/declare the-heap [env : Env] [x&v* : (Listof (Id * (Optionof Val)))]): (Heap * Env) 165 | (let ((x* (map fst x&v*))) 166 | (if (no-duplicates x*) 167 | (let-values (((the-heap addr) (allocate! the-heap (h-env env x&v*)))) 168 | (values the-heap (some addr))) 169 | (raise (exn-rt "redeclare"))))) 170 | 171 | (define (envmap-keys em) 172 | (map fst em)) 173 | 174 | (define (envmap-ref em x) 175 | (cond 176 | [(empty? em) (none)] 177 | [else 178 | (if (equal? (fst (first em)) x) 179 | (some (snd (first em))) 180 | (envmap-ref (rest em) x))])) 181 | 182 | (define (envmap-set em x v) 183 | (cond 184 | [(empty? em) (list (pair x v))] 185 | [else 186 | (if (equal? (fst (first em)) x) 187 | (cons (pair x v) (rest em)) 188 | (cons (first em) (envmap-set (rest em) x v)))])) 189 | 190 | (define (no-duplicates x*) 191 | (= (length x*) 192 | (length (remove-duplicates x*)))) 193 | (define (env-set the-heap [env : Env] x v) 194 | (type-case Env env 195 | [(none) 196 | (raise (exn-rt "You are using `set!` on an undefined variable!"))] 197 | [(some addr) 198 | (let* ((addr (some-v env))) 199 | (type-case HeapValue (heap-ref the-heap addr) 200 | ((h-env env map) 201 | (type-case (Optionof 'a) (envmap-ref map x) 202 | ((none) 203 | (env-set the-heap env x v)) 204 | ((some _) 205 | (heap-set 206 | the-heap 207 | addr 208 | (h-env env (envmap-set map x (some v))) )))) 209 | (else 210 | (raise (exn-internal 'env-set "This is impossible. The address is not an env.")))))])) 211 | (define (env-lookup the-heap [env : Env] x) 212 | (type-case (Optionof HeapAddress) env 213 | ((none) 214 | (none)) 215 | ((some addr) 216 | (env-lookup-1 the-heap addr x)))) 217 | (define (env-lookup-1 the-heap addr x) 218 | (type-case HeapValue (heap-ref the-heap addr) 219 | ((h-env env map) 220 | (type-case 221 | (Optionof (Optionof Val)) 222 | (envmap-ref map x) 223 | ((none) (env-lookup the-heap env x)) 224 | ((some v) 225 | (type-case 226 | (Optionof Val) 227 | v 228 | ((none) (raise (exn-rt (format "use-before-set ~a" x)))) 229 | ((some v) (some v)))))) 230 | (else 231 | (raise (exn-internal 'env-lookup "Not an env."))))) 232 | 233 | (define-type ECFrame 234 | (F-seq [is-block : Boolean] [e* : (Listof Term)] [e : Term]) 235 | (F-app [v* : (Listof Val)] [e* : (Listof Term)]) 236 | (F-let [xv* : (Listof (Id * Val))] [x : Id] [xe* : (Listof (Id * Term))] [body : Block]) 237 | (F-if [thn : Term] [els : Term]) 238 | (F-set! [var : Id]) 239 | (P-def [x : Id] [d* : (Listof (Id * Term))] [e* : (Listof Term)]) 240 | (P-exp [v* : (Listof Val)] [e* : (Listof Term)])) 241 | (define-type-alias ECtx (Listof ECFrame)) 242 | (define-type CtxAnn 243 | (ca-app [v : Val] [v* : (Listof Val)]) 244 | (ca-let) 245 | (ca-letrec)) 246 | (define-type-alias Ctx (Env * ECtx * CtxAnn)) 247 | (define-type-alias Stack (Listof Ctx)) 248 | 249 | (define (uninteresting-variable? x) 250 | (member x builtins)) 251 | (define-values (base-heap base-env builtins) 252 | (let* ((the-heap (empty-heap)) 253 | [x&v* (ind-List 254 | (list 255 | (values 'string->list (po-string->list)) 256 | (values 'first (po-first)) 257 | (values 'rest (po-rest)) 258 | (values 'not (po-not)) 259 | (values 'left (po-left)) 260 | (values 'string-length (po-string-length)) 261 | (values 'string-append (po-string-append)) 262 | (values 'string->list (po-string->list)) 263 | (values 'list->string (po-list->string)) 264 | (values 'right (po-right)) 265 | (values 'vec-len (po-vec-len)) 266 | (values 'equal? (po-equalp)) 267 | (values 'eq? (po-eqp)) 268 | (values 'zero? (po-zerop)) 269 | (values '+ (po-+)) 270 | (values '- (po--)) 271 | (values '* (po-*)) 272 | (values '/ (po-/)) 273 | (values '< (po-<)) 274 | (values '> (po->)) 275 | (values '<= (po-<=)) 276 | (values '>= (po->=)) 277 | (values '= (po-=)) 278 | (values 'empty? (po-emptyp)) 279 | (values 'pair? (po-pairp)) 280 | (values 'pair (po-mpair)) 281 | (values 'mpair (po-mpair)) 282 | (values 'set-left! (po-set-left!)) 283 | (values 'set-right! (po-set-right!)) 284 | (values 'vec-ref (po-vec-ref)) 285 | (values 'cons (po-cons)) 286 | (values 'cons? (po-consp)) 287 | (values 'vec-set! (po-vec-set!)) 288 | (values 'vec (po-mvec)) 289 | (values 'mvec (po-mvec)) 290 | (values 'list (po-list))) 291 | (list) 292 | (λ (IH e) 293 | (cons (values (fst e) 294 | (v-prim (snd e))) 295 | IH)))] 296 | [base-env-map (append 297 | (map2 pair 298 | (map fst x&v*) 299 | (map some (map snd x&v*))) 300 | (list (pair 'empty (some (v-empty))) 301 | (pair 'map (some (v-addr (ha-prim (pa-map))))) 302 | (pair 'filter (some (v-addr (ha-prim (pa-filter))))) 303 | (pair 'member? (some (v-addr (ha-prim (pa-memberp))))) 304 | (pair 'foldl (some (v-addr (ha-prim (pa-foldl))))) 305 | (pair 'foldr (some (v-addr (ha-prim (pa-foldr))))) 306 | (pair 'andmap (some (v-addr (ha-prim (pa-andmap))))) 307 | (pair 'ormap (some (v-addr (ha-prim (pa-ormap))))) 308 | (pair 'false (some (v-bool #f))) 309 | (pair 'true (some (v-bool #t)))))] 310 | [builtins (envmap-keys base-env-map)] 311 | [addr (ha-prim (pa-base-env))] 312 | [hv (h-env (none) base-env-map)] 313 | [the-heap (heap-set the-heap addr hv)] 314 | [base-env (some addr)] 315 | (the-heap (heap-set the-heap (ha-prim (pa-map)) 316 | (h-fun base-env 317 | (some 'map) 318 | (list 'f 'xs) 319 | (block 320 | (list) 321 | (list) 322 | (t-if (t-app (t-var 'equal?) (list (t-var 'xs) (t-var 'empty))) 323 | (t-var 'empty) 324 | (t-app (t-var 'cons) 325 | (list (t-app (t-var 'f) 326 | (list (t-app (t-quote (v-prim (po-first))) 327 | (list (t-var 'xs))))) 328 | (t-app (t-var 'map) 329 | (list (t-var 'f) 330 | (t-app (t-quote (v-prim (po-rest))) 331 | (list (t-var 'xs)))))))))))) 332 | (the-heap (heap-set the-heap (ha-prim (pa-memberp)) 333 | (h-fun base-env 334 | (some 'member?) 335 | (list 'x 'l) 336 | (block 337 | (list) 338 | (list) 339 | (t-if (t-app (t-var 'equal?) (list (t-var 'l) (t-var 'empty))) 340 | (t-quote (v-bool #f)) 341 | (t-or (t-app (t-var 'equal?) 342 | (list (t-app (t-quote (v-prim (po-first))) 343 | (list (t-var 'l))) 344 | (t-var 'x))) 345 | (t-app (t-var 'member?) 346 | (list (t-var 'x) 347 | (t-app (t-quote (v-prim (po-rest))) 348 | (list (t-var 'l))))))))))) 349 | (the-heap (heap-set the-heap (ha-prim (pa-filter)) 350 | (h-fun base-env 351 | (some 'filter) 352 | (list 'f 'xs) 353 | (block 354 | (list) 355 | (list) 356 | (t-if (t-app (t-var 'equal?) (list (t-var 'xs) (t-var 'empty))) 357 | (t-var 'empty) 358 | (t-if (t-app (t-var 'f) 359 | (list (t-app (t-quote (v-prim (po-first))) 360 | (list (t-var 'xs))))) 361 | (t-app (t-var 'cons) 362 | (list (t-app (t-quote (v-prim (po-first))) 363 | (list (t-var 'xs))) 364 | (t-app (t-var 'filter) 365 | (list (t-var 'f) 366 | (t-app (t-quote (v-prim (po-rest))) 367 | (list (t-var 'xs))))))) 368 | (t-app (t-var 'filter) 369 | (list (t-var 'f) 370 | (t-app (t-quote (v-prim (po-rest))) 371 | (list (t-var 'xs))))))))))) 372 | (the-heap (heap-set the-heap (ha-prim (pa-foldl)) 373 | (h-fun base-env 374 | (some 'foldl) 375 | (list 'f 'base 'l) 376 | (block 377 | (list) 378 | (list) 379 | (t-if (t-app (t-var 'equal?) (list (t-var 'l) (t-var 'empty))) 380 | (t-var 'base) 381 | (t-app (t-var 'foldl) 382 | (list 383 | (t-var 'f) 384 | (t-app (t-var 'f) 385 | (list 386 | (t-app (t-quote (v-prim (po-first))) 387 | (list (t-var 'l))) 388 | (t-var 'base))) 389 | (t-app (t-quote (v-prim (po-rest))) 390 | (list (t-var 'l)))))))))) 391 | (the-heap (heap-set the-heap (ha-prim (pa-foldr)) 392 | (h-fun base-env 393 | (some 'foldr) 394 | (list 'f 'base 'l) 395 | (block 396 | (list) 397 | (list) 398 | (t-if (t-app (t-var 'equal?) (list (t-var 'l) (t-var 'empty))) 399 | (t-var 'base) 400 | (t-app (t-var 'f) 401 | (list 402 | (t-app (t-quote (v-prim (po-first))) 403 | (list (t-var 'l))) 404 | (t-app (t-var 'foldr) 405 | (list 406 | (t-var 'f) 407 | (t-var 'base) 408 | (t-app (t-quote (v-prim (po-rest))) 409 | (list (t-var 'l)))))))))))) 410 | (the-heap (heap-set the-heap (ha-prim (pa-andmap)) 411 | (h-fun base-env 412 | (some 'andmap) 413 | (list 'p? 'l) 414 | (block 415 | (list) 416 | (list) 417 | (t-if (t-app (t-var 'equal?) (list (t-var 'l) (t-var 'empty))) 418 | (t-quote (v-bool #t)) 419 | (t-and (t-app (t-var 'p?) 420 | (list 421 | (t-app (t-quote (v-prim (po-first))) 422 | (list (t-var 'l))))) 423 | (t-app (t-var 'andmap) 424 | (list 425 | (t-var 'p?) 426 | (t-app (t-quote (v-prim (po-rest))) 427 | (list (t-var 'l))))))))))) 428 | (the-heap (heap-set the-heap (ha-prim (pa-ormap)) 429 | (h-fun base-env 430 | (some 'andmap) 431 | (list 'p? 'l) 432 | (block 433 | (list) 434 | (list) 435 | (t-if (t-app (t-var 'equal?) (list (t-var 'l) (t-var 'empty))) 436 | (t-quote (v-bool #t)) 437 | (t-or (t-app (t-var 'p?) 438 | (list 439 | (t-app (t-quote (v-prim (po-first))) 440 | (list (t-var 'l))))) 441 | (t-app (t-var 'andmap) 442 | (list 443 | (t-var 'p?) 444 | (t-app (t-quote (v-prim (po-rest))) 445 | (list (t-var 'l))))))))))) 446 | ) 447 | (values the-heap base-env builtins))) 448 | 449 | (define-type Operator 450 | (op-prim [name : PrimitiveOp]) 451 | (op-fun [env : Env] [arg* : (Listof Id)] [body : Block])) 452 | 453 | (define-type OtherState 454 | (setting [x : Id] [v : Val] [env : Env] [ectx : ECtx] [stack : Stack]) 455 | (setted [env : Env] [ectx : ECtx] [stack : Stack]) 456 | (vector-setting [addr : HeapAddress] [it : (Vectorof Val)] [i : Number] [velm : Val] 457 | [env : Env] [ectx : ECtx] [stack : Stack]) 458 | (calling [fun : Val] [args* : (Listof Val)] [env : Env] [ectx : ECtx] [stack : Stack] 459 | [clos-env : Env] [arg* : (Listof Id)] [body : Block]) 460 | (called [e : Term] [env : Env] [stack : Stack]) 461 | (returning [v : Val] [stack : Stack]) 462 | (returned [v : Val] [env : Env] [ectx : ECtx] [stack : Stack]) 463 | (terminated [v* : (Listof Val)]) 464 | (errored)) 465 | (define-type-alias State (Heap * OtherState)) 466 | -------------------------------------------------------------------------------- /s-exp-of-state.rkt: -------------------------------------------------------------------------------- 1 | #lang plait 2 | 3 | (require "utilities.rkt") 4 | (require "datatypes.rkt") 5 | (require "error.rkt") 6 | (require "io.rkt") 7 | (require 8 | (opaque-type-in racket 9 | (Port port?)) 10 | (typed-in racket 11 | (open-output-string : (-> Port)) 12 | (get-output-string : (Port -> String)) 13 | (write : ('a Port -> Void)) 14 | (append* : ((Listof (Listof 'a)) -> (Listof 'a))) 15 | (vector->list : ((Vectorof 'a) -> (Listof 'a))))) 16 | (require (opaque-type-in pprint (Doc doc?)) 17 | (typed-in pprint 18 | (text : (String -> Doc)) 19 | (group : (Doc -> Doc)) 20 | (align : (Doc -> Doc)) 21 | (hang : (Number Doc -> Doc)) 22 | (v-concat : ((Listof Doc) -> Doc)) 23 | (v-append : (Doc Doc -> Doc)) 24 | (vs-concat : ((Listof Doc) -> Doc)) 25 | (h-concat : ((Listof Doc) -> Doc)) 26 | (hs-concat : ((Listof Doc) -> Doc)) 27 | (pretty-format : (Doc -> String)))) 28 | (require 29 | (rename-in (typed-in pprint [pretty-format : (Doc Number -> String)]) 30 | [pretty-format pretty-format/n])) 31 | (require (typed-in "show.rkt" [string-of-o : (Obs -> String)])) 32 | (require (typed-in racket 33 | [number->string : (Number -> String)] 34 | [vector-map : (('a -> 'b) (Vectorof 'a) -> (Vectorof 'b))] 35 | [sort : ((Listof 'x) ('x 'x -> Boolean) -> (Listof 'x))] 36 | [append* : ((Listof (Listof 'x)) -> (Listof 'x))])) 37 | (require (opaque-type-in racket [Any any/c])) 38 | (require (rename-in (typed-in racket [identity : ('a -> Any)]) [identity inj])) 39 | 40 | 41 | (define (string-of-o-of-v the-heap) 42 | (let ([obs (obs-of-val the-heap)]) 43 | (lambda (v) 44 | (string-of-o (obs v))))) 45 | (define (obs-of-val the-heap) 46 | (lambda (v) 47 | (local ([define counter 0] 48 | (define obs-of-hv 49 | (lambda (visited) 50 | (lambda (hv) 51 | (type-case HeapValue hv 52 | ((h-vec vs) (o-vec (vector-map (obs-of-val visited) vs))) 53 | ((h-cons vs) (o-list (cons ((obs-of-val visited) (fst vs)) 54 | (o-list-it ((obs-of-val visited) (snd vs)))))) 55 | ((h-fun env name arg* body) 56 | (o-fun (type-case (Optionof '_) name 57 | [(none) (none)] 58 | [(some x) (some (symbol->string x))]))) 59 | ((h-env _env _map) 60 | (raise (exn-internal 'obs-of-val "Impossible."))))))) 61 | [define obs-of-val 62 | (lambda (visited) 63 | (lambda (v) 64 | (type-case 65 | Val 66 | v 67 | ((v-str it) (o-con (c-str it))) 68 | ((v-num it) (o-con (c-num it))) 69 | ((v-bool it) (o-con (c-bool it))) 70 | ((v-char it) (o-con (c-char it))) 71 | ((v-prim name) (o-fun (some (pretty-format (doc-of-prim name))))) 72 | ((v-empty) (o-list '())) 73 | ((v-void) (o-void)) 74 | ((v-addr addr) 75 | (type-case (Optionof '_) (hash-ref visited addr) 76 | [(none) 77 | (let* ([bx (box (none))] 78 | [visited (hash-set visited addr bx)]) 79 | (let ([o ((obs-of-hv visited) (heap-ref the-heap addr))]) 80 | (type-case (Optionof Number) (unbox bx) 81 | [(none) o] 82 | [(some id) (o-rec id o)])))] 83 | [(some bx) 84 | (begin 85 | (when (equal? (unbox bx) (none)) 86 | (set-box! bx (some counter)) 87 | (set! counter (add1 counter))) 88 | (o-var (some-v (unbox bx))))])))))]) 89 | ((obs-of-val (hash (list))) v)))) 90 | 91 | (define (symbol x) 92 | (text x)) 93 | 94 | (define (doc-of-any s) 95 | (let* ([p (open-output-string)] 96 | [_ (write s p)]) 97 | (text (get-output-string p)))) 98 | 99 | (define (doc-of-x (x : Symbol)) 100 | (symbol (symbol->string x))) 101 | 102 | (define (doc-of-prim p) 103 | (type-case PrimitiveOp p 104 | [(po-not) 105 | (doc-of-x 'not)] 106 | [(po-left) 107 | (doc-of-x 'left)] 108 | [(po-right) 109 | (doc-of-x 'right)] 110 | [(po-vec-len) 111 | (doc-of-x 'vec-len)] 112 | [(po-eqp) 113 | (doc-of-x 'equal?)] 114 | [(po-equalp) 115 | (doc-of-x 'equal?)] 116 | [(po-zerop) 117 | (doc-of-x 'zero?)] 118 | [(po-+) 119 | (doc-of-x '+)] 120 | [(po--) 121 | (doc-of-x '-)] 122 | [(po-*) 123 | (doc-of-x '*)] 124 | [(po-/) 125 | (doc-of-x '/)] 126 | [(po-<) 127 | (doc-of-x '<)] 128 | [(po->) 129 | (doc-of-x '>)] 130 | [(po-<=) 131 | (doc-of-x '<=)] 132 | [(po->=) 133 | (doc-of-x '>=)] 134 | [(po-=) 135 | (doc-of-x '=)] 136 | [(po-emptyp) 137 | (doc-of-x 'empty?)] 138 | [(po-consp) 139 | (doc-of-x 'cons?)] 140 | [(po-pairp) 141 | (doc-of-x 'pair?)] 142 | [(po-string-length) 143 | (doc-of-x 'string-length)] 144 | [(po-string-append) 145 | (doc-of-x 'string-append)] 146 | [(po-string->list) 147 | (doc-of-x 'string->list)] 148 | [(po-list->string) 149 | (doc-of-x 'list->string)] 150 | [(po-mpair) 151 | (doc-of-x 'mpair)] 152 | [(po-set-left!) 153 | (doc-of-x 'set-left!)] 154 | [(po-set-right!) 155 | (doc-of-x 'set-right!)] 156 | [(po-vec-ref) 157 | (doc-of-x 'vec-ref)] 158 | [(po-cons) 159 | (doc-of-x 'cons)] 160 | [(po-first) 161 | (doc-of-x 'first)] 162 | [(po-rest) 163 | (doc-of-x 'rest)] 164 | [(po-vec-set!) 165 | (doc-of-x 'vec-set!)] 166 | [(po-mvec) 167 | (doc-of-x 'mvec)] 168 | [(po-list) 169 | (doc-of-x 'list)])) 170 | 171 | (define (doc-list d*) 172 | (doc-paren (hs-concat d*))) 173 | 174 | (define (doc-paren d) 175 | (h-concat 176 | (list 177 | (text "(") 178 | (align d) 179 | (text ")")))) 180 | 181 | (define (doc-brack d) 182 | (h-concat 183 | (list 184 | (text "[") 185 | (align d) 186 | (text "]")))) 187 | 188 | (define (doc-brack-pair d1 d2) 189 | (doc-brack 190 | (hs-concat 191 | (list 192 | d1 193 | d2)))) 194 | 195 | (define (head-body head-element* body) 196 | (doc-paren 197 | (v-concat 198 | (list 199 | (hang 1 (v-append (hs-concat head-element*) body)))))) 200 | 201 | 202 | (define (s-exp-of-state hide-fun-addr? defvar-lambda-as-deffun? set!-lambda-as-def? set!-other-as-def?) 203 | (lambda (state) 204 | (let-values (((the-heap state) state)) 205 | (local ((define (stringify-ha [it : HeapAddress]) : String 206 | (type-case HeapAddress it 207 | [(ha-user it) 208 | (let ([printing (format "~a" it)]) 209 | (type-case HeapValue (heap-ref the-heap (ha-user it)) 210 | ((h-fun env name arg* body) 211 | (type-case (Optionof Symbol) name 212 | ((some s) 213 | (if hide-fun-addr? 214 | (format "~a" s) 215 | (string-append printing (format ".~a" s)))) 216 | ((none) 217 | printing))) 218 | (else 219 | printing)))] 220 | [(ha-prim it) 221 | (string-of-primitive-address it)])) 222 | (define (doc-of-ha ha) 223 | (text (stringify-ha ha))) 224 | (define (string-of-primitive-address pa) 225 | (type-case PrimitiveHeapAddress pa 226 | [(pa-map) (symbol->string 'map)] 227 | [(pa-filter) (symbol->string 'filter)] 228 | [(pa-memberp) (symbol->string 'member?)] 229 | [(pa-foldl) (symbol->string 'foldl)] 230 | [(pa-foldr) (symbol->string 'foldr)] 231 | [(pa-andmap) (symbol->string 'andmap)] 232 | [(pa-ormap) (symbol->string 'ormap)] 233 | [(pa-base-env) (symbol->string 'primordial-env)] 234 | [(pa-empty) (symbol->string 'empty)])) 235 | (define (doc-of-v v) 236 | (type-case Val v 237 | ((v-addr it) 238 | (h-concat (list (text "@") (doc-of-ha it)))) 239 | ((v-prim name) 240 | (doc-of-prim name)) 241 | ((v-str it) 242 | (doc-of-any it)) 243 | ((v-num it) 244 | (doc-of-any it)) 245 | ((v-bool it) 246 | (doc-of-any it)) 247 | ((v-char it) 248 | (doc-of-any it)) 249 | ((v-empty) 250 | (text "'()")) 251 | ((v-void) 252 | (text "#")))) 253 | (define (doc-of-def def) 254 | (local ((define-values (x e) def)) 255 | (if (and defvar-lambda-as-deffun? (t-fun? e)) 256 | (doc-of-deffun x 257 | (t-fun-arg* e) 258 | (t-fun-body e)) 259 | (group 260 | (head-body 261 | (list 262 | (symbol "defvar") 263 | (doc-of-x x)) 264 | (doc-of-e e)))))) 265 | (define (doc-of-body [body : Block]) : Doc 266 | (let ([def* (block-def* body)] 267 | [exp* (block-exp* body)] 268 | [out (block-out body)]) 269 | (v-concat 270 | (append 271 | (map doc-of-def def*) 272 | (append 273 | (map doc-of-e exp*) 274 | (list (doc-of-e out))))))) 275 | (define (doc-of-deffun x arg* [body : Block]) 276 | (head-body 277 | (list 278 | (symbol "deffun") 279 | (doc-list 280 | (cons (doc-of-x x) 281 | (map doc-of-x arg*)))) 282 | (doc-of-body body))) 283 | (define (doc-lambda arg* [body : Doc]) 284 | (head-body 285 | (list 286 | (symbol "lambda") 287 | (doc-list arg*)) 288 | body)) 289 | (define (doc-app e*) 290 | (doc-list e*)) 291 | (define (doc-let bind* body) 292 | (head-body 293 | (list 294 | (symbol "let") 295 | (doc-paren 296 | (v-concat bind*))) 297 | body)) 298 | (define (doc-letrec bind* body) 299 | (head-body 300 | (list 301 | (symbol "letrec") 302 | (doc-paren 303 | (v-concat bind*))) 304 | body)) 305 | (define (doc-set! x e) 306 | (group 307 | (if set!-other-as-def? 308 | (head-body 309 | (list 310 | (symbol "defvar") 311 | x) 312 | e) 313 | (head-body 314 | (list 315 | (symbol "set!") 316 | x) 317 | e)))) 318 | (define (doc-of-set! x e) 319 | (cond 320 | [(and set!-lambda-as-def? (t-fun? e)) 321 | (doc-of-def (values x e))] 322 | [(and set!-other-as-def? (not (t-fun? e))) 323 | (doc-of-def (values x e))] 324 | [else 325 | (group 326 | (head-body 327 | (list 328 | (symbol "set!") 329 | (doc-of-x x)) 330 | (doc-of-e e)))])) 331 | (define (doc-begin e* e) 332 | (if (empty? e*) 333 | e 334 | (head-body 335 | (list 336 | (symbol "begin")) 337 | (v-concat (append e* (list e)))))) 338 | (define (doc-if e*) 339 | (doc-paren 340 | (hs-concat 341 | (list 342 | (text "if") 343 | (align (v-concat e*)))))) 344 | (define (doc-cond ee*) 345 | (head-body 346 | (list 347 | (symbol "cond")) 348 | (v-concat 349 | ee*))) 350 | (define (doc-of-e-top e) : Doc 351 | (type-case Term e 352 | [(t-seq b e* e) 353 | (v-concat (map doc-of-e (append e* (list e))))] 354 | [else 355 | (doc-of-e e)])) 356 | (define (doc-of-e e) : Doc 357 | (type-case Term e 358 | [(t-quote v) 359 | (doc-of-v v)] 360 | [(t-var x) 361 | (doc-of-x x)] 362 | [(t-fun name arg* body) 363 | (doc-lambda 364 | (map doc-of-x arg*) 365 | (doc-of-body body))] 366 | [(t-app fun arg*) 367 | (doc-app 368 | (map doc-of-e (cons fun arg*)))] 369 | [(t-let bind* body) 370 | (doc-let 371 | (map doc-of-xe bind*) 372 | (doc-of-body body))] 373 | [(t-letrec bind* body) 374 | (doc-letrec 375 | (map doc-of-xe bind*) 376 | (doc-of-body body))] 377 | [(t-set! x e) 378 | (doc-of-set! x e)] 379 | [(t-seq is-block e* e) 380 | (doc-of-seq is-block (map doc-of-e e*) (doc-of-e e))] 381 | [(t-if cnd thn els) 382 | (doc-if (map doc-of-e (list cnd thn els)))] 383 | [(t-cond cnd-thn* els) 384 | (doc-cond 385 | (map doc-of-ee 386 | (append 387 | cnd-thn* 388 | (type-case (Optionof '_) els 389 | [(none) (list)] 390 | [(some e) 391 | (list (values (t-var 'else) e))]))))])) 392 | (define (doc-of-seq is-block e* e) 393 | (if is-block 394 | (v-concat (append e* (list e))) 395 | (doc-begin e* e))) 396 | (define (doc-of-xe xe) 397 | (local [(define-values (x e) xe)] 398 | (doc-of-ee (values (t-var x) e)))) 399 | (define (doc-of-ee [ee : (Term * Term)]) 400 | (local [(define-values (e1 e2) ee)] 401 | (doc-brack 402 | (hs-concat 403 | (list 404 | (doc-of-e e1) 405 | (doc-of-e e2)))))) 406 | (define (doc-of-xv [xv : (Id * Val)]) 407 | (local [(define-values (x v) xv)] 408 | (doc-brack-pair 409 | (doc-of-x x) 410 | (doc-of-v v)))) 411 | (define (doc-of-f f) 412 | (lambda ([□ : Doc]) 413 | (type-case ECFrame f 414 | ((F-seq is-block e* e) 415 | (doc-of-seq is-block (cons □ (map doc-of-e e*)) (doc-of-e e))) 416 | ((F-app v* e*) 417 | (doc-app (append 418 | (map doc-of-v v*) 419 | (cons 420 | □ 421 | (map doc-of-e e*))))) 422 | ((F-let xv* x xe* body) 423 | (doc-let 424 | (append* 425 | (list 426 | (map doc-of-xv xv*) 427 | (list (doc-brack-pair (doc-of-x x) □)) 428 | (map doc-of-xe xe*))) 429 | (doc-of-body body))) 430 | ((F-if thn els) 431 | (doc-if (list □ (doc-of-e thn) (doc-of-e els)))) 432 | ((F-set! x) 433 | (doc-set! (doc-of-x x) □)) 434 | ((P-def x d* e*) 435 | (v-concat 436 | (append* 437 | (list 438 | (list (doc-set! (doc-of-x x) □)) 439 | (map doc-of-def d*) 440 | (map doc-of-e e*))))) 441 | ((P-exp v* e*) 442 | (v-concat 443 | (append 444 | (map doc-of-v v*) 445 | (cons □ (map doc-of-e e*)))))))) 446 | (define (s-exp-of-stack stack) 447 | (inj (map s-exp-of-sf stack))) 448 | (define (s-exp-of-heap heap) 449 | (let* ([heap (heap-heap-it heap)] 450 | [interesting-items 451 | (map 452 | (lambda (key) 453 | (pair key (some-v (hash-ref heap key)))) 454 | (filter ha-user? (hash-keys heap)))] 455 | [interesting-items 456 | (sort interesting-items 457 | (lambda (item1 item2) 458 | (< (fst (snd item1)) 459 | (fst (snd item2)))))]) 460 | (inj 461 | (map 462 | (lambda (item) 463 | (let-values ([(ha timestamp&hv) item]) 464 | (inj (list (inj (string-of-ha ha)) (s-exp-of-hv (snd timestamp&hv)))))) 465 | interesting-items)))) 466 | (define (doc-of-ca ca) 467 | (type-case CtxAnn ca 468 | [(ca-app v v*) 469 | (doc-app (map doc-of-v (cons v v*)))] 470 | [(ca-let) 471 | (text "(let ...)")] 472 | [(ca-letrec) 473 | (text "(letrec ...)")])) 474 | (define (s-exp-of-hv [hv : HeapValue]) : Any 475 | (type-case HeapValue hv 476 | [(h-vec it) 477 | (inj (cons "vec" (map string-of-v (vector->list it))))] 478 | [(h-cons it) 479 | (inj (list "cons" (string-of-v (fst it)) (string-of-v (snd it))))] 480 | [(h-fun env name arg* body) 481 | (inj (list "fun" (string-of-env env) (string-of-e (t-fun name arg* body))))] 482 | [(h-env env binding*) 483 | (inj 484 | (list 485 | (inj "env") 486 | (inj (string-of-env env)) 487 | (inj 488 | (ind-List (envmap-keys binding*) 489 | (list) 490 | (lambda (IH x) 491 | (cons 492 | (list 493 | (string-of-x x) 494 | (string-of-optionof-v (some-v (envmap-ref binding* x)))) 495 | IH))))))])) 496 | (define (string-of-optionof-v ov) 497 | (type-case (Optionof '_) ov 498 | [(none) 499 | "💣"] 500 | [(some v) 501 | (string-of-v v)])) 502 | (define (string-of-env env) 503 | (type-case (Optionof '_) env 504 | [(none) 505 | "💣"] 506 | [(some ha) 507 | (string-of-ha ha)])) 508 | (define (s-exp-of-sf sf) 509 | (local ((define-values (env ectx ann) sf)) 510 | (inj (list (string-of-env env) (string-of-ectx ectx) (string-of-ann ann))))) 511 | (define (string-of-ann ann) 512 | (pretty-format (doc-of-ca ann))) 513 | (define (string-of-x x) 514 | (pretty-format (doc-of-x x))) 515 | (define (string-of-e e) 516 | (pretty-format/n (doc-of-e e) 20)) 517 | (define (string-of-e-top body) 518 | (begin 519 | (pretty-format/n (doc-of-e-top body) 20))) 520 | (define (string-of-ha ha) 521 | (pretty-format (doc-of-ha ha))) 522 | (define (string-of-v v) 523 | (pretty-format (doc-of-v v))) 524 | (define (string-of-ectx ectx) 525 | (pretty-format/n 526 | (ind-List (reverse (map doc-of-f ectx)) 527 | (text "□") 528 | (lambda (IH x) 529 | (x IH))) 530 | 20))) 531 | (type-case OtherState state 532 | [(vector-setting addr it i velm env ectx stack) 533 | (inj (list (inj "vec-setting") 534 | (inj (string-of-e (t-app (t-quote (v-prim (po-vec-set!))) 535 | (list 536 | (t-quote (v-addr addr)) 537 | (t-quote (v-num i)) 538 | (t-quote velm))))) 539 | #;(inj (string-of-ha addr)) 540 | #;(inj (number->string i)) 541 | #;(inj (string-of-v velm)) 542 | (inj (string-of-env env)) 543 | (inj (string-of-ectx ectx)) 544 | (s-exp-of-stack stack) 545 | (s-exp-of-heap the-heap)))] 546 | [(setting x v env ectx stack) 547 | (inj (list (inj "setting") 548 | (inj (string-of-x x)) 549 | (inj (string-of-v v)) 550 | (inj (string-of-env env)) 551 | (inj (string-of-ectx ectx)) 552 | (s-exp-of-stack stack) 553 | (s-exp-of-heap the-heap)))] 554 | [(setted env ectx stack) 555 | (inj (list (inj "setted") 556 | (inj (string-of-env env)) 557 | (inj (string-of-ectx ectx)) 558 | (s-exp-of-stack stack) 559 | (s-exp-of-heap the-heap)))] 560 | [(calling fun arg* env ectx stack clos-env arg-x* body) 561 | (inj (list (inj "calling") 562 | (inj (string-of-e (t-app (t-quote fun) (map t-quote arg*)))) 563 | (inj (string-of-env env)) 564 | (inj (string-of-ectx ectx)) 565 | (s-exp-of-stack stack) 566 | (s-exp-of-heap the-heap)))] 567 | [(called body env stack) 568 | (inj (list (inj "called") 569 | (inj (string-of-e-top body)) 570 | (inj (string-of-env env)) 571 | (s-exp-of-stack stack) 572 | (s-exp-of-heap the-heap)))] 573 | [(returned v env ectx stack) 574 | (inj (list (inj "returned") 575 | (inj (string-of-v v)) 576 | (inj (string-of-env env)) 577 | (inj (string-of-ectx ectx)) 578 | (s-exp-of-stack stack) 579 | (s-exp-of-heap the-heap)))] 580 | [(returning v stack) 581 | (inj (list (inj "returning") 582 | (inj (string-of-v v)) 583 | (s-exp-of-stack stack) 584 | (s-exp-of-heap the-heap)))] 585 | [(terminated v*) 586 | (inj (list (inj "terminated") 587 | (inj (map string-of-v v*)) 588 | (s-exp-of-heap the-heap)))] 589 | [(errored) 590 | (inj (list (inj "errored") 591 | (s-exp-of-heap the-heap)))]))))) -------------------------------------------------------------------------------- /runtime.rkt: -------------------------------------------------------------------------------- 1 | #lang plait 2 | 3 | (require (opaque-type-in pict 4 | [Pict pict?])) 5 | (require (typed-in pict 6 | [text : (String -> Pict)])) 7 | (require (typed-in "pict-loop.rkt" 8 | [pict-loop : ('state 'terminated? 'forward 'pict-of-state -> Void)])) 9 | (require "utilities.rkt") 10 | (require "error.rkt") 11 | (require (typed-in "show.rkt" [string-of-o : (Obs -> String)])) 12 | (require "io.rkt") 13 | (require "datatypes.rkt") 14 | (require "s-exp-of-state.rkt") 15 | (require (typed-in racket 16 | [list->vector : ((Listof 'a) -> (Vectorof 'a))] 17 | [vector->list : ((Vectorof 'a) -> (Listof 'a))] 18 | [vector-map : (('a -> 'b) (Vectorof 'a) -> (Vectorof 'b))] 19 | [remove-duplicates : ((Listof 'a) -> (Listof 'a))] 20 | [andmap : (('a 'a -> Boolean) (Listof 'a) (Listof 'a) -> Boolean)] 21 | [take : ((Listof 'a) Number -> (Listof 'a))] 22 | [drop : ((Listof 'a) Number -> (Listof 'a))] 23 | [index-of : ((Listof 'a) 'a -> Number)] 24 | )) 25 | 26 | (define (compile [program : Program]): CompiledProgram 27 | (let* ([def* (fst program)] 28 | [exp* (snd program)] 29 | [def* (map compile-def def*)] 30 | [exp* (map compile-e exp*)]) 31 | (values def* exp*))) 32 | (define (compile-e [e : Expr]) : Term 33 | (type-case Expr e 34 | [(e-con c) 35 | (term-of-c c)] 36 | [(e-var x) 37 | (t-var x)] 38 | [(e-fun arg* def* prelude* result) 39 | (compile-fun (none) arg* def* prelude* result)] 40 | [(e-app fun arg*) 41 | (t-app (compile-e fun) (map compile-e arg*))] 42 | [(e-let bind* def* prelude* result) 43 | (t-let (map compile-bind bind*) (block-of-def* def* prelude* result))] 44 | [(e-let* bind* def* prelude* result) 45 | (compile-let* (map compile-bind bind*) 46 | (block-of-def* def* prelude* result))] 47 | [(e-letrec bind* def* prelude* result) 48 | (t-letrec (map compile-bind bind*) 49 | (block-of-def* def* prelude* result))] 50 | [(e-set! var val) 51 | (t-set! var (compile-e val))] 52 | [(e-begin prelude* result) 53 | (compile-begin prelude* result)] 54 | [(e-if cnd thn els) 55 | (t-if (compile-e cnd) 56 | (compile-e thn) 57 | (compile-e els))] 58 | [(e-cond thn-cnd* els) 59 | (t-cond (map compile-e&e thn-cnd*) 60 | (type-case (Optionof '_) els 61 | [(none) (none)] 62 | [(some e) 63 | (some (compile-e e))]))])) 64 | (define (compile-e&e e&e) 65 | (pair (compile-e (fst e&e)) 66 | (compile-e (snd e&e)))) 67 | (define (compile-def def) : (Id * Term) 68 | (type-case Def def 69 | ((d-var x e) 70 | (values x (compile-e e))) 71 | ((d-fun fun arg* def* prelude* result) 72 | (values fun (compile-fun (some fun) arg* def* prelude* result))))) 73 | (define (compile-fun name arg* def* prelude* result) 74 | (t-fun name arg* 75 | (block 76 | (map compile-def def*) 77 | (map compile-e prelude*) 78 | (compile-e result)))) 79 | (define (compile-bind bind) 80 | (values (fst bind) 81 | (compile-e (snd bind)))) 82 | (define (block-of-def* def* prelude* result) 83 | (block 84 | (map compile-def def*) 85 | (map compile-e prelude*) 86 | (compile-e result))) 87 | (define (term-of-block b) 88 | (cond 89 | [(not (empty? (block-def* b))) 90 | (t-let (list) b)] 91 | [(not (empty? (block-exp* b))) 92 | (t-block (block-exp* b) (block-out b))] 93 | [else 94 | (block-out b)])) 95 | (define (compile-let* bind* [body : Block]) 96 | (term-of-block 97 | (ind-List bind* 98 | body 99 | (λ (IH bind) 100 | (block 101 | (list) 102 | (list) 103 | (t-let (list bind) IH)))))) 104 | (define (compile-begin prelude* result) 105 | (t-begin 106 | (map compile-e prelude*) 107 | (compile-e result))) 108 | 109 | (define (truthy? [v : Val]) 110 | (type-case Val v 111 | [(v-bool b) 112 | b] 113 | [else 114 | #t])) 115 | (define (term-of-c c) : Term 116 | (type-case Constant c 117 | ((c-void) 118 | (t-quote (v-void))) 119 | ((c-char it) 120 | (t-quote (v-char it))) 121 | ((c-str it) 122 | (t-quote (v-str it))) 123 | ((c-num it) 124 | (t-quote (v-num it))) 125 | ((c-bool it) 126 | (t-quote (v-bool it))) 127 | ((c-vec it) 128 | (t-app (t-quote (v-prim (po-mvec))) (map term-of-c it))) 129 | ((c-list it) 130 | (t-app (t-quote (v-prim (po-list))) (map term-of-c it))))) 131 | 132 | 133 | (define (simple? e) 134 | (type-case Term e 135 | ((t-var _) #t) 136 | ((t-quote _) #t) 137 | (else #f))) 138 | 139 | (define (as-fun the-heap (v : Val)) 140 | (type-case Val v 141 | ((v-prim name) (op-prim name)) 142 | ((v-addr addr) 143 | (type-case HeapValue (heap-ref the-heap addr) 144 | ((h-fun env name arg* body) 145 | (op-fun env arg* body)) 146 | (else 147 | (raise (exn-rt "expecting a function, given something else"))))) 148 | (else (raise (exn-rt "expecting a function, given something else"))))) 149 | 150 | (define-syntax-rule 151 | (let-args ([(v ...) arg*]) . body) 152 | (cond 153 | [(not (= (length '(v ...)) (length arg*))) 154 | (raise (exn-rt "arity mismatch"))] 155 | [else 156 | (let ([v (list-ref arg* (index-of '(v ...) 'v))] ...) 157 | . body)])) 158 | 159 | (define (eval tracing? enable-tco? [check : (((Listof (Id * Term)) * (Listof Term)) -> Void)] pict-of-state (e : Program)) 160 | : 161 | Void 162 | 163 | (local ((define (apply-stack the-heap v stack) 164 | : State 165 | (type-case (Listof Ctx) stack 166 | (empty 167 | (raise (exn-internal 'apply-stack "The empty stack should have been caught by P-exp"))) 168 | ((cons sf0 stack) 169 | (local ((define-values (env ectx ann) sf0)) 170 | (continue-returned the-heap v env ectx stack) 171 | #; 172 | (values the-heap (returned v env ectx stack)))))) 173 | (define (continue-returning the-heap v stack) 174 | (apply-stack the-heap v stack)) 175 | (define (continue-returned the-heap v env ectx stack) 176 | (do-apply-k the-heap v env ectx stack)) 177 | (define (do-apply-k the-heap v env ectx [stack : Stack]) 178 | : State 179 | (begin 180 | (type-case (Listof ECFrame) ectx 181 | [empty 182 | (values the-heap (returning v stack))] 183 | ((cons f ectx) 184 | (type-case ECFrame f 185 | ((F-seq is-block e* e) 186 | (interp-seq is-block the-heap e* e env ectx stack)) 187 | ((F-app v* e*) 188 | (let ([v* (append v* (list v))]) 189 | (interp-app the-heap v* e* env ectx stack))) 190 | ((F-let xv* x xe* body) 191 | (interp-let the-heap (append xv* (list (pair x v))) xe* body env ectx stack)) 192 | ((F-if thn els) 193 | (if (truthy? v) 194 | (let ((e thn)) 195 | (do-interp the-heap e env ectx stack)) 196 | (let ((e els)) 197 | (do-interp the-heap e env ectx stack)))) 198 | ((F-set! var) 199 | (values the-heap (setting var v env ectx stack)) 200 | #; 201 | (let ((the-heap (env-set the-heap env var v))) 202 | (do-apply-k the-heap (v-void) env ectx stack))) 203 | ((P-def x d* e*) 204 | (begin 205 | (unless (and (empty? ectx) (empty? stack)) 206 | (raise (exn-internal 'apply-k "The ectx and the stack must be empty."))) 207 | (let ([the-heap (env-set the-heap env x v)]) 208 | (do-interp-program-def* the-heap d* e* env)))) 209 | ((P-exp v* e*) 210 | (begin 211 | (unless (and (empty? ectx) (empty? stack)) 212 | (raise (exn-internal 'apply-k "The ectx and the stack must be empty."))) 213 | (let ([o ((obs-of-val the-heap) v)]) 214 | (begin 215 | (output! o) 216 | (do-interp-program-exp* the-heap (append v* (list v)) e* env)))))))))) 217 | (define (do-interp-program the-heap [p : CompiledProgram]) : State 218 | (local ((define-values (bind* exp*) p)) 219 | (let ((var* (map var-of-bind bind*))) 220 | (let-values (((the-heap env) (env-declare the-heap base-env var*))) 221 | (do-interp-program-def* the-heap bind* exp* env))))) 222 | (define (do-interp-program-def* the-heap [bind* : (Listof (Id * Term))] [exp* : (Listof Term)] [env : Env]) 223 | : State 224 | (type-case (Listof (Id * Term)) bind* 225 | [empty (do-interp-program-exp* the-heap (list) exp* env)] 226 | [(cons bind bind*) 227 | (let* ([x (fst bind)] 228 | [e (snd bind)]) 229 | (do-interp the-heap e env (list (P-def x bind* exp*)) empty))])) 230 | (define (do-interp-program-exp* the-heap [v* : (Listof Val)] [e* : (Listof Term)] [env : Env]): State 231 | (type-case (Listof Term) e* 232 | [empty 233 | (values the-heap (terminated v*))] 234 | [(cons e e*) 235 | (do-interp the-heap e env (list (P-exp v* e*)) empty)])) 236 | (define (do-ref the-heap x env ectx stack) 237 | (type-case (Optionof Val) (env-lookup the-heap env x) 238 | [(some v) (do-apply-k the-heap v env ectx stack)] 239 | [else (raise (exn-rt (format "unbound id ~a" x)))])) 240 | (define (do-interp the-heap [e : Term] [env : Env] ectx stack) 241 | : State 242 | (begin 243 | (type-case 244 | Term 245 | e 246 | ((t-quote v) (do-apply-k the-heap v env ectx stack)) 247 | ((t-var x) 248 | (do-ref the-heap x env ectx stack)) 249 | ((t-fun name arg* body) 250 | (let-values (((the-heap v) (v-fun the-heap env name arg* body))) 251 | (do-apply-k the-heap v env ectx stack))) 252 | ((t-app fun arg*) (interp-app the-heap (list) (cons fun arg*) env ectx stack)) 253 | ((t-let bind* body) (interp-let the-heap (list) bind* body env ectx stack)) 254 | ((t-letrec bind* body) 255 | (let ([stack (cons (values env ectx (ca-letrec)) stack)]) 256 | (let ((ectx (list))) 257 | (let ((var* (map var-of-bind bind*))) 258 | (let-values (((the-heap env) (env-declare the-heap env var*))) 259 | (let ([e (t-block 260 | (map (lambda (xe) (t-set! (fst xe) (snd xe))) bind*) 261 | (term-of-block body))]) 262 | (do-interp the-heap e env ectx stack))))))) 263 | ((t-set! var val) 264 | (let ((e val)) 265 | (let ((ectx (cons (F-set! var) ectx))) 266 | (do-interp the-heap e env ectx stack)))) 267 | ((t-seq is-block prelude* result) 268 | (interp-seq is-block the-heap prelude* result env ectx stack)) 269 | ((t-if cnd thn els) 270 | (let ((e cnd)) 271 | (let ((ectx (cons (F-if thn els) ectx))) 272 | (do-interp the-heap e env ectx stack)))) 273 | ((t-cond cnd-thn* els) 274 | (type-case (Listof '_) cnd-thn* 275 | [empty 276 | (type-case (Optionof Term) els 277 | [(none) 278 | (do-apply-k the-heap (v-void) env ectx stack)] 279 | [(some e) 280 | (do-interp the-heap e env ectx stack)])] 281 | [(cons cnd-thn cnd-thn*) 282 | (let ([e (t-if (fst cnd-thn) 283 | (snd cnd-thn) 284 | (t-cond cnd-thn* els))]) 285 | (do-interp the-heap e env ectx stack))]))))) 286 | (define (interp-app the-heap v* e* env ectx stack) : State 287 | (type-case 288 | (Listof Term) 289 | e* 290 | (empty 291 | (type-case 292 | (Listof Val) 293 | v* 294 | (empty (raise (exn-internal 'interpter ""))) 295 | ((cons fun arg*) (interp-beta the-heap fun arg* env ectx stack)))) 296 | ((cons e e*) 297 | (let ((ectx (cons (F-app v* e*) ectx))) 298 | (do-interp the-heap e env ectx stack))))) 299 | (define (interp-seq is-block the-heap prelude* result env ectx stack) : State 300 | (type-case 301 | (Listof Term) 302 | prelude* 303 | (empty 304 | (let ([e result]) 305 | (do-interp the-heap e env ectx stack))) 306 | ((cons e prelude*) 307 | (let ((ectx (cons (F-seq is-block prelude* result) ectx))) 308 | (do-interp the-heap e env ectx stack))))) 309 | (define (interp-let the-heap xv* xe* [body : Block] env ectx stack) : State 310 | (type-case 311 | (Listof (Id * Term)) 312 | xe* 313 | (empty 314 | (enter-block the-heap env ectx (ca-let) stack env (map snd xv*) (map fst xv*) body)) 315 | ((cons ⟨x×e⟩ xe*) 316 | (let ((x (fst ⟨x×e⟩))) 317 | (let ((e (snd ⟨x×e⟩))) 318 | (let ((ectx (cons (F-let xv* x xe* body) ectx))) 319 | (do-interp the-heap e env ectx stack))))))) 320 | (define (output! o) 321 | (unless (o-void? o) 322 | (displayln (string-of-o o)))) 323 | (define (interp-beta the-heap (fun : Val) (arg-v* : (Listof Val)) env ectx stack) 324 | : State 325 | (begin 326 | (type-case 327 | Operator 328 | (as-fun the-heap fun) 329 | ((op-prim op) 330 | (delta the-heap op arg-v* env ectx stack)) 331 | ((op-fun clos-env arg-x* body) 332 | (values the-heap (calling fun arg-v* env ectx stack clos-env arg-x* body)))))) 333 | (define (continute-setting the-heap x v env ectx stack) 334 | (let ((the-heap (env-set the-heap env x v))) 335 | (continute-setted the-heap env ectx stack))) 336 | (define (do-call the-heap fun arg-v* env ectx stack clos-env arg-x* body) : State 337 | (enter-block the-heap env ectx (ca-app fun arg-v*) stack clos-env arg-v* arg-x* body)) 338 | (define (enter-block the-heap env ectx ctx-ann stack base-env v* x* body) : State 339 | ;; tail-call optimization 340 | (let ([stack (if (and (empty? ectx) enable-tco?) 341 | stack 342 | (cons (values env ectx ctx-ann) stack))]) 343 | (enter-block-2 the-heap stack base-env v* x* body))) 344 | (define (enter-block-2 the-heap stack base-env v* x* body) : State 345 | (let ([def* (block-def* body)]) 346 | (cond 347 | [(not (= (length x*) 348 | (length v*))) 349 | (raise (exn-rt "arity mismatch"))] 350 | [else 351 | (let-values (((the-heap env) 352 | (env-extend/declare the-heap base-env 353 | (append (map2 pair x* (map some v*)) 354 | (map (lambda (def) 355 | (let ([name (fst def)]) 356 | (values name (none)))) 357 | def*))))) 358 | (let ((e (t-init! body))) 359 | (values the-heap (called e env stack))))]))) 360 | (define (t-init! body) 361 | (t-block 362 | (append 363 | (map (lambda (xe) (t-set! (fst xe) (snd xe))) 364 | (block-def* body)) 365 | (block-exp* body)) 366 | (block-out body))) 367 | (define (do-equal? the-heap v1 v2) 368 | (let ([visited (list)]) 369 | (local ((define (do-equal?-helper v1 v2) 370 | (or (equal? v1 v2) 371 | (member (values v1 v2) visited) 372 | (begin 373 | (set! visited (cons (values v1 v2) visited)) 374 | (type-case Val v1 375 | [(v-addr v1) 376 | (type-case Val v2 377 | [(v-addr v2) 378 | (let ([v1 (heap-ref the-heap v1)] 379 | [v2 (heap-ref the-heap v2)]) 380 | (cond 381 | [(and (h-vec? v1) (h-vec? v2)) 382 | (andmap 383 | do-equal?-helper 384 | (vector->list (h-vec-it v1)) 385 | (vector->list (h-vec-it v2)))] 386 | [(and (h-cons? v1) (h-cons? v2)) 387 | (and (do-equal?-helper (fst (h-cons-it v1)) 388 | (fst (h-cons-it v2))) 389 | (do-equal?-helper (snd (h-cons-it v1)) 390 | (snd (h-cons-it v2))))] 391 | [else #f]))] 392 | [else #f])] 393 | [else #f]))))) 394 | (do-equal?-helper v1 v2)))) 395 | (define (delta the-heap op v-arg* env ectx stack) : State 396 | (letrec ([return-value 397 | (lambda (the-heap v) 398 | (do-apply-k the-heap v env ectx stack))] 399 | [return-allocation 400 | (lambda (heap&v) 401 | (local ([define-values (the-heap v) heap&v]) 402 | (return-value the-heap v)))]) 403 | (type-case 404 | PrimitiveOp 405 | op 406 | ((po-not) 407 | (let-args (((v) v-arg*)) 408 | (let ((v (as-bool v))) 409 | (return-value the-heap (v-bool (not v)))))) 410 | ((po-left) 411 | (let-args (((v) v-arg*)) 412 | (let ((v (as-vec the-heap v))) 413 | (let ((_ (unless (= (vector-length v) 2) (raise (exn-rt "left: expecting a pair, given something else"))))) 414 | (return-value the-heap (vector-ref v 0)))))) 415 | ((po-right) 416 | (let-args (((v) v-arg*)) 417 | (let ((v (as-vec the-heap v))) 418 | (let ((_ (unless (= (vector-length v) 2) (raise (exn-rt "right: expecting a pair, given something else"))))) 419 | (return-value the-heap (vector-ref v 1)))))) 420 | ((po-vec-len) 421 | (let-args (((v) v-arg*)) 422 | (let ((v (as-vec the-heap v))) 423 | (return-value the-heap (v-num (vector-length v)))))) 424 | ((po-string-length) 425 | (let-args (((v) v-arg*)) 426 | (let ((v (as-str v))) 427 | (return-value the-heap (v-num (string-length v)))))) 428 | ((po-string-append) 429 | (let ((v* (map as-str v-arg*))) 430 | (return-value the-heap (v-str (foldr string-append "" v*))))) 431 | ((po-string->list) 432 | (let-args (((v) v-arg*)) 433 | (let ((v (as-str v))) 434 | (return-allocation (v-list the-heap (map v-char (string->list v))))))) 435 | ((po-list->string) 436 | (let-args (((v) v-arg*)) 437 | (let ((v (as-plait-list the-heap v))) 438 | (let ((v (map as-char v))) 439 | (return-value the-heap (v-str (list->string v))))))) 440 | ((po-zerop) 441 | (let-args (((v1) v-arg*)) 442 | (return-value the-heap (v-bool (equal? v1 (v-num 0)))))) 443 | ((po-emptyp) 444 | (let-args (((v1) v-arg*)) 445 | (return-value the-heap (v-bool (equal? v1 (v-empty)))))) 446 | ((po-eqp) 447 | (let-args (((v1 v2) v-arg*)) 448 | (return-value the-heap (v-bool (equal? v1 v2))))) 449 | ((po-equalp) 450 | (let-args (((v1 v2) v-arg*)) 451 | (return-value the-heap (v-bool (do-equal? the-heap v1 v2))))) 452 | ((po-+) 453 | (cond 454 | [(= 0 (length v-arg*)) 455 | (raise (exn-rt "arity mismatch"))] 456 | [else 457 | (let ([v-arg* (map as-num v-arg*)]) 458 | (return-value the-heap 459 | (v-num (foldl (lambda (x y) (+ y x)) 460 | (first v-arg*) 461 | (rest v-arg*)))))])) 462 | ((po--) 463 | (cond 464 | [(= 0 (length v-arg*)) 465 | (raise (exn-rt "arity mismatch"))] 466 | [else 467 | (let ([v-arg* (map as-num v-arg*)]) 468 | (return-value the-heap 469 | (v-num (foldl (lambda (x y) (- y x)) 470 | (first v-arg*) 471 | (rest v-arg*)))))])) 472 | ((po-*) 473 | (cond 474 | [(= 0 (length v-arg*)) 475 | (raise (exn-rt "arity mismatch"))] 476 | [else 477 | (let ([v-arg* (map as-num v-arg*)]) 478 | (return-value the-heap 479 | (v-num (foldl (lambda (x y) (* y x)) 480 | (first v-arg*) 481 | (rest v-arg*)))))])) 482 | ((po-/) 483 | (cond 484 | [(= 0 (length v-arg*)) 485 | (raise (exn-rt "arity mismatch"))] 486 | [else 487 | (let ([v-arg* (map as-num v-arg*)]) 488 | (return-value the-heap 489 | (v-num (foldl (lambda (x y) 490 | (if (zero? x) 491 | (raise (exn-rt "division-by-zero")) 492 | (/ y x))) 493 | (first v-arg*) 494 | (rest v-arg*)))))])) 495 | ((po-<) 496 | (let-args (((v1 v2) v-arg*)) 497 | (let ((v1 (as-num v1))) 498 | (let ((v2 (as-num v2))) 499 | (return-value the-heap (v-bool (< v1 v2))))))) 500 | ((po->) 501 | (let-args (((v1 v2) v-arg*)) 502 | (let ((v1 (as-num v1))) 503 | (let ((v2 (as-num v2))) 504 | (return-value the-heap (v-bool (> v1 v2))))))) 505 | ((po-<=) 506 | (let-args (((v1 v2) v-arg*)) 507 | (let ((v1 (as-num v1))) 508 | (let ((v2 (as-num v2))) 509 | (return-value the-heap (v-bool (<= v1 v2))))))) 510 | ((po->=) 511 | (let-args (((v1 v2) v-arg*)) 512 | (let ((v1 (as-num v1))) 513 | (let ((v2 (as-num v2))) 514 | (return-value the-heap (v-bool (>= v1 v2))))))) 515 | ((po-=) 516 | (let-args (((v1 v2) v-arg*)) 517 | (let ((v1 (as-num v1))) 518 | (let ((v2 (as-num v2))) 519 | (return-value the-heap (v-bool (= v1 v2))))))) 520 | ((po-pairp) 521 | (let-args (((v) v-arg*)) 522 | (catch 523 | (lambda () 524 | (let ([v (as-vec the-heap v)]) 525 | (return-value the-heap (v-bool (= (vector-length v) 2))))) 526 | (lambda (exn) 527 | (return-value the-heap (v-bool #f)))))) 528 | ((po-consp) 529 | (let-args (((v) v-arg*)) 530 | (catch 531 | (lambda () 532 | (let ([v (as-cons the-heap v)]) 533 | (return-value the-heap (v-bool #t)))) 534 | (lambda (exn) 535 | (return-value the-heap (v-bool #f)))))) 536 | ((po-mpair) 537 | (let-args (((v1 v2) v-arg*)) 538 | (return-allocation (v-vec the-heap (list->vector (list v1 v2)))))) 539 | ((po-set-left!) 540 | (let-args (((v e) v-arg*)) 541 | (vector-set the-heap v 0 542 | e 543 | (lambda (n) (= n 2)) 544 | env ectx stack))) 545 | ((po-set-right!) 546 | (let-args (((v e) v-arg*)) 547 | (vector-set the-heap v 1 548 | e 549 | (lambda (n) (= n 2)) 550 | env ectx stack))) 551 | ((po-vec-ref) 552 | (let-args (((v1 v2) v-arg*)) 553 | (let ((v1 (as-vec the-heap v1))) 554 | (let ((v2 (as-num v2))) 555 | (let ((_ (unless (< v2 (vector-length v1)) 556 | (raise (exn-rt "vec-ref: vector too short."))))) 557 | (return-value the-heap (vector-ref v1 v2))))))) 558 | ((po-cons) 559 | (let-args (((v1 v2) v-arg*)) 560 | (let ((v2 (as-list the-heap v2))) 561 | (return-allocation (v-cons the-heap (pair v1 v2)))))) 562 | ((po-first) 563 | (let-args (((v1) v-arg*)) 564 | (let ((v1 (as-cons the-heap v1))) 565 | (return-value the-heap (fst v1))))) 566 | ((po-rest) 567 | (let-args (((v1) v-arg*)) 568 | (let ((v1 (as-cons the-heap v1))) 569 | (return-value the-heap (snd v1))))) 570 | ((po-vec-set!) 571 | (let-args ([(v i e) v-arg*]) 572 | (let ([i (as-num i)]) 573 | (vector-set 574 | the-heap 575 | v 576 | i 577 | e 578 | (lambda (n) (< i n)) 579 | env ectx stack)))) 580 | ((po-mvec) 581 | (return-allocation (v-vec the-heap (list->vector v-arg*)))) 582 | ((po-list) 583 | (return-allocation (v-list the-heap v-arg*)))))) 584 | (define (as-num (v : Val)) 585 | : 586 | Number 587 | (type-case Val v ((v-num it) it) (else (raise (exn-rt "expecting a number, given something else"))))) 588 | (define (as-str (v : Val)) 589 | : 590 | String 591 | (type-case Val v ((v-str it) it) (else (raise (exn-rt "expecting a string, given something else"))))) 592 | (define (as-bool (v : Val)) 593 | : 594 | Boolean 595 | (type-case Val v ((v-bool it) it) (else (raise (exn-rt "expecting a boolean, given something else"))))) 596 | (define (as-char (v : Val)) 597 | : 598 | Char 599 | (type-case Val v ((v-char it) it) (else (raise (exn-rt "expecting a char, given something else"))))) 600 | (define (functional-vector-set vec i elm) 601 | (let ((lst (vector->list vec))) 602 | (let ((pre (take lst i)) 603 | (pos (drop lst (add1 i)))) 604 | (h-vec (list->vector (append pre (cons elm pos))))))) 605 | (define (continute-vector-setting the-heap addr it i velm env ectx stack) 606 | (let ([the-heap (heap-set the-heap addr (functional-vector-set it i velm))]) 607 | (do-apply-k the-heap (v-void) env ectx stack))) 608 | (define (vector-set [the-heap : Heap] [v : Val] i velm len-valid? env ectx stack) : State 609 | (type-case Val v 610 | ((v-addr addr) 611 | (type-case HeapValue (heap-ref the-heap addr) 612 | ((h-vec it) 613 | (begin 614 | (unless (len-valid? (vector-length it)) 615 | (raise (exn-rt "the length of the vector is not what I expected."))) 616 | (values the-heap (vector-setting addr it i velm env ectx stack)))) 617 | (else 618 | (raise (exn-rt (format "not a vector ~a" ((string-of-o-of-v the-heap) v))))))) 619 | (else (raise (exn-rt (format "not a vector ~a" ((string-of-o-of-v the-heap) v))))))) 620 | (define (as-vec the-heap (v : Val)) 621 | (type-case Val v 622 | ((v-addr addr) 623 | (type-case HeapValue (heap-ref the-heap addr) 624 | ((h-vec it) it) 625 | (else 626 | (raise (exn-rt (format "not a vector ~a" ((string-of-o-of-v the-heap) v))))))) 627 | (else (raise (exn-rt (format "not a vector ~a" ((string-of-o-of-v the-heap) v))))))) 628 | (define (as-list the-heap (v : Val)) 629 | (type-case Val v 630 | ((v-empty) v) 631 | ((v-addr addr) 632 | (type-case HeapValue (heap-ref the-heap addr) 633 | ((h-cons it) v) 634 | (else 635 | (raise (exn-rt (format "not a list ~a" ((string-of-o-of-v the-heap) v))))))) 636 | (else (raise (exn-rt (format "not a list ~a" ((string-of-o-of-v the-heap) v))))))) 637 | (define (as-plait-list the-heap (v : Val)) 638 | (type-case Val v 639 | ((v-empty) (list)) 640 | ((v-addr addr) 641 | (type-case HeapValue (heap-ref the-heap addr) 642 | ((h-cons it) 643 | (cons (fst it) (as-plait-list the-heap (snd it)))) 644 | (else 645 | (raise (exn-rt (format "not a list ~a" ((string-of-o-of-v the-heap) v))))))) 646 | (else (raise (exn-rt (format "not a list ~a" ((string-of-o-of-v the-heap) v))))))) 647 | (define (as-cons the-heap (v : Val)) 648 | (type-case Val v 649 | ((v-addr addr) 650 | (type-case HeapValue (heap-ref the-heap addr) 651 | ((h-cons it) it) 652 | (else 653 | (raise (exn-rt (format "not a cons ~a" ((string-of-o-of-v the-heap) v))))))) 654 | (else (raise (exn-rt (format "not a cons ~a" ((string-of-o-of-v the-heap) v))))))) 655 | (define (continute-setted the-heap env ectx stack) 656 | (do-apply-k the-heap (v-void) env ectx stack)) 657 | (define (forward [state : State]) 658 | (let-values (((the-heap state) state)) 659 | (catch 660 | (λ () 661 | (type-case OtherState state 662 | [(vector-setting addr it i v env ectx stack) 663 | (continute-vector-setting the-heap addr it i v env ectx stack)] 664 | [(setting x v env ectx stack) 665 | (continute-setting the-heap x v env ectx stack)] 666 | [(setted env ectx stack) 667 | (continute-setted the-heap env ectx stack)] 668 | [(calling fun arg-v* env ectx stack clos-env arg-x* body) 669 | (do-call the-heap fun arg-v* env ectx stack clos-env arg-x* body)] 670 | [(called e env stack) 671 | (do-interp the-heap e env (list) stack)] 672 | [(returning v stack) 673 | (continue-returning the-heap v stack)] 674 | [(returned v env ectx stack) 675 | (continue-returned the-heap v env ectx stack)] 676 | [else 677 | (raise (exn-internal 'forward "The program has terminated"))])) 678 | (λ (exn) 679 | (begin 680 | (handle-exn exn) 681 | (values the-heap (errored))))))) 682 | (define (final? [s : OtherState]) 683 | (or (terminated? s) 684 | (errored? s))) 685 | (define (trampoline [state : State]) 686 | (when (not (final? (snd state))) 687 | (trampoline (forward state)))) 688 | (define (handle-exn exn) 689 | (type-case 690 | Exception 691 | exn 692 | ((exn-tc msg) (output! (o-exn msg))) 693 | ((exn-rt msg) (output! (o-exn msg))) 694 | ((exn-internal where what) (error where what))))) 695 | (let ([initial-state 696 | (catch 697 | (λ () 698 | (let* ((e (compile e)) 699 | (_ (check e))) 700 | (some (do-interp-program base-heap e)))) 701 | (λ (exn) 702 | (begin 703 | (handle-exn exn) 704 | (none))))]) 705 | (type-case (Optionof State) initial-state 706 | [(none) (void)] 707 | [(some state) 708 | (if tracing? 709 | (pict-loop state (lambda (state) (final? (snd state))) forward pict-of-state) 710 | (catch 711 | (λ () 712 | (trampoline state)) 713 | (λ (exn) 714 | (begin 715 | (handle-exn exn) 716 | (void)))))])))) --------------------------------------------------------------------------------