├── .gitignore ├── .travis.yml ├── LICENSE.txt ├── README.md ├── info.rkt ├── main.rkt ├── private ├── dispatch-table.rkt ├── if-windows.rkt ├── windows-readline.rkt ├── zo-compile.rkt ├── zo-find.rkt ├── zo-shell.rkt ├── zo-string.rkt ├── zo-syntax.rkt └── zo-transition.rkt ├── scribblings ├── .gitignore ├── Makefile ├── api.scrbl ├── overview.scrbl ├── repl.scrbl ├── typed-api.scrbl └── zordoz.scrbl ├── test.rkt ├── typed.rkt ├── typed └── zo-structs.rkt └── zordoz.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | *\.swp 2 | *~ 3 | \#* 4 | compiled 5 | coverage 6 | 7 | zordoz 8 | zordoz.org 9 | pgmp.tar.gz 10 | 11 | play 12 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | langauge: c 2 | sudo: false 3 | env: 4 | global: 5 | - RACKET_DIR=~/racket 6 | matrix: 7 | - RACKET_VERSION=HEAD 8 | 9 | before_install: 10 | - git clone https://github.com/greghendershott/travis-racket.git ../travis-racket 11 | - cat ../travis-racket/install-racket.sh | bash 12 | - export PATH="${RACKET_DIR}/bin:${PATH}" 13 | 14 | install: raco pkg install --deps search-auto $TRAVIS_BUILD_DIR 15 | 16 | script: 17 | - raco test $TRAVIS_BUILD_DIR 18 | - raco setup --check-pkg-deps zordoz 19 | 20 | after_success: 21 | - raco pkg install --deps search-auto cover 22 | - raco pkg install --deps search-auto cover-coveralls 23 | - raco cover -b -f coveralls -d $TRAVIS_BUILD_DIR/coverage . 24 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | zordoz 2 | Copyright (c) 2015-2021 Ben Greenman 3 | 4 | This package is distributed under the GNU Lesser General Public 5 | License (LGPL). This means that you can link this package into proprietary 6 | applications, provided you follow the rules stated in the LGPL. You 7 | can also modify this package; if you distribute a modified version, 8 | you must distribute it under the terms of the LGPL, which in 9 | particular means that you must release the source code for the 10 | modified software. See http://www.gnu.org/copyleft/lesser.html 11 | for more information. 12 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Zordoz 2 | ====== 3 | [![Build Status](https://travis-ci.org/bennn/zordoz.svg)](https://travis-ci.org/bennn/zordoz) 4 | [![Coverage Status](https://coveralls.io/repos/bennn/zordoz/badge.svg?branch=master&service=github)](https://coveralls.io/github/bennn/zordoz?branch=master) 5 | [![Scribble](https://img.shields.io/badge/Docs-Scribble-blue.svg)](http://docs.racket-lang.org/zordoz/index.html) 6 | 7 | [ZORDOZ](https://www.youtube.com/watch?v=kbGVIdA3dx0) speaks to you! His chosen ones. 8 | 9 | 10 | This is an explorer for Racket .zo files. 11 | 12 | Tested to work on Racket `v6.5` 13 | For compatibility with older versions, see the 14 | [v6.1](https://github.com/bennn/zordoz/tree/v6.1) 15 | and 16 | [v6.2](https://github.com/bennn/zordoz/tree/v6.2) 17 | and 18 | [v6.3](https://github.com/bennn/zordoz/tree/v6.3) 19 | branches of this repo. 20 | (Note that installing through `raco` will choose the available version, if any, matching your Racket install.) 21 | 22 | Typed Racket users can `(require zordoz/typed)` for type-annotated bindings from `zordoz`. 23 | Also, `zordoz/typed/zo-structs` is a safe wrapper around Racket's [compiler/zo-structs](http://docs.racket-lang.org/raco/decompile.html#%28mod-path._compiler%2Fzo-structs%29) library. 24 | 25 | 26 | Install 27 | ------- 28 | 29 | You have two options. 30 | 31 | 1. Install from `raco` by running `raco pkg install zordoz` 32 | 2. Build from source by cloning this repo and using `raco`: 33 | `git clone https://github.com/bennn/zordoz; raco pkg install zordoz/` 34 | 35 | To run tests, do `raco test zordoz`. 36 | Tests are located in the `test` submodule of each source file. 37 | 38 | 39 | Usage 40 | ----- 41 | 42 | Zordoz provides a `raco zordoz` command. 43 | 44 | ### REPL 45 | 46 | Activate the REPL by giving a path to a compiled file. 47 | 48 | ``` 49 | raco zordoz FILE.zo 50 | ``` 51 | 52 | Passing the `-t` option uses typed racket code. 53 | Beware, the typed racket version is up to 5x slower than untyped because of contracts with the `compiler/zo-lib` structs. 54 | 55 | The REPL accepts the following commands: 56 | 57 | - `alst` prints all command aliases; for example, the repl treats the words 'alst' and 'aliases' the same way 58 | - `back` goes back to the previous context 59 | - `dive ARG` changes context to a new zo struct or list (other dives are not permitted) 60 | - `find ARG` searches for matches to `ARG` and, if successful, changes context to the list of results 61 | - `help` prints information about these commands 62 | - `info` prints data about the current context 63 | - `jump` reverts to a previously saved context 64 | - `save` marks the current context as a target for `jump` 65 | - `quit` exits the interpreter 66 | 67 | The functions implementing the `dive`, `find`, and `info` commands are available outside the REPL. 68 | Check the [guide](http://bennn.github.io/zordoz) for a summary. 69 | 70 | ### Quick Search 71 | 72 | Running: 73 | 74 | ``` 75 | ./zordoz -f branch -f lam -f closure FILE.zo 76 | ``` 77 | 78 | Will count and print the number of times the zo structs [branch](http://docs.racket-lang.org/raco/decompile.html#%28def._%28%28lib._compiler%2Fzo-structs..rkt%29._branch%29%29) [lam](http://docs.racket-lang.org/raco/decompile.html#%28def._%28%28lib._compiler%2Fzo-structs..rkt%29._lam%29%29) and [closure](http://docs.racket-lang.org/raco/decompile.html#%28def._%28%28lib._compiler%2Fzo-structs..rkt%29._closure%29%29) appear. 79 | This may take a while, depending on the size of the bytecode file. 80 | You can limit the search depth by passing a natural number with the `-l` flag. 81 | 82 | See the [decompilation guide](http://docs.racket-lang.org/raco/decompile.html#%28mod-path._compiler%2Fzo-structs%29) for a list of all zo struct names. 83 | 84 | 85 | Background 86 | ---------- 87 | 88 | Racket bytecode is stored in files with a `.zo` [extension](http://docs.racket-lang.org/raco/make.html). 89 | This tool makes it easier to explore the bytecode representation of a file, whether or not you have access to the file's source code. 90 | 91 | Given a `.zo` file, we decompile the bytecode into a struct (aka, a "zo-struct") using Racket's built-in [decompilation API](http://docs.racket-lang.org/raco/decompile.html). 92 | The REPL loads this struct as its initial _context_ and begins accepting commands, making it easy to visualize and explore Racket bytecode. 93 | 94 | Example 95 | ------- 96 | 97 | Suppose we create and compile a small racket file: 98 | ``` 99 | > echo -e "#lang racket/base\n(if #t (+ 1 1) 0)" > test.rkt 100 | > raco make test.rkt 101 | ``` 102 | 103 | The actual bytecode is not human readable. 104 | Neither is the struct representation output by `zo-parse`: 105 | ``` 106 | > echo -e '#lang racket/base\n(require compiler/zo-parse)\n(call-with-input-file "compiled/test_rkt.zo"\n (lambda (fd) (displayln (zo-parse fd))))' > print-test.rkt 107 | > racket print-test.rkt 108 | #s((compilation-top zo 0) 0 #s((prefix zo 0) 0 (#f) ()) #s((mod form 0 zo 0) test test # #s((prefix zo 0) 0 (#s((module-variable zo 0) # print-values 0 0 #s((function-shape zo 0) #(struct:arity-at-least 0) #f))) ()) ((0 () ()) (1 () ()) (#f () ())) ((0 #) (1) (-1) (#f)) (#s((apply-values expr 0 form 0 zo 0) #s((toplevel expr 0 form 0 zo 0) 0 0 #t #t) 2)) () ((0 () ())) 0 #s((toplevel expr 0 form 0 zo 0) 0 0 #f #f) #f #t () (#s((mod form 0 zo 0) (test configure-runtime) configure-runtime # #s((prefix zo 0) 0 (#s((module-variable zo 0) # configure 0 0 #s((function-shape zo 0) 1 #f))) ()) ((0 () ()) (1 () ()) (#f () ())) ((0 # #) (1) (-1) (#f)) (#s((application expr 0 form 0 zo 0) #s((primval expr 0 form 0 zo 0) 1000) (#t))) () ((0 () ())) 1 #s((toplevel expr 0 form 0 zo 0) 0 0 #f #f) #f #t () () ())) ())) 109 | ``` 110 | 111 | ZORDOZ offers a more readable presentation. 112 | Below is a sample interactive session with the same small file (interspersed with commentary): 113 | 114 | ``` 115 | > racket zordoz.rkt compiled/test_rkt.zo 116 | INFO: Loading bytecode file 'compiled/test_rkt.zo'... 117 | INFO: Parsing bytecode... 118 | INFO: Parsing complete! 119 | --- Welcome to the .zo shell, version 0.1 'outlands' --- 120 | zo> info 121 | 122 | max-let-depth : 0 123 | prefix : 124 | code : 125 | ``` 126 | 127 | The `compilation-top` struct is at the top of most every `.zo` file. 128 | Things get more interesting as we explore the structs nested inside it. 129 | 130 | ``` 131 | zo> dive code 132 | zo> info 133 | 134 | name : test 135 | srcname : test 136 | self-modidx : # 137 | prefix : 138 | provides : 0 [] [] 1 [] [] #f [] [] 139 | requires : 0 # 1 -1 #f 140 | body : 141 | syntax-bodies : 142 | unexported : 0 143 | max-let-depth : 0 144 | dummy : 145 | lang-info : #f 146 | internal-context : #t 147 | flags : 148 | pre-submodules : [1] 149 | post-submodules : [] 150 | ``` 151 | 152 | The `mod` struct represents a Racket module. 153 | This module has the name `test`; inferred from our filename `test.rkt`. 154 | 155 | We could continue `dive`-ing into structs, or we can use the shell's `find` command to look for structs matching a name like `mod` or `compilation-top`. 156 | Let's search for `branch` structs. 157 | Maybe we can find the `if`-statement in our original code. 158 | 159 | ``` 160 | zo> find branch 161 | FIND returned 0 results 162 | ``` 163 | 164 | Nothing. 165 | The `if`-statement has been optimized away. 166 | Let's try to find what it turned into by searching the body of the module. 167 | 168 | ``` 169 | zo> dive body 170 | zo> info 171 | ()[1] 172 | ``` 173 | 174 | The syntax `()[LENGTH]` denotes a list of zo-structs. 175 | `LENGTH` is the number of elements in the list--we can `dive` into any valid index. 176 | 177 | ``` 178 | zo> dive 0 179 | zo> info 180 | 181 | proc : 182 | args-expr : 2 183 | ``` 184 | 185 | Looks like our `if`-statement was optimized into a constant, `2`. 186 | 187 | Happy exploring! 188 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | (define collection "zordoz") 3 | (define deps '("base" ;; Expects 6.2.900.15 or greater 4 | "compiler-lib" 5 | "zo-lib" 6 | "typed-racket-lib" 7 | "typed-racket-more" 8 | "readline-lib" 9 | "dynext-lib")) 10 | (define build-deps '("rackunit-lib" 11 | "scribble-lib" 12 | "racket-doc")) 13 | (define pkg-desc "REPL for exploring .zo bytecode files") 14 | (define version "0.8") 15 | (define pkg-authors '(ben)) 16 | (define raco-commands '(("zordoz" (submod zordoz/zordoz main) "open a REPL for a bytecode file (aka 'zo Explorer')" #f))) 17 | (define scribblings '(("scribblings/zordoz.scrbl" () (tool-library)))) 18 | -------------------------------------------------------------------------------- /main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require racket/contract 4 | compiler/zo-structs 5 | zordoz/private/zo-string 6 | zordoz/private/zo-transition 7 | zordoz/private/zo-find 8 | zordoz/private/zo-shell 9 | zordoz/private/zo-syntax 10 | zordoz/private/zo-compile) 11 | 12 | (provide result result? result-zo result-path from-c 13 | (contract-out 14 | [zo->string (->* (zo?) (#:deep? boolean?) string?)] 15 | ;; Render a zo struct as a string. 16 | ;; Optional argument #:deep? determines whether to render the struct's 17 | ;; fields, or just its name. 18 | 19 | [zo->spec (->i ([z zo?]) () [res (z) (and/c spec/c (specof z))])] 20 | ;; Convert a zo struct to a string specification. 21 | ;; Specifications are structured strings -- they are lists with 22 | ;; the same number of fields as the struct they represent. 23 | 24 | [zo-transition (-> zo? string? (values (or/c zo? (listof zo?)) boolean?))] 25 | ;; (zo-transition z s) retrieves the field named `s` from the 26 | ;; zo struct `z`, provided: 27 | ;; - this field `s` exists 28 | ;; - the type of `s` is a zo struct (and not an integer, list, ...) 29 | 30 | [zo-find (->* [zo? string?] [#:limit (or/c natural-number/c #f)] (listof result?))] 31 | ;; Recursively search a zo struct for sub-structures 32 | ;; with names exactly matching the argument string. 33 | ;; Matching structs are return along with the path taken to reach them 34 | 35 | [filename->shell (-> path-string? void?)] 36 | ;; Start a REPL session to explore a .zo bytecode file 37 | 38 | [zo->shell (-> zo? void?)] 39 | ;; Start a REPL session to explore a zo struct 40 | 41 | [syntax->shell (-> syntax? void?)] 42 | ;; Start a REPL session to explore a syntax object 43 | 44 | [compiled-expression->zo (-> compiled-expression? zo?)] 45 | ;; Convert a compiled expression into a zo struct 46 | 47 | [syntax->zo (-> syntax? zo?)] 48 | ;; Compile a syntax object to a zo struct 49 | 50 | [syntax->decompile (-> syntax? any/c)] 51 | ;; Compile a syntax object, then decompile the result to an S-expression 52 | 53 | [toplevel-syntax->zo (-> syntax? (listof zo?))] 54 | ;; Compile a top level syntax object into a list of zo structs 55 | 56 | [zo->compiled-expression (-> zo? compiled-expression?)] 57 | ;; Compile a zo struct 58 | 59 | [compile-c-module (-> (or/c path-string? path?) void?)] 60 | ;; Compile a C module so it can be required in racket 61 | )) 62 | -------------------------------------------------------------------------------- /private/dispatch-table.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Macro abstracting dispatch tables for zo structs. 4 | ;; 5 | ;; Given an action and a list of struct names, create a `cond` table to: 6 | ;; - check predicates (built from each name) 7 | ;; - apply actions (derived by combining the action and the names) 8 | 9 | (provide 10 | make-table 11 | ;; Create a dispatch table from an action and list of names 12 | ) 13 | 14 | ;; -------------------------------------------------------------------------------- 15 | 16 | (require 17 | (for-syntax racket/base syntax/parse racket/syntax)) 18 | 19 | ;; ============================================================================= 20 | 21 | ;; Create a dispatch table from an action and 22 | (define-syntax (make-table stx) 23 | (syntax-parse stx 24 | [(_ (~seq #:action act) ids:id ...) 25 | #:with (ids? ...) #`(#,@(for/list ([i (syntax->list #'(ids ...))]) 26 | (format-id stx "~a?" i))) 27 | #:with (ids* ...) #`(#,@(for/list ([i (syntax->list #'(ids ...))]) 28 | (format-id stx "~a~a" i #'act))) 29 | #'(λ (z . a) 30 | (cond 31 | [(ids? z) (apply ids* (cons z a))] 32 | ... 33 | [else #f]))])) 34 | -------------------------------------------------------------------------------- /private/if-windows.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Conditional "if windows" compile-time check 4 | 5 | (provide if-windows) 6 | 7 | (require (for-syntax racket/base syntax/parse)) 8 | 9 | ;; ============================================================================= 10 | 11 | (define-syntax (if-windows stx) 12 | (syntax-parse stx 13 | [(_ yes no) 14 | (case (system-type 'os) 15 | [(windows) (syntax/loc stx yes)] 16 | [(unix macosx) (syntax/loc stx no)])] 17 | [_ (error 'if-windows 18 | (format "Expected (if-windows YES NO), got '~a'" (syntax->datum stx)))])) 19 | 20 | -------------------------------------------------------------------------------- /private/windows-readline.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Readline bindings, without the readline 4 | 5 | (provide 6 | readline-prompt 7 | (rename-out [winread read-line])) 8 | 9 | ;; ============================================================================= 10 | 11 | (define readline-prompt (make-parameter #"> ")) 12 | 13 | (define (winread) 14 | (display (readline-prompt)) 15 | (read-line)) 16 | -------------------------------------------------------------------------------- /private/zo-compile.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide compile-c-module 4 | from-c) 5 | 6 | (require racket/file 7 | dynext/file 8 | dynext/compile 9 | dynext/link 10 | ffi/unsafe 11 | ffi/unsafe/atomic 12 | (only-in ffi/unsafe/global register-process-global) 13 | (for-syntax racket/base 14 | syntax/parse 15 | racket/require-transform 16 | racket/file 17 | dynext/file 18 | dynext/compile 19 | dynext/link 20 | ffi/unsafe 21 | ffi/unsafe/atomic 22 | (only-in ffi/unsafe/global register-process-global))) 23 | 24 | (define-syntax-rule (define-for-syntax-and-runtime f ...) 25 | (begin (define f ...) 26 | (define-for-syntax f ...))) 27 | 28 | ; Helpers for creating a tag for the global process table 29 | (define-for-syntax-and-runtime zordoz-prefix-string "ZORDOZ-INTERNAL-") 30 | (define-for-syntax-and-runtime (mk-process-global-key key) 31 | (format "~a~a" zordoz-prefix-string key)) 32 | 33 | (define-for-syntax-and-runtime done (cast 1 _scheme _pointer)) 34 | 35 | (define-for-syntax-and-runtime object-target-path 36 | (build-path "compiled" "native" (system-library-subpath))) 37 | 38 | ; Try to compile the library. If already linked, don't relink, 39 | ; if linked and c file has been modified, error. 40 | ; path? -> void? 41 | (define-for-syntax-and-runtime (try-load-library in) 42 | (define extensionless-source (path-replace-suffix in "")) 43 | (define out (build-path object-target-path (append-extension-suffix extensionless-source))) 44 | (with-handlers ([exn:fail? 45 | (raise-user-error 46 | 'zordoz 47 | "DrRacket cannot do background check-syntax on modules imported with from-c")]) 48 | (make-temporary-file)) ; Cludgy hack to see if in sandbox 49 | (call-as-atomic 50 | (lambda () 51 | (if (register-process-global (mk-process-global-key (path->string out)) done) 52 | (unless (and (file-exists? in) 53 | (file-exists? out) 54 | ((file-or-directory-modify-seconds in) 55 | . < . 56 | (file-or-directory-modify-seconds out))) 57 | (raise-user-error 'zordoz 58 | "Cannot reload C based module, please restart Racket (or DrRacket)")) 59 | (call-as-nonatomic 60 | (lambda () 61 | (with-handlers ([exn:fail? 62 | (error 'zordoz 63 | "Could not compile C file, please restart Racket (or DrRacket)")]) 64 | (compile-c-module in)))))))) 65 | 66 | ; Compile C implementation of module. Does not load into program 67 | ; path -> void? 68 | (define-for-syntax-and-runtime (compile-c-module c-source) 69 | (define extensionless-source (path-replace-suffix c-source "")) 70 | (define object-target 71 | (build-path object-target-path (append-object-suffix extensionless-source))) 72 | (define shared-object-target 73 | (build-path object-target-path (append-extension-suffix extensionless-source))) 74 | (make-directory* object-target-path) 75 | (compile-extension #t c-source object-target '()) 76 | (link-extension #t (list object-target) shared-object-target)) 77 | 78 | ; Compile C module, load into module. Fail if C file changed and module has 79 | ; already been loaded into the VM. 80 | (define-syntax from-c 81 | (make-require-transformer 82 | (lambda (stx) 83 | (syntax-parse stx 84 | [(_ c-source:str) 85 | (define f (syntax-e #'c-source)) 86 | (try-load-library f) 87 | (expand-import (datum->syntax stx (path->string (path-replace-suffix f ""))))])))) 88 | -------------------------------------------------------------------------------- /private/zo-find.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Simple utility for searching zo structs. 4 | ;; Explores the current struct's fields recursively for a exact string match. 5 | 6 | (provide 7 | zo-find 8 | ;; (->* [zo? string?] [#:limit (or/c natural-number/c #f)] (listof result?)) 9 | ;; Search a struct recursively for member zo-structs matching a string. 10 | 11 | result result? result-zo result-path 12 | ;; Search result: a zo-struct and the path to reach it 13 | ) 14 | 15 | ;; ----------------------------------------------------------------------------- 16 | 17 | (require 18 | (only-in racket/string string-split string-trim) 19 | (only-in compiler/zo-structs zo?) 20 | (only-in zordoz/private/zo-transition zo-transition) 21 | (only-in zordoz/private/zo-string zo->spec spec/c) 22 | (only-in racket/list append*) 23 | racket/match) 24 | 25 | ;; ============================================================================= 26 | 27 | ;; --- API functions 28 | 29 | (struct result (zo path) #:transparent) 30 | 31 | ;; Searches a zo-struct `z` recursively for member zo-structs matching the `s`. 32 | ;; Terminates after at most `#:limit` recursive calls. 33 | ;; Return a list of 'result' structs. 34 | (define (zo-find z str #:limit [lim #f]) 35 | ;; (-> zo? string? (listof result?)) 36 | (define-values (_ children) (parse-zo z)) 37 | (append* (for/list ([z* children]) (zo-find-aux z* '() str 1 lim)))) 38 | 39 | ;; --- private functions 40 | 41 | ;; Check if `str` is one of the known looping zo-structs. 42 | ;; 2015-01-23: So far as I know, only closures may loop. 43 | ;; 2015-07-29: New macro expander => scope and multi-scope can loop 44 | (define (may-loop? str) 45 | ;; (-> string? boolean?) 46 | (member str (list "closure" "scope" "multi-scope"))) 47 | 48 | ;; Recursive helper for `zo-find`. 49 | ;; Add the current struct to the results, if it matches. 50 | ;; Check struct members for matches unless the search has reached its limit. 51 | (define (zo-find-aux z hist str i lim) 52 | (define-values (title children) (parse-zo z)) 53 | (define results 54 | (cond 55 | [(and lim (<= lim i)) 56 | '()] 57 | ;; Terminate search if we're seeing a node for the second time 58 | [(and (may-loop? title) (memq z hist)) 59 | '()] 60 | [else 61 | ;; Remember current node if we might see it again. 62 | (define hist* (cons z hist)) 63 | (apply append (for/list ([z* children]) (zo-find-aux z* hist* str (add1 i) lim)))])) 64 | (if (and (string=? str title) (not (memq z (map result-zo results)))) 65 | (cons (result z hist) results) 66 | results)) 67 | 68 | ;; Return the name of the zo `z` and a list of its child zo structs. 69 | ;; Uses `zo-string.rkt` to parse a raw struct. 70 | (define (parse-zo z) 71 | ;; (-> zo? (values string? (listof zo?))) 72 | (define z-spec (zo->spec z)) 73 | (define title (car z-spec)) 74 | (define child-strs (for/list ([pair (cdr z-spec)]) (car pair))) 75 | (values title (get-children z child-strs))) 76 | 77 | ;; Given a zo `z` and list of possible field names `strs`, return the list 78 | ;; of zo-structs obtained by looking up each name in `strs` in the struct `z`. 79 | ;; Relies on `zo-transition.rkt` to do the lookup. 80 | (define (get-children z strs) 81 | ;; (-> zo? string? (listof zo?)) 82 | (match strs 83 | ['() '()] 84 | [(cons hd tl) 85 | (define-values (r success?) (zo-transition z hd)) 86 | (cond [(not success?) (get-children z tl)] 87 | [(list? r) (append (filter zo? r) (get-children z tl))] 88 | [(hash? r) (append (filter zo? (hash-values r)) (get-children z tl))] 89 | [(zo? r) (cons r (get-children z tl))])])) 90 | 91 | ;; ============================================================================= 92 | ;; --- testing 93 | 94 | (module+ test 95 | (require rackunit 96 | (only-in "zo-string.rkt" zo->string) 97 | compiler/zo-structs) 98 | 99 | ;; --- API 100 | (test-case "Success, one search path" 101 | (let* ([z (branch #t #t (branch #t #t (branch #t #t (branch #t #t #t))))] 102 | [arg "branch"] 103 | [res (zo-find z arg)]) 104 | (begin (check-equal? (length res) 3) 105 | (check-equal? (result-zo (car res)) (branch-else z)) 106 | (check-equal? (result-path (car res)) '())))) 107 | 108 | (test-case "Success, #:limit-ed results" 109 | (let* ([z (branch #t #t (branch #t #t (branch #t #t (branch #t #t #t))))] 110 | [arg "branch"] 111 | [res (zo-find z arg #:limit 2)]) 112 | (begin (check-equal? (length res) 2) 113 | (check-equal? (result-zo (cadr res)) (branch-else (branch-else z))) 114 | (check-equal? (result-path (cadr res)) (list (branch-else z)))))) 115 | 116 | (test-case "Fail, no results" 117 | (let* ([z (primval 8)] 118 | [arg "apply-values"] 119 | [res (zo-find z arg)]) 120 | (check-equal? res '()))) 121 | 122 | (test-case "Fail, search excludes root" 123 | (let* ([z (primval 8)] 124 | [arg "primval"] 125 | [res (zo-find z arg)]) 126 | (check-equal? res '()))) 127 | 128 | ;; --- private 129 | (test-case "-- find-aux" 130 | ;; Success, search INCLUDES root (empty history) 131 | (let* ([z (primval 8)] 132 | [arg "primval"] 133 | [res (zo-find-aux z '() arg 1 10)]) 134 | (begin (check-equal? (length res) 1) 135 | (check-equal? (result-zo (car res)) z) 136 | (check-equal? (result-path (car res)) '())))) 137 | 138 | (test-case "Success, search INCLUDES root (make sure history is passed in result)" 139 | (let* ([z (primval 8)] 140 | [arg "primval"] 141 | [hist '(a b c d)] 142 | [res (zo-find-aux z hist arg 1 10)]) 143 | (begin (check-equal? (result-zo (car res)) z) 144 | (check-equal? (result-path (car res)) hist)))) 145 | 146 | (test-case "Failure, search at limit (remember, find-aux searches the head)" 147 | (let* ([z (branch #t #t (primval 8))] 148 | [arg "primval"] 149 | [hist '()] 150 | [res (zo-find-aux z hist arg 9 9)]) 151 | (check-equal? res '()))) 152 | 153 | (test-case "Failure, search past limit" 154 | (let* ([z (branch #t #t (primval 8))] 155 | [arg "primval"] 156 | [hist '()] 157 | [res (zo-find-aux z hist arg 9 1)]) 158 | (check-equal? res '()))) 159 | 160 | (test-case "find nothing, malformed zo" 161 | (let* ([tgt (inline-variant (branch #f #f #f) (branch #f #f #f))] 162 | [z (with-cont-mark (let-one (boxenv 7 #f) (localref #t 1 #t #t #f) #f #t) 163 | (seq (list tgt)) 164 | #f)] 165 | [arg "inline-variant"] 166 | [hist '(a b)] 167 | [res (zo-find-aux z hist arg 1 10)]) 168 | (check-equal? (length res) 0))) 169 | 170 | (test-case "Success, searching a few branches" 171 | (let* ([tgt (branch #f #f #f)] 172 | [z (with-cont-mark (let-one (boxenv 7 #f) (localref #t 1 #t #t #f) #f #t) 173 | (seq (list tgt)) 174 | #f)] 175 | [arg "branch"] 176 | [hist '(a b)] 177 | [res (zo-find-aux z hist arg 1 10)]) 178 | (begin (check-equal? (length res) 1) 179 | (check-equal? (result-zo (car res)) tgt) 180 | (check-equal? (result-path (car res)) (cons (with-cont-mark-val z) (cons z hist)))))) 181 | 182 | (test-case "Success, find multiple results" 183 | (let* ([tgt (toplevel 1 2 #t #f)] 184 | [z (application (beg0 (list (beg0 (list tgt)))) 185 | (list (primval 3) (primval 4) tgt tgt))] 186 | [arg "toplevel"] 187 | [hist '(a b c)] 188 | [res (zo-find-aux z hist arg 1 10)]) 189 | (begin (check-equal? (length res) 3) 190 | (check-equal? (result-zo (car res)) tgt) 191 | (check-equal? (result-zo (cadr res)) tgt) 192 | (check-equal? (result-zo (caddr res)) tgt) 193 | ;; Verify one history 194 | (check-equal? (result-path (car res)) (cons (car (beg0-seq (application-rator z))) 195 | (cons (application-rator z) 196 | (cons z hist))))))) 197 | 198 | (test-case "Success, it's a closure but we have not seen it" 199 | (let* ([z (closure (lam 'N '() 0 '() #f '#() '() #f 0 #f) 'C)] 200 | [arg "lam"] 201 | [res (zo-find-aux z '() arg 1 10)]) 202 | (begin (check-equal? (length res) 1) 203 | (check-equal? (result-zo (car res)) (closure-code z))))) 204 | 205 | (test-case "-- parse-zo" 206 | ;; Simple zo, no interesting fields 207 | (let ([z (toplevel 1 2 #t #t)]) 208 | (let-values ([(title children) (parse-zo z)]) 209 | (begin (check-equal? title "toplevel") 210 | (check-equal? (length children) 0))))) 211 | 212 | (test-case "Three interesting fields" 213 | (let ([z (branch (branch #t #t #t) (branch #t #t #f) (branch #t #f #f))]) 214 | (let-values ([(title children) (parse-zo z)]) 215 | (begin (check-equal? title "branch") 216 | (check-equal? (length children) 3) 217 | (check-equal? (car children) (branch #t #t #t)))))) 218 | 219 | (test-case "2 of 3 fields are interesting" 220 | (let ([z (branch #f (branch #t #t #f) (branch #t #f #f))]) 221 | (let-values ([(title children) (parse-zo z)]) 222 | (begin (check-equal? title "branch") 223 | (check-equal? (length children) 2) 224 | (check-equal? (car children) (branch #t #t #f)))))) 225 | 226 | (test-case "Nested children are not returned" 227 | (let* ([tgt (beg0 (list (beg0 '())))] 228 | [z (apply-values tgt 229 | (assign (toplevel 1 1 #t #t) #f #f))]) 230 | (let-values ([(title children) (parse-zo z)]) 231 | (begin (check-equal? title "apply-values") 232 | (check-equal? (length children) 2) 233 | (check-equal? (car children) tgt))))) 234 | 235 | (test-case "-- get-children" 236 | ;; Two valid fields, only 1 result 237 | (let* ([tgt (toplevel 1 1 #t #f)] 238 | [z (def-values (list 'A 'B 'C tgt) #f)] 239 | [args (list "ids" "rhs")] 240 | [res (get-children z args)]) 241 | (begin (check-equal? (length res) 1) 242 | (check-equal? (car res) tgt))) 243 | (let* ([tgt (toplevel 1 1 #t #f)] 244 | [z (linkl-bundle (make-hash (list (cons 0 tgt) (cons 1 2))))] 245 | [args (list "table")] 246 | [res (get-children z args)]) 247 | (begin (check-equal? (length res) 1) 248 | (check-equal? (car res) tgt)))) 249 | 250 | (test-case "Two fields, 2 results" 251 | (let* ([tgt (lam 'name '() 0 '() #f '#() '() #f 0 #f)] 252 | [z (inline-variant tgt (let-rec '() #f))] 253 | [args (list "inline" "direct")] 254 | [res (get-children z args)]) 255 | (begin (check-equal? (length res) 2) 256 | (check-pred (lambda (x) (memq tgt res)) '())))) 257 | 258 | (test-case "Only search 1 of 2 possible fields" 259 | (let* ([tgt (lam 'name '() 0 '() #f '#() '() #f 0 #f)] 260 | [z (inline-variant tgt (let-rec '() #f))] 261 | [args (list "direct")] 262 | [res (get-children z args)]) 263 | (begin (check-equal? (length res) 1) 264 | (check-equal? (car res) tgt)))) 265 | 266 | (test-case "Failure, search no valid fields" 267 | (let* ([tgt (lam 'name '() 0 '() #f '#() '() #f 0 #f)] 268 | [z (inline-variant tgt (let-rec '() #f))] 269 | [args '()] 270 | [res (get-children z args)]) 271 | (check-equal? (length res) 0))) 272 | 273 | (let* ([tgt (lam 'name '() 0 '() #f '#() '() #f 0 #f)] 274 | [z (inline-variant tgt (let-rec '() #f))] 275 | [args (list "outline" "NOTHING")] 276 | [res (get-children z args)]) 277 | (check-equal? (length res) 0)) 278 | 279 | (test-case "Failure, no fields are zo" 280 | (let* ([z (let-void 777 #f 'NOTHING)] 281 | [args (list "count" "boxes?" "body" "something" "anything" "zo")] 282 | [res (get-children z args)]) 283 | (check-equal? (length res) 0))) 284 | ) 285 | -------------------------------------------------------------------------------- /private/zo-shell.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Command-line UI for exploring decompiled bytecode. 4 | ;; (Use `raco make` to generate bytecode) 5 | 6 | (provide 7 | filename->zo 8 | ;; (-> String zo) 9 | 10 | filename->shell 11 | ;; (-> String Void) 12 | ;; Start a repl using the zo file `filename` 13 | 14 | zo->shell 15 | ;; (-> zo Void) 16 | ;; Start a repl using the zo struct 17 | 18 | syntax->shell 19 | ;; (-> Syntax Void) 20 | ;; Start a repl from a syntax object 21 | 22 | find-all 23 | ;; (->* [String (Listof String)] [#:limit (U Natural #f)] Void) 24 | ;; (find-all zo arg* #:lim n) 25 | ;; Searches the bytecode file `zo` for all zo-structs named by the list `arg*` 26 | ;; and prints the number of matches. 27 | ;; If `#:limit` is not false, recursive searches are terminated at depth `n`. 28 | ;; 29 | ;; For example, if `arg*` is '("branch" "lam"), then the result will be the number 30 | ;; of zo structs in the decompiled output that match the `branch?` or `lam?` predicates. 31 | 32 | print-usage 33 | ;; (-> Void) 34 | ;; Display terms-of-use 35 | ) 36 | 37 | ;; ----------------------------------------------------------------------------- 38 | 39 | (require 40 | (only-in racket/port with-input-from-string) 41 | (only-in compiler/zo-parse zo? zo-parse) 42 | (only-in racket/string string-split string-join string-trim) 43 | (only-in zordoz/private/zo-find zo-find result result? result-zo result-path) 44 | (only-in zordoz/private/zo-string zo->string zo->spec) 45 | (only-in zordoz/private/zo-transition zo-transition) 46 | (only-in zordoz/private/zo-syntax syntax->zo) 47 | racket/match 48 | zordoz/private/if-windows 49 | ) 50 | 51 | (struct unsupplied-arg ()) 52 | (define the-unsupplied-arg (unsupplied-arg)) 53 | 54 | (if-windows 55 | (require zordoz/private/windows-readline) 56 | (require readline readline/pread)) 57 | 58 | ;; ============================================================================= 59 | 60 | ;; --- constants & contracts 61 | 62 | ;; when set, print extra debugging information 63 | (define DEBUG #f) 64 | ;; For aesthetic purposes 65 | (define VERSION 1.0) 66 | (define VNAME "vortex") 67 | 68 | ;; A welcome message for users entering the REPL 69 | (define WELCOME 70 | (let ([base-str (format "--- Welcome to the .zo shell, version ~a '~a' ---" VERSION VNAME)]) 71 | (if-windows 72 | base-str 73 | ;; Add colors 74 | (string-append "\033[1;34m" base-str "\033[0;0m")))) 75 | 76 | ;; (define nat? natural-number/c) 77 | ;; (define context? (or/c zo? (listof zo?) (listof result?))) 78 | ;; (define history? (listof context?)) 79 | 80 | ;; ----------------------------------------------------------------------------- 81 | ;; --- Commands (could go in their own file) 82 | 83 | (struct command (name ;; String 84 | num-args ;; Natural 85 | aliases ;; Listof String 86 | help-msg)) ;; String 87 | (define ALST (command "alst" 88 | 0 89 | (list "a" "alias" "aliases") 90 | "Print command aliases")) 91 | (define BACK (command "back" 92 | 0 93 | (list "b" "up" "u" ".." "../") 94 | "Move up to the previous context")) 95 | (define DIVE (command "dive" 96 | 1 97 | (list "d" "cd" "next" "step") 98 | "Step into struct field ARG")) 99 | (define FIND (command "find" 100 | 1 101 | (list "f" "query" "search" "look") 102 | "Search the current subtree for structs with the name ARG")) 103 | (define HELP (command "help" 104 | 0 105 | (list "h" "-h" "--h" "-help" "--help") 106 | "Print this message")) 107 | (define INFO (command "info" 108 | 0 109 | (list "i" "ls" "print" "p" "show") 110 | "Show information about current context")) 111 | (define JUMP (command "jump" 112 | 0 113 | (list "j" "warp" "top") 114 | "Revert to last saved position")) 115 | (define SAVE (command "save" 116 | 0 117 | (list "mark") 118 | "Save the current context as jump target")) 119 | (define QUIT (command "quit" 120 | 0 121 | (list "q" "exit" "leave" "bye") 122 | "Exit the interpreter")) 123 | (define COMMANDS 124 | (list ALST BACK DIVE FIND HELP INFO JUMP SAVE QUIT)) 125 | 126 | (define ((cmd? c) str) 127 | ;; (-> command? (-> string? boolean?)) 128 | (define splt (string-split str)) 129 | (and 130 | ;; Has the right number of arguments 131 | (= (sub1 (length splt)) 132 | (command-num-args c)) 133 | ;; First word matches command name (or an alias) 134 | (or (string=? (car splt) (command-name c)) 135 | (member (car splt) (command-aliases c))))) 136 | 137 | ;; ----------------------------------------------------------------------------- 138 | ;; --- REPL 139 | 140 | ;; Basic entry point to the REPL, expects command-line arguments passed as a list. 141 | (define (init args) 142 | ;; (-> (vectorof string?) void?) 143 | (match args 144 | ['#() 145 | (print-usage)] 146 | ;; Catch --help flag, and any others 147 | [(? has-any-flags?) (print-usage)] 148 | [(vector fname) 149 | (filename->shell fname)] 150 | [(vector fname args ...) 151 | (find-all fname args)])) 152 | 153 | (define (init-repl ctx) 154 | (displayln WELCOME) 155 | ((repl ctx '() `((,ctx))) '())) 156 | 157 | ;; Start REPL from a filename 158 | (define (filename->shell name) 159 | ;; (-> string? void?) 160 | (print-info (format "Loading bytecode file '~a'..." name)) 161 | (define ctx (filename->zo name)) 162 | (print-info "Parsing complete!") 163 | (init-repl ctx)) 164 | 165 | (define (filename->zo name) 166 | (call-with-input-file name zo-parse)) 167 | 168 | (define zo->shell init-repl) 169 | 170 | (define (syntax->shell stx) 171 | (zo->shell (syntax->zo stx))) 172 | 173 | ;; The REPL loop. Process a command using context `ctx` and history `hist`. 174 | (define ((repl ctx hist pre-hist) cmd*) 175 | ;; (-> context? history? void?) 176 | (when DEBUG (print-history hist)) 177 | (match cmd* 178 | ['() 179 | (match (parameterize ([readline-prompt (make-prompt ctx)]) 180 | (read-line)) 181 | [(? eof-object? _) 182 | (displayln "EOF: you have penetrated me")] 183 | [str 184 | ((repl ctx hist pre-hist) (split-cd (map string-trim (string-split str ";"))))])] 185 | [(cons (? (cmd? ALST) raw) cmd*) 186 | (print-alias) ((repl ctx hist pre-hist) cmd*)] 187 | [(cons (? (cmd? BACK) raw) cmd*) 188 | ((call-with-values (lambda () (back raw ctx hist pre-hist)) repl) cmd*)] 189 | [(cons (? (cmd? DIVE) raw) cmd*) 190 | ((call-with-values (lambda () (dive raw ctx hist pre-hist)) repl) cmd*)] 191 | [(cons (? (cmd? FIND) raw) cmd*) 192 | ((call-with-values (lambda () (find raw ctx hist pre-hist)) repl) cmd*)] 193 | [(cons (? (cmd? HELP) raw) cmd*) 194 | (begin (print-help) ((repl ctx hist pre-hist) cmd*))] 195 | [(cons (? (cmd? INFO) raw) cmd*) 196 | (begin (print-context ctx) ((repl ctx hist pre-hist) cmd*))] 197 | [(cons (? (cmd? JUMP) raw) cmd*) 198 | ((call-with-values (lambda () (jump raw ctx hist pre-hist)) repl) cmd*)] 199 | [(cons (? (cmd? SAVE) raw) cmd*) 200 | ((call-with-values (lambda () (save raw ctx hist pre-hist)) repl) cmd*)] 201 | [(cons (? (cmd? QUIT) raw) cmd*) 202 | (print-goodbye)] 203 | [(cons raw cmd*) 204 | (begin (print-unknown raw) ((repl ctx hist pre-hist) cmd*))])) 205 | 206 | ;; ----------------------------------------------------------------------------- 207 | ;; --- command implementations 208 | 209 | ;; 2015-01-23: Warn about possible-unexpected behavior 210 | (define BACK-WARNING 211 | (string-append 212 | "BACK removing most recent 'save' mark. " 213 | "Be sure to save if you want to continue exploring search result.")) 214 | 215 | ;; Step back to a previous context, if any, and reduce the history. 216 | ;; Try popping from `hist`, fall back to list-of-histories `pre-hist`. 217 | (define (back raw ctx hist pre-hist) 218 | (match (list hist pre-hist) 219 | [(list '() '()) 220 | ;; Nothing to pop from 221 | (print-unknown raw) 222 | (values ctx hist pre-hist)] 223 | [(list '() _) 224 | ;; Pop from pre-history 225 | (define-values (hist* pre-hist*) (pop pre-hist)) 226 | (define pre-hist** 227 | (if (null? pre-hist*) 228 | pre-hist 229 | (begin (displayln BACK-WARNING) pre-hist*))) 230 | (back raw ctx hist* pre-hist**)] 231 | [_ 232 | (define-values (ctx* hist*) (pop hist)) 233 | (values ctx* hist* pre-hist)])) 234 | 235 | ;; Search context `ctx` for a new context matching string `raw`. 236 | ;; Push `ctx` onto the stack `hist` on success. 237 | (define (dive raw ctx hist pre-hist) 238 | ;; (-> string? context? history? (listof history?) (values context? history? (listof history?))) 239 | (define arg (split-snd raw)) 240 | (if (member arg '(".." "../")) 241 | (back raw ctx hist pre-hist) 242 | (let-values (((ctx* hist*) 243 | (cond 244 | [(not arg) 245 | ;; Failed to parse argument, 246 | (print-unknown raw) 247 | (values ctx hist)] 248 | [(list? ctx) 249 | ;; Context is a list, try accessing by index 250 | (dive-list ctx hist arg)] 251 | [(hash? ctx) 252 | (dive-hash ctx hist arg)] 253 | [(zo? ctx) 254 | ;; Context is a zo, try looking up field 255 | (dive-zo ctx hist arg)] 256 | [else 257 | ;; Should never happen! REPL controls the context. 258 | (error 'zo-shell:dive (format "Invalid context '~a'" ctx))]))) 259 | ;; Return pre-hist unchanged 260 | (values ctx* hist* pre-hist)))) 261 | 262 | ;; Parse the string `arg` to an integer n. 263 | ;; If n is within the bounds of the list `ctx`, 264 | ;; push `ctx` onto the stack `hist` and return the n-th element of `ctx`. 265 | ;; Otherwise, return `ctx` and `hist` unchanged. 266 | (define (dive-list ctx hist arg) 267 | ;; (-> (listof (or/c zo? result?)) history? string? (values context? history?)) 268 | (define index (string->number arg)) 269 | (cond [(or (not index) (< index 0) (>= index (length ctx))) 270 | ;; Index out of bounds, or not a number. Cannot dive. 271 | (print-unknown (format "dive ~a" arg)) 272 | (values ctx hist)] 273 | [else 274 | ;; Select from list, 275 | (define res (list-ref ctx index)) 276 | ;; If list elements are search results, current `hist` can be safely ignored. 277 | (if (result? res) 278 | (values (result-zo res) (result-path res)) 279 | (values res (push hist ctx)))])) 280 | 281 | (define (dive-hash ctx hist arg) 282 | (define k (read-from-string arg)) 283 | (define res (if (unsupplied-arg? k) k (hash-ref ctx k the-unsupplied-arg))) 284 | (cond 285 | [(or (unsupplied-arg? k) (unsupplied-arg? res)) 286 | (print-unknown (format "dive ~a" arg)) 287 | (values ctx hist)] 288 | [else 289 | (if (result? res) 290 | (values (result-zo res) (result-path res)) 291 | (values res (push hist ctx)))])) 292 | 293 | (define (read-from-string str) 294 | (with-handlers ((exn:fail:read? (lambda (exn) the-unsupplied-arg))) 295 | (with-input-from-string str read))) 296 | 297 | ;; Use the string `field` to access a field in the zo struct `ctx`. 298 | ;; If the field exists and denotes another zo struct, return that 299 | ;; struct and push `ctx` on to the stack `hist`. 300 | ;; Otherwise, return `ctx` and `hist` unchanged. 301 | (define (dive-zo ctx hist field) 302 | ;; (-> zo? history? string? (values context? history?)) 303 | (define-values (ctx* success?) (zo-transition ctx field)) 304 | (cond 305 | [success? 306 | (values ctx* (push hist ctx))] 307 | [else 308 | (print-unknown (format "dive ~a" field)) 309 | (values ctx hist)])) 310 | 311 | ;; Parse argument, then search for & save results. 312 | (define (find raw ctx hist pre-hist) 313 | (define arg (split-snd raw)) 314 | (cond [(and arg (zo? ctx)) 315 | (define results (zo-find ctx arg)) 316 | (printf "FIND returned ~a results\n" (length results)) 317 | (match results 318 | ['() 319 | ;; No results, don't make a save mark 320 | (values ctx hist pre-hist)] 321 | [_ 322 | ;; Success! Show the results and save them, to allow jumps 323 | (printf "FIND automatically saving context\n") 324 | (print-context results) 325 | (save "" results (push hist ctx) pre-hist)])] 326 | [else 327 | (print-unknown raw) 328 | (values ctx hist pre-hist)])) 329 | 330 | 331 | ;; Jump back to a previously-saved location, if any. 332 | (define (jump raw ctx hist pre-hist) 333 | (match pre-hist 334 | ['() 335 | ;; Nothing to jump to 336 | (print-unknown raw) 337 | (values ctx hist pre-hist)] 338 | [_ 339 | (define-values (hist* pre-hist*) (pop pre-hist)) 340 | (define pre-hist** 341 | (if (null? pre-hist*) pre-hist pre-hist*)) 342 | (back raw ctx hist* pre-hist**)])) 343 | 344 | ;; Save the current context and history to the pre-history 345 | ;; For now, erases current history. 346 | (define (save raw ctx hist pre-hist) 347 | (values ctx '() (push pre-hist (push hist ctx)))) 348 | 349 | ;; ----------------------------------------------------------------------------- 350 | ;; --- history manipulation 351 | 352 | ;; Add the context `ctx` to the stack `hist`. 353 | (define (push hist ctx) 354 | ;; (-> history? context? history?) 355 | (cons ctx hist)) 356 | 357 | ;; Remove the top context from the stack `hist`. 358 | ;; Return the popped value and tail of `hist`. 359 | ;; Callers must avoid calling `pop` on empty stacks. 360 | (define (pop hist) 361 | ;; (-> history? (values context? history?)) 362 | (values (car hist) (cdr hist))) 363 | 364 | ;; ----------------------------------------------------------------------------- 365 | ;; --- print 366 | 367 | (define (print-alias) 368 | ;; (-> void?) 369 | (displayln "At your service. Command aliases:") 370 | (displayln 371 | (string-join 372 | (for/list ([cmd COMMANDS]) 373 | (format " ~a ~a" 374 | (command-name cmd) 375 | (string-join (command-aliases cmd)))) 376 | "\n"))) 377 | 378 | ;; Print a history object. 379 | (define (print-history hist) 380 | ;; (-> history? void?) 381 | (printf "History is: ~a\n" hist)) 382 | 383 | ;; Print a help message for the REPL. 384 | (define (print-help) 385 | ;; (-> void?) 386 | (displayln "At your service. Available commands:") 387 | (displayln 388 | (string-join 389 | (for/list ([cmd COMMANDS]) 390 | (format " ~a~a ~a" 391 | (command-name cmd) 392 | (if (= 1 (command-num-args cmd)) " ARG" " ") ;; hack 393 | (command-help-msg cmd))) 394 | "\n"))) 395 | 396 | ;; Print a context. 397 | (define (print-context ctx) 398 | ;; (-> context? void?) 399 | (match ctx 400 | [(? zo?) 401 | (displayln (zo->string ctx))] 402 | ['() 403 | (displayln "'()")] 404 | [(cons x _) 405 | (define z (if (result? x) (result-zo x) x)) 406 | (printf "~a[~a]~n" 407 | (zo->string z #:deep? #f) 408 | (length ctx))] 409 | [(? hash?) 410 | (format "{~a~n}~n" 411 | (string-join 412 | (for/list ([kv (in-list (sort (hash->list ctx) stringstring z #:deep? #f))) 415 | "\n "))] 416 | [_ 417 | (error 'zo-shell:info (format "Unknown context '~a'" ctx))])) 418 | 419 | ;; Print an error message (after receiving an undefined/invalid command). 420 | (define (print-unknown raw) 421 | ;; (-> string? void?) 422 | (printf "'~a' not permitted.\n" raw)) 423 | 424 | ;; Print a goodbye message (when the user exits the REPL). 425 | (define (print-goodbye) 426 | ;; (-> void?) 427 | (printf "Ascending to second-level meditation. Goodbye.\n\n")) 428 | 429 | ;; Print a debugging message. 430 | (define (print-debug str) 431 | ;; (-> string? void?) 432 | (printf "DEBUG: ~a\n" str)) 433 | 434 | ;; Print the REPL prompt. 435 | (define (make-prompt ctx) 436 | ;; (-> void?) 437 | (define tag (cond [(list? ctx) (format "[~a]" (length ctx))] 438 | [(hash? ctx) (format "(hash keys: ~a)" (hash-keys ctx))] 439 | [(zo? ctx) (format "(~a)" (car (zo->spec ctx)))] 440 | [else ""])) 441 | (string->bytes/locale 442 | (string-append tag " zo> "))) 443 | 444 | ;; Print an informative message. 445 | (define (print-info str) 446 | ;; (-> string? void?) 447 | (printf "INFO: ~a\n" str)) 448 | 449 | ;; Print a warning. 450 | (define (print-warn str) 451 | ;; (-> string? void?) 452 | (printf "WARN: ~a\n" str)) 453 | 454 | ;; Print an error message. 455 | (define (print-error str) 456 | ;; (-> string? void?) 457 | (printf "ERROR: ~a\n" str)) 458 | 459 | ;; Print usage information. 460 | (define USAGE 461 | "Usage: zo-shell FILE.zo") 462 | (define (print-usage) 463 | (displayln USAGE)) 464 | 465 | ;; ----------------------------------------------------------------------------- 466 | ;; --- misc 467 | 468 | (define (find-all name args #:limit [lim #f]) 469 | ;; (-> string? (listof string?) void) 470 | (print-info (format "Loading bytecode file '~a'..." name)) 471 | (call-with-input-file name 472 | (lambda (port) 473 | (print-info "Parsing bytecode...") 474 | (define ctx (zo-parse port)) 475 | (print-info "Parsing complete! Searching...") 476 | (for ([arg (in-list args)]) 477 | (printf "FIND '~a' : " arg) 478 | (printf "~a results\n" (length (zo-find ctx arg #:limit lim)))) 479 | (displayln "All done!")))) 480 | 481 | ;; True if the vector contains any command-line flags. 482 | ;; All flags begin with a hyphen, - 483 | (define (has-any-flags? v) 484 | ;; (-> (vectorof string) boolean?) 485 | (for/or ([str (in-vector v)]) 486 | (and (< 0 (string-length str)) 487 | (eq? #\- (string-ref str 0))))) 488 | 489 | ;; Check if second arg is a prefix of the first 490 | (define (starts-with? str prefix) 491 | ;; (-> string? string? boolean?) 492 | (and (<= (string-length prefix) 493 | (string-length str)) 494 | (for/and ([c1 (in-string str)] 495 | [c2 (in-string prefix)]) 496 | (char=? c1 c2)))) 497 | 498 | ;; Split a path like "cd ../BLAH/.." into a list of commands "cd ..; cd BLAH; cd .." 499 | (define (split-cd cmd*) 500 | ;; (-> (listof string?) (listof string?)) 501 | (match cmd* 502 | ['() '()] 503 | [(cons cd-cmd rest) 504 | #:when ((cmd? DIVE) cd-cmd) 505 | ;; Split "cd " commands by "/" 506 | (append 507 | (map (lambda (x) (string-append "dive " x)) (string-split (cadr (string-split cd-cmd)) "/")) 508 | (split-cd rest))] 509 | [(cons cmd rest) 510 | ;; Leave other commands alone 511 | (cons cmd (split-cd rest))])) 512 | 513 | ;; Split the string `raw` by whitespace and 514 | ;; return the second element of the split, if any. 515 | ;; Otherwise return `#f`. 516 | (define (split-snd raw) 517 | ;; (-> string? (or/c #f string?)) 518 | (define splt (string-split raw)) 519 | (match splt 520 | [(list _ x) x] 521 | [(list _ x ys ...) (print-warn (format "Ignoring extra arguments: '~a'" ys)) 522 | x] 523 | [_ #f])) 524 | 525 | ;; ============================================================================= 526 | ;; --- testing 527 | 528 | (module+ test 529 | (require rackunit 530 | compiler/zo-structs) 531 | 532 | ;; Hijack the print statements 533 | (define-values (in out) (make-pipe)) 534 | (current-output-port out) 535 | 536 | ;; --- API 537 | ;; -- invalid args for init. read-line makes sure some message was printed. 538 | (test-case "-- TODO more init tests" 539 | (check-equal? (init '#()) (void))) 540 | 541 | (test-case "--- command predicates" 542 | (check-pred (cmd? ALST) "alst") 543 | (check-pred (cmd? ALST) "a") 544 | (check-pred (cmd? ALST) "alias") 545 | (check-pred (cmd? ALST) "aliases")) 546 | 547 | (check-false ((cmd? ALST) "alias ARG")) 548 | (check-false ((cmd? ALST) "ALIAS")) 549 | (check-false ((cmd? ALST) "help")) 550 | (check-false ((cmd? ALST) "")) 551 | 552 | (check-pred (cmd? BACK) "back") 553 | (check-pred (cmd? BACK) "b") 554 | (check-pred (cmd? BACK) "up") 555 | (check-pred (cmd? BACK) "../") 556 | (check-pred (cmd? BACK) "..") 557 | 558 | (check-false ((cmd? BACK) "back ARG")) 559 | (check-false ((cmd? BACK) "BACK")) 560 | (check-false ((cmd? BACK) "help")) 561 | (check-false ((cmd? BACK) "")) 562 | 563 | ;; -- DIVE command requires a single argument (doesn't fail for multiple arguments) 564 | (check-pred (cmd? DIVE) "dive ARG") 565 | (check-pred (cmd? DIVE) "d ARG") 566 | (check-pred (cmd? DIVE) "cd ARG") 567 | (check-pred (cmd? DIVE) "next ARG") 568 | 569 | (check-false ((cmd? DIVE) "step ARG1 ARG2 ARG3")) 570 | (check-false ((cmd? DIVE) "dive")) 571 | (check-false ((cmd? DIVE) "d")) 572 | (check-false ((cmd? DIVE) "quit")) 573 | (check-false ((cmd? DIVE) "a mistake")) 574 | 575 | ;; -- FIND command takes one argument, just like DIVE 576 | (check-pred (cmd? FIND) "find ARG") 577 | (check-pred (cmd? FIND) "search branch") 578 | (check-pred (cmd? FIND) "look up") 579 | 580 | (check-false ((cmd? FIND) "query ")) 581 | (check-false ((cmd? FIND) "f ARG1 ARG2 ARG3")) 582 | (check-false ((cmd? FIND) "find")) 583 | (check-false ((cmd? FIND) "back")) 584 | (check-false ((cmd? FIND) "hello world")) 585 | 586 | (check-pred (cmd? HELP) "help") 587 | (check-pred (cmd? HELP) "h") 588 | (check-pred (cmd? HELP) "--help") 589 | (check-pred (cmd? HELP) "-help") 590 | 591 | (check-false ((cmd? HELP) "ohgosh")) 592 | (check-false ((cmd? HELP) "help me")) 593 | (check-false ((cmd? HELP) "lost")) 594 | (check-false ((cmd? HELP) "stuck, please help")) 595 | 596 | (check-pred (cmd? INFO) "info") 597 | (check-pred (cmd? INFO) "i") 598 | (check-pred (cmd? INFO) "print") 599 | (check-pred (cmd? INFO) "show") 600 | 601 | (check-false ((cmd? INFO) "println")) 602 | (check-false ((cmd? INFO) "help")) 603 | (check-false ((cmd? INFO) "display")) 604 | (check-false ((cmd? INFO) "write to out")) 605 | 606 | (check-pred (cmd? JUMP) "jump") 607 | (check-pred (cmd? JUMP) "j") 608 | (check-pred (cmd? JUMP) "warp") 609 | (check-pred (cmd? JUMP) "top") 610 | 611 | (check-false ((cmd? JUMP) "jump a")) 612 | (check-false ((cmd? JUMP) "w")) 613 | 614 | (check-pred (cmd? SAVE) "save") 615 | (check-pred (cmd? SAVE) "mark") 616 | 617 | (check-false ((cmd? SAVE) "lasd")) 618 | (check-false ((cmd? SAVE) "step")) 619 | (check-false ((cmd? SAVE) "")) 620 | (check-false ((cmd? SAVE) "save z")) 621 | 622 | (check-pred (cmd? QUIT) "q") 623 | (check-pred (cmd? QUIT) "quit") 624 | (check-pred (cmd? QUIT) "exit") 625 | (check-pred (cmd? QUIT) "leave") 626 | 627 | (check-false ((cmd? QUIT) "(quit)")) 628 | (check-false ((cmd? QUIT) "(exit)")) 629 | (check-false ((cmd? QUIT) "get me out of here")) 630 | 631 | ;; --- command implementations 632 | 633 | ;; -- dive end-to-end 634 | ;; Invalid command 635 | (let ([ctx '()] 636 | [hist '()] 637 | [arg "dive "] 638 | [pre-hist '(a aa)]) 639 | (define-values (ctx* hist* pre*) (dive arg ctx hist pre-hist)) 640 | (check-equal? ctx ctx*) 641 | (check-equal? hist hist*) 642 | (check-equal? pre-hist pre*)) 643 | 644 | ;; List out-of-bounds 645 | (let ([ctx '((a) (b))] 646 | [hist '((c) (d))] 647 | [arg "dive 2"] 648 | [pre-hist '(x y z)]) 649 | (define-values (ctx* hist* pre*) (dive arg ctx hist pre-hist)) 650 | (check-equal? ctx ctx*) 651 | (check-equal? hist hist*) 652 | (check-equal? pre-hist pre*)) 653 | 654 | ;; List, in-bounds 655 | (let ([ctx '((a) (b))] 656 | [hist '((c) (d))] 657 | [arg "dive 0"] 658 | [pre-hist '('())]) 659 | (define-values (ctx* hist* pre*) (dive arg ctx hist pre-hist)) 660 | (check-equal? ctx* (car ctx)) 661 | (check-equal? hist* (cons ctx hist))) 662 | 663 | ;; List, search results. Ignores current history 664 | (let ([ctx (list (result (zo) '()))] 665 | [hist '((c) (d))] 666 | [pre-hist '(blah)] 667 | [arg "dive 0"]) 668 | (define-values (ctx* hist* pre*) (dive arg ctx hist pre-hist)) 669 | (check-equal? ctx* (result-zo (car ctx))) 670 | (check-equal? pre-hist pre*) 671 | (check-equal? hist* '())) 672 | 673 | ;; List, search results. Ignores current history, overwrites with search result history 674 | (let ([ctx (list (result (zo) '(a a a)))] 675 | [hist '((c) (d))] 676 | [arg "dive 0"] 677 | [pre-hist '(a 78)]) 678 | (define-values (ctx* hist* pre*) (dive arg ctx hist pre-hist)) 679 | (check-equal? ctx* (result-zo (car ctx))) 680 | (check-equal? hist* (result-path (car ctx))) 681 | (check-equal? pre-hist pre*)) 682 | 683 | ;; zo, valid field 684 | (let* ([z (branch '() '() '())] 685 | [ctx (branch z '() '())] 686 | [hist '()] 687 | [pre-hist '(7 7 7)] 688 | [arg "dive test"]) 689 | (define-values (ctx* hist* pre*) (dive arg ctx hist pre-hist)) 690 | (check-equal? ctx* z) 691 | (check-equal? hist* (cons ctx hist)) 692 | (check-equal? pre-hist pre*)) 693 | 694 | ;; zo, invalid field 695 | (let ([ctx (branch '() '() '())] 696 | [hist '()] 697 | [pre-hist '(a b x)] 698 | [arg "dive datum"]) 699 | (define-values (ctx* hist* pre*) (dive arg ctx hist pre-hist)) 700 | (check-equal? ctx* ctx) 701 | (check-equal? hist* hist) 702 | (check-equal? pre* pre-hist)) 703 | 704 | (test-case "dive-list" 705 | ;; Valid list access 706 | (let ([ctx '(a b c)] [hist '(d)] [arg "2"]) 707 | (let-values ([(ctx* hist*) (dive-list ctx hist arg)]) 708 | (begin (check-equal? ctx* (caddr ctx)) 709 | (check-equal? hist* (cons ctx hist))))) 710 | 711 | ;; Invalid, index is not an integer 712 | (let ([ctx '(a)] [hist '()] [arg "x"]) 713 | (let-values ([(ctx* hist*) (dive-list ctx hist arg)]) 714 | (begin (check-equal? ctx* ctx) 715 | (check-equal? hist* hist)))) 716 | 717 | ;; Invalid, index is not in bounds 718 | (let ([ctx '(a b c)] [hist '(d)] [arg "3"]) 719 | (let-values ([(ctx* hist*) (dive-list ctx hist arg)]) 720 | (begin (check-equal? ctx* ctx) 721 | (check-equal? hist* hist)))) 722 | 723 | ;; Search results, hist overwritten 724 | (let ([ctx (list (result (zo) '(a)) 725 | (result (expr) '(b)) 726 | (result (branch '() '() '()) '(c)) 727 | (result (form) '(d)))] 728 | [hist '(e)] 729 | [arg "3"]) 730 | (let-values ([(ctx* hist*) (dive-list ctx hist arg)]) 731 | (begin (check-equal? ctx* (result-zo (cadddr ctx))) 732 | (check-equal? hist* (result-path (cadddr ctx))))))) 733 | 734 | (test-case "dive-zo" 735 | ;; (I'm creating these zo structs arbitrarily, 736 | ;; using the contracts in 'zo-lib/compiler/zo-structs.rkt') 737 | ;; Valid, field is a zo 738 | (let* ([z (localref #f 0 #f #f #f)] 739 | [ctx (branch #t z #t)] 740 | [hist '()] 741 | [arg "then"]) 742 | (let-values ([(ctx* hist*) (dive-zo ctx hist arg)]) 743 | (begin (check-equal? ctx* z) 744 | (check-equal? hist* (cons ctx hist))))) 745 | 746 | ;; Valid, field is a list of zo 747 | (let* ([z (toplevel 999 1 #t #t)] 748 | [ctx (def-values (list z z 'arbitrary-symbol) #f)] 749 | [hist '(d)] 750 | [arg "ids"]) 751 | (let-values ([(ctx* hist*) (dive-zo ctx hist arg)]) 752 | (begin (check-equal? ctx* (list z z)) 753 | (check-equal? hist* (cons ctx hist))))) 754 | 755 | ;; Invalid, field is not a zo 756 | (let* ([z (localref #f 0 #f #f #f)] 757 | [ctx (branch #t z #t)] 758 | [hist '()] 759 | [arg "test"]) 760 | (let-values ([(ctx* hist*) (dive-zo ctx hist arg)]) 761 | (begin (check-equal? ctx* ctx) 762 | (check-equal? hist* hist)))) 763 | 764 | ;; Invalid, field is a list that does not contain any zo 765 | (let* ([z (toplevel 999 1 #t #t)] 766 | [ctx (def-values (list z z 'arbitrary-symbol) #f)] 767 | [hist '(d)] 768 | [arg "rhs"]) 769 | (let-values ([(ctx* hist*) (dive-zo ctx hist arg)]) 770 | (begin (check-equal? ctx* ctx) 771 | (check-equal? hist* hist)))) 772 | 773 | ;; Invalid, field does not exist 774 | (let* ([z (localref #f 0 #f #f #f)] 775 | [ctx (branch #t z #t)] 776 | [hist '()] 777 | [arg ""]) 778 | (let-values ([(ctx* hist*) (dive-zo ctx hist arg)]) 779 | (begin (check-equal? ctx* ctx) 780 | (check-equal? hist* hist))))) 781 | 782 | (test-case "dive-hash" 783 | (let ([ctx (make-immutable-hash '((a . 1) (b . 2)))] [hist '(d)] [arg "a"]) 784 | (let-values ([(ctx* hist*) (dive-hash ctx hist arg)]) 785 | (begin (check-equal? ctx* (hash-ref ctx 'a)) 786 | (check-equal? hist* (cons ctx hist))))) 787 | 788 | (let ([ctx (make-immutable-hash '((a . 1) (b . 2)))] [hist '(d)] [arg "400"]) 789 | (let-values ([(ctx* hist*) (dive-hash ctx hist arg)]) 790 | (begin (check-equal? ctx* ctx) 791 | (check-equal? hist* hist)))) 792 | 793 | ;; Search results, hist overwritten 794 | (let ([ctx (make-immutable-hash 795 | (list (cons 0 (result (zo) '(a))) 796 | (cons 1 (result (expr) '(b))) 797 | (cons 2 (result (branch '() '() '()) '(c))) 798 | (cons 3 (result (form) '(d)))))] 799 | [hist '(e)] 800 | [arg "3"]) 801 | (let-values ([(ctx* hist*) (dive-hash ctx hist arg)] 802 | [(real-res) (hash-ref ctx 3)]) 803 | (begin (check-equal? ctx* (result-zo real-res)) 804 | (check-equal? hist* (result-path real-res)))))) 805 | 806 | (test-case "find" 807 | ;; Success, search 1 level down 808 | (let* ([z (branch '() '() '())] 809 | [st (seq (list z))] 810 | [ctx (seq (list st))] 811 | [raw "find branch"] 812 | [hist '(A)] 813 | [pre-hist '(a b)]) 814 | (let-values ([(ctx* hist* pre-hist*) (find raw ctx hist pre-hist)]) 815 | (begin (check-equal? (result-zo (car ctx*)) z) 816 | (check-equal? (result-path (car ctx*)) (list st)) 817 | (check-equal? hist* '()) 818 | (check-equal? pre-hist* (cons (cons ctx* (cons ctx hist)) pre-hist))))) 819 | 820 | ;; Failure, search 1 level down 821 | (let* ([z (branch '() '() '())] 822 | [st (branch z '() '())] 823 | [ctx (seq (list st))] 824 | [raw "find local-binding"] 825 | [hist '(A)] 826 | [pre-hist '(a b)]) 827 | (let-values ([(ctx* hist* pre-hist*) (find raw ctx hist pre-hist)]) 828 | (begin (check-equal? ctx* ctx) 829 | (check-equal? hist* hist) 830 | (check-equal? pre-hist* pre-hist)))) 831 | 832 | ;; Success, deeper search. Note that the top struct is not in the results 833 | (let* ([ctx (branch #t #t (branch #t #t (branch #t #t (branch #t #t #t))))] 834 | [raw "find branch"] 835 | [hist '(asa)] 836 | [pre-hist '(b c s)]) 837 | (let-values ([(ctx* hist* pre-hist*) (find raw ctx hist pre-hist)]) 838 | (begin (check-equal? (length ctx*) 3) 839 | (check-equal? (result-zo (car ctx*)) (branch-else ctx)) 840 | (check-equal? (result-path (cadr ctx*)) (list (branch-else ctx))) 841 | (check-equal? hist* '()) 842 | (check-equal? pre-hist* (cons (cons ctx* (cons ctx hist)) pre-hist))))) 843 | 844 | ;; Success, deeper search. 845 | (let* ([z (beg0 '())] 846 | [ctx (branch #t #t (branch #t #t (branch #t #t (branch #t z #t))))] 847 | [raw "find beg0"] 848 | [hist '(asa)] 849 | [pre-hist '(b c s)]) 850 | (let-values ([(ctx* hist* pre-hist*) (find raw ctx hist pre-hist)]) 851 | (begin (check-equal? (length ctx*) 1) 852 | (check-equal? (result-zo (car ctx*)) 853 | (branch-then (branch-else (branch-else (branch-else ctx))))) 854 | (check-equal? (result-path (car ctx*)) 855 | (list (branch-else (branch-else (branch-else ctx))) 856 | (branch-else (branch-else ctx)) 857 | (branch-else ctx))) 858 | (check-equal? hist* '()) 859 | (check-equal? pre-hist* (cons (cons ctx* (cons ctx hist)) pre-hist)))))) 860 | 861 | ;; -- back 862 | ;; - Failure, cannot go back 863 | (let* ([ctx 'a] 864 | [hist '()] 865 | [pre-hist '()]) 866 | (let-values ([(ctx* hist* pre-hist*) (back 'foo ctx hist pre-hist)]) 867 | (begin (check-equal? ctx* ctx) 868 | (check-equal? hist* hist) 869 | (check-equal? pre-hist* pre-hist)))) 870 | 871 | ;; - Success, use hist to go back 872 | (let* ([ctx 'a] 873 | [hist '(b)] 874 | [pre-hist '()]) 875 | (let-values ([(ctx* hist* pre-hist*) (back 'foo ctx hist pre-hist)]) 876 | (begin (check-equal? ctx* 'b) 877 | (check-equal? hist* '()) 878 | (check-equal? pre-hist* pre-hist)))) 879 | 880 | ;; - Success, use hist to go back (Do not change pre-hist) 881 | (let* ([ctx 'a] 882 | [hist '(b c)] 883 | [pre-hist '(x y)]) 884 | (let-values ([(ctx* hist* pre-hist*) (back 'foo ctx hist pre-hist)]) 885 | (begin (check-equal? ctx* 'b) 886 | (check-equal? hist* (cdr hist)) 887 | (check-equal? pre-hist* pre-hist)))) 888 | 889 | ;; - Success, use pre-hist to go back 890 | (let* ([ctx 'z] 891 | [hist '()] 892 | [pre-hist '((a b c) (d e f))]) 893 | (let-values ([(ctx* hist* pre-hist*) (back 'foo ctx hist pre-hist)]) 894 | (begin (check-equal? ctx* 'a) 895 | (check-equal? hist* (cdar pre-hist)) 896 | (check-equal? pre-hist* (cdr pre-hist))))) 897 | 898 | ;; - Success, never empty the pre-list 899 | (let* ([ctx 'z] 900 | [hist '()] 901 | [pre-hist '((a b c))]) 902 | (let-values ([(ctx* hist* pre-hist*) (back 'foo ctx hist pre-hist)]) 903 | (begin (check-equal? ctx* 'a) 904 | (check-equal? hist* (cdar pre-hist)) 905 | (check-equal? pre-hist* pre-hist)))) 906 | 907 | ;; -- jump 908 | ;; - Fail, no pre-hist 909 | (let* ([ctx 'a] 910 | [hist '(b c d)] 911 | [pre-hist '()]) 912 | (let-values ([(ctx* hist* pre-hist*) (jump 'raw ctx hist pre-hist)]) 913 | (begin (check-equal? ctx* ctx) 914 | (check-equal? hist* hist) 915 | (check-equal? pre-hist* pre-hist)))) 916 | 917 | ;; - Success! Has pre-hist 918 | (let* ([ctx 'z] 919 | [hist '()] 920 | [pre-hist '((a b c) (d e f))]) 921 | (let-values ([(ctx* hist* pre-hist*) (jump 'raw ctx hist pre-hist)]) 922 | (begin (check-equal? ctx* 'a) 923 | (check-equal? hist* (cdar pre-hist)) 924 | (check-equal? pre-hist* (cdr pre-hist))))) 925 | 926 | ;; - Success! Never empty the pre-hist 927 | (let* ([ctx 'z] 928 | [hist '()] 929 | [pre-hist '((a b))]) 930 | (let-values ([(ctx* hist* pre-hist*) (jump 'raw ctx hist pre-hist)]) 931 | (begin (check-equal? ctx* 'a) 932 | (check-equal? hist* (cdar pre-hist)) 933 | (check-equal? pre-hist* pre-hist)))) 934 | 935 | ;; - Success, clobber old hist 936 | (let* ([ctx 'z] 937 | [hist '(l o l)] 938 | [pre-hist '((a b c) (d e f))]) 939 | (let-values ([(ctx* hist* pre-hist*) (jump 'raw ctx hist pre-hist)]) 940 | (begin (check-equal? ctx* 'a) 941 | (check-equal? hist* (cdar pre-hist)) 942 | (check-equal? pre-hist* (cdr pre-hist))))) 943 | 944 | ;; -- save 945 | ;; - Always succeeds, just move hist to the pre-hist 946 | (let* ([ctx 'z] 947 | [hist '(l o l)] 948 | [pre-hist '((a b c) (d e f))]) 949 | (let-values ([(ctx* hist* pre-hist*) (save 'raw ctx hist pre-hist)]) 950 | (begin (check-equal? ctx* 'z) 951 | (check-equal? hist* '()) 952 | (check-equal? pre-hist* (cons (cons ctx hist) pre-hist))))) 953 | 954 | (let* ([ctx 'z] 955 | [hist '()] 956 | [pre-hist '()]) 957 | (let-values ([(ctx* hist* pre-hist*) (save 'raw ctx hist pre-hist)]) 958 | (begin (check-equal? ctx* 'z) 959 | (check-equal? hist* hist) 960 | (check-equal? pre-hist* (cons (list ctx) pre-hist))))) 961 | 962 | (let* ([ctx 'z] 963 | [hist '()] 964 | [pre-hist '(yolo)]) 965 | (let-values ([(ctx* hist* pre-hist*) (save 'raw ctx hist pre-hist)]) 966 | (begin (check-equal? ctx* 'z) 967 | (check-equal? hist* hist) 968 | (check-equal? pre-hist* '((z) yolo))))) 969 | 970 | ;; --- history manipulation 971 | (check-equal? (push '() 'x) '(x)) 972 | (check-equal? (push '() '()) '(())) 973 | 974 | (let-values ([(hd tl) (pop '(a b c))]) 975 | (begin (check-equal? hd 'a) 976 | (check-equal? tl '(b c)))) 977 | (let-values ([(hd tl) (pop '(()))]) 978 | (begin (check-equal? hd '()) 979 | (check-equal? tl '()))) 980 | 981 | ;; --- printing 982 | (print-alias) 983 | 984 | 985 | (print-history '()) 986 | 987 | (print-help) 988 | 989 | (print-context '()) 990 | 991 | (print-context (beg0 '())) 992 | 993 | (print-context (list (result (beg0 '()) '()))) 994 | 995 | (print-context (make-immutable-hash (list (cons 'A (result (beg0 '()) '()))))) 996 | 997 | (print-unknown "") 998 | 999 | (print-goodbye) 1000 | 1001 | (print-debug "") 1002 | 1003 | (check-pred string? WELCOME) 1004 | 1005 | (check-true 1006 | (bytes? (make-prompt '()))) 1007 | 1008 | (print-info "") 1009 | 1010 | (print-warn "") 1011 | 1012 | (print-error "") 1013 | 1014 | (print-usage) 1015 | 1016 | ;; --- parsing 1017 | ;; Success, has exactly one whitespace 1018 | (let* ([arg "hey jude"] 1019 | [res "jude"]) 1020 | (check-equal? (split-snd arg) res)) 1021 | 1022 | ;; Success, but prints warning about extra arguments 1023 | (let* ([arg "hel lo world"] 1024 | [res "lo"]) 1025 | (check-equal? (split-snd arg) res)) 1026 | 1027 | ;; Failure, no whitespace 1028 | (let* ([arg "yolo"] 1029 | [res #f]) 1030 | (check-equal? (split-snd arg) res)) 1031 | 1032 | ;; Failure, no characters 1033 | (let* ([arg ""] 1034 | [res #f]) 1035 | (check-equal? (split-snd arg) res)) 1036 | 1037 | ;; -- has-any-flags? 1038 | (define-syntax-rule (has-any-flags-test arg res) 1039 | (check-equal? (has-any-flags? arg) res)) 1040 | 1041 | (has-any-flags-test 1042 | (vector "a" "b" "c") 1043 | #f) 1044 | 1045 | (has-any-flags-test 1046 | (vector "" "b" "c") 1047 | #f) 1048 | 1049 | (has-any-flags-test 1050 | (vector "file.zo") 1051 | #f) 1052 | 1053 | (has-any-flags-test 1054 | (vector "file.zo" "arg1" "arg2" "arg3") 1055 | #f) 1056 | 1057 | (has-any-flags-test 1058 | (vector "file.zo" "--help") 1059 | #t) 1060 | 1061 | (has-any-flags-test 1062 | (vector "--help" "file.zo") 1063 | #t) 1064 | 1065 | (has-any-flags-test 1066 | (vector "--help" "file.zo" "struct-name") 1067 | #t) 1068 | 1069 | (has-any-flags-test 1070 | (vector "-file.zo") 1071 | #t) 1072 | 1073 | (has-any-flags-test 1074 | (vector "file.zo" "struct1" "struct2" "-accident") 1075 | #t) 1076 | 1077 | ;; -- starts-with 1078 | (check-true (starts-with? "racket" "")) 1079 | (check-true (starts-with? "racket" "r")) 1080 | (check-true (starts-with? "racket" "rack")) 1081 | (check-true (starts-with? "racket" "racket")) 1082 | (check-false (starts-with? "" "racket")) 1083 | (check-false (starts-with? "racket" "R")) 1084 | (check-false (starts-with? "racket" "rak")) 1085 | (check-false (starts-with? "racket" "racket2")) 1086 | 1087 | ;; -- split-cd 1088 | (check-equal? (split-cd '("")) '("")) 1089 | (for ([a (in-list (command-aliases DIVE))]) 1090 | (check-equal? (split-cd (list (format "~a ../../" a))) 1091 | '("dive .." "dive .."))) 1092 | (check-equal? (split-cd '("a" "b" "dive" "c")) '("a" "b" "dive" "c")) 1093 | (check-equal? (split-cd '("a" "dive ../foo/bar" "car")) '("a" "dive .." "dive foo" "dive bar" "car")) 1094 | 1095 | ) ;; --- end testing 1096 | -------------------------------------------------------------------------------- /private/zo-string.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Convert a zo struct to a more readable string representation. 4 | 5 | ;; Uses predicates to guess which struct we have, then convert the known 6 | ;; fields to strings. 7 | ;; Printing a field recursively is potentially expensive, 8 | ;; so we wrap the computation in a thunk. 9 | ;; The macro `lcons` makes thunk creation a little prettier. 10 | ;; The function `format-spec` forces these thunks. 11 | 12 | ;; Documentation for zo structs is online: 13 | ;; http://docs.racket-lang.org/raco/decompile.html 14 | 15 | (provide 16 | zo->string 17 | ;; (->* (zo?) (#:deep? boolean?) string?) 18 | ;; Return a string representation of a zo struct 19 | 20 | zo->spec 21 | ;; (->i ([z zo?]) () [res (z) (and/c spec/c (specof z))]) 22 | ;; Return a list-of-strings representation of a zo struct. 23 | ;; The structure of the list mirrors the structure of the original zo struct. 24 | 25 | specof spec/c 26 | ;; Contracts for conversion functions. 27 | ) 28 | 29 | (require 30 | compiler/zo-structs 31 | ;zordoz/typed/zo-structs ;; For testing 32 | racket/contract 33 | racket/match 34 | (only-in racket/string string-join) 35 | (for-syntax racket/base racket/syntax) 36 | (only-in zordoz/private/dispatch-table make-table) 37 | ) 38 | 39 | ;; ----------------------------------------------------------------------------- 40 | 41 | ;; --- string specifications 42 | 43 | ;; Contract for conversion functions. 44 | ;; A spec/c is the name of a zo struct and a list of pairs representing its fields: 45 | ;; - The car of each field is the name of that field 46 | ;; - The cdr of each field is a thunk for building a representation of the field's value. 47 | ;; If the value is a zo-struct, the thunk should build a spec/c 48 | ;; Otherwise, the thunk should build a string 49 | (define spec/c 50 | (recursive-contract 51 | (cons/c string? (listof (cons/c string? (-> (or/c spec/c string?))))))) 52 | 53 | ;; Given a zo struct `z`, creates a predicate that accepts only specs with the 54 | ;; same number of elements as the struct `z` has fields (+1, for the title). 55 | (define ((specof z) res) 56 | (= (length res) (vector-length (struct->vector z)))) 57 | 58 | ;; ============================================================================= 59 | 60 | ;; --- API functions 61 | 62 | ;; Convert any zo struct to a spec/c representation. 63 | (define/contract 64 | (zo->spec z) 65 | (->i ([z zo?]) () [res (z) (and/c spec/c (specof z))]) 66 | (define z* (try-spec z)) 67 | (if z* 68 | z* 69 | (error (format "Cannot format unknown struct ~e" z)))) 70 | 71 | ;; Convert any zo struct to a string. 72 | ;; First builds a spec, then forces the thunks in that spec to build a string. 73 | ;; If `deep` is `#f`, only formats the name of the struct `z`. 74 | (define/contract 75 | (zo->string z #:deep? [deep? #t]) 76 | (->* (zo?) (#:deep? boolean?) string?) 77 | (format-spec deep? (zo->spec z))) 78 | 79 | ;; --- syntax: lazy cons to delay evaluation of tail 80 | 81 | ;; Introduces syntax (lcons a:any b:any). 82 | ;; Wraps second argument in a thunk. 83 | (define-syntax (lcons stx) 84 | (syntax-case stx () 85 | [(_) (raise-syntax-error #f "[lcons] Expected two arguments.")] 86 | [(_ _) (raise-syntax-error #f "[lcons] Expected two arguments.")] 87 | [(_ hd tl) #'(cons hd (lambda () tl))])) 88 | 89 | ;; --- dispatch tables 90 | 91 | (define try-spec 92 | (make-table 93 | #:action ->spec 94 | linkl-directory 95 | linkl-bundle 96 | linkl 97 | form 98 | inline-variant 99 | expr)) 100 | 101 | (define form->spec 102 | (make-table 103 | #:action ->spec 104 | def-values 105 | seq 106 | expr)) 107 | 108 | (define expr->spec 109 | (make-table 110 | #:action ->spec 111 | lam 112 | closure 113 | case-lam 114 | let-one 115 | let-void 116 | install-value 117 | let-rec 118 | boxenv 119 | localref 120 | toplevel 121 | application 122 | branch 123 | with-cont-mark 124 | seq 125 | beg0 126 | varref 127 | assign 128 | apply-values 129 | with-immed-mark 130 | primval)) 131 | 132 | (define (false? x) 133 | (eq? #f x)) 134 | 135 | (define (false->spec x) 136 | (boolean->string x)) 137 | 138 | (define constantness->spec 139 | (make-table 140 | #:action ->spec 141 | symbol 142 | false 143 | function-shape 144 | struct-shape 145 | struct-type-shape 146 | constructor-shape 147 | predicate-shape 148 | accessor-shape 149 | mutator-shape 150 | struct-type-property-shape 151 | property-predicate-shape 152 | property-accessor-shape 153 | struct-other-shape)) 154 | 155 | (define (constantness->string c) 156 | (define x (constantness->spec c)) 157 | (if (string? x) x (format-spec #f x))) 158 | 159 | ;; --- private functions 160 | 161 | (define 162 | (linkl-directory->spec ld) 163 | (list "linkl-directory" 164 | (lcons "table" (hash->spec any->string linkl-bundle->string (linkl-directory-table ld))))) 165 | 166 | (define (linkl-bundle->string lb) 167 | (format-spec #f (linkl-bundle->spec lb))) 168 | 169 | (define (linkl-or-any->string lx) 170 | (if (linkl? lx) 171 | (format-spec #f (linkl->spec lx)) 172 | (any->string lx))) 173 | 174 | (define 175 | (linkl-bundle->spec lb) 176 | (list "linkl-bundle" 177 | (lcons "table" (hash->spec any->string linkl-or-any->string (linkl-bundle-table lb))))) 178 | 179 | (define 180 | (linkl->spec l) 181 | (list "linkl" 182 | (lcons "name" (symbol->spec (linkl-name l))) 183 | (lcons "importss" (any->string (linkl-importss l))) 184 | (lcons "import-shapess" (list->string import-shapes->spec (linkl-import-shapess l))) 185 | (lcons "exports" (any->string (linkl-exports l))) 186 | (lcons "internals" (any->string (linkl-internals l))) 187 | (lcons "lifts" (any->string (linkl-lifts l))) 188 | (lcons "source-names" (any->string (linkl-source-names l))) 189 | (lcons "body" (listof-form-or-any->string (linkl-body l))) 190 | (lcons "max-let-depth" (number->string (linkl-max-let-depth l))) 191 | (lcons "need-instance-access?" (boolean->string (linkl-need-instance-access? l))))) 192 | 193 | (define (import-shapes->spec is) 194 | (list->string constantness->string is)) 195 | 196 | ;; --- form 197 | 198 | (define 199 | (def-values->spec z) 200 | (list "def-values" 201 | (lcons "ids" (list->string toplevel-or-symbol->string (def-values-ids z))) 202 | (lcons "rhs" (let ([rhs (def-values-rhs z)]) 203 | (cond [(inline-variant? rhs) (inline-variant->spec rhs)] 204 | [else (expr-seq-any->string rhs)]))))) 205 | 206 | (define 207 | (seq->spec z) 208 | (list "seq" 209 | (lcons "forms" (listof-form-or-any->string (seq-forms z))))) 210 | 211 | (define 212 | (inline-variant->spec z) 213 | (list "inline-variant" 214 | (lcons "direct" (expr->spec (inline-variant-direct z))) 215 | (lcons "inline" (expr->spec (inline-variant-inline z))))) 216 | 217 | ;; --- expr 218 | 219 | ;; Helper for `lam` and `case-lam`. 220 | (define (lam-name->spec nm) 221 | (match nm 222 | [(? vector?) 223 | (any->string nm)] 224 | ['() 225 | "()"] 226 | [(? symbol?) 227 | (symbol->string nm)])) 228 | 229 | (define 230 | (lam->spec z) 231 | (define (closure-map->spec cm) 232 | (list->string number->string (vector->list cm))) 233 | (define (toplevel-map->spec tm) 234 | (cond [(eq? #f tm) "#f"] 235 | [else (format-list #:sep " " (for/list ([n tm]) (number->string n)))])) 236 | (list "lam" 237 | (lcons "name" (lam-name->spec (lam-name z))) 238 | (lcons "flags" (list->string symbol->string (lam-flags z))) 239 | (lcons "num-params" (number->string (lam-num-params z))) 240 | (lcons "param-types" (list->string symbol->string (lam-param-types z))) 241 | (lcons "rest?" (boolean->string (lam-rest? z))) 242 | (lcons "closure-map" (closure-map->spec (lam-closure-map z))) 243 | (lcons "closure-types" (list->string symbol->string (lam-closure-types z))) 244 | (lcons "toplevel-map" (toplevel-map->spec (lam-toplevel-map z))) 245 | (lcons "max-let-depth" (number->string (lam-max-let-depth z))) 246 | (lcons "body" (expr-seq-any->string (lam-body z))))) 247 | 248 | (define 249 | (closure->spec z) 250 | (list "closure" 251 | (lcons "code" (lam->spec (closure-code z))) 252 | (lcons "gen-id" (symbol->string (closure-gen-id z))))) 253 | 254 | (define 255 | (case-lam->spec z) 256 | (list "case-lam" 257 | (lcons "name" (lam-name->spec (case-lam-name z))) 258 | (lcons "clauses" (list->string (lambda (x) (format-spec #f (expr->spec x))) (case-lam-clauses z))))) 259 | 260 | (define 261 | (let-one->spec z) 262 | (list "let-one" 263 | (lcons "rhs" (expr-seq-any->string (let-one-rhs z))) 264 | (lcons "body" (expr-seq-any->string (let-one-body z))) 265 | (lcons "type" (symbol-or-f->string (let-one-type z))) 266 | (lcons "unused?" (boolean->string (let-one-unused? z))))) 267 | 268 | (define 269 | (let-void->spec z) 270 | (list "let-void" 271 | (lcons "count" (number->string (let-void-count z))) 272 | (lcons "boxes" (boolean->string (let-void-boxes? z))) 273 | (lcons "body" (expr-seq-any->string (let-void-body z))))) 274 | 275 | (define 276 | (install-value->spec z) 277 | (list "install-value" 278 | (lcons "count" (number->string (install-value-count z))) 279 | (lcons "pos" (number->string (install-value-pos z))) 280 | (lcons "boxes?" (boolean->string (install-value-boxes? z))) 281 | (lcons "rhs" (expr-seq-any->string (install-value-rhs z))) 282 | (lcons "body" (expr-seq-any->string (install-value-body z))))) 283 | 284 | (define 285 | (let-rec->spec z) 286 | (list "let-rec" 287 | (lcons "procs" (listof-zo->string lam->spec (let-rec-procs z))) 288 | (lcons "body" (expr-seq-any->string (let-rec-body z))))) 289 | 290 | (define 291 | (boxenv->spec z) 292 | (list "boxenv" 293 | (lcons "pos" (number->string (boxenv-pos z))) 294 | (lcons "body" (expr-seq-any->string (boxenv-body z))))) 295 | 296 | (define 297 | (localref->spec z) 298 | (list "localref" 299 | (lcons "unbox?" (boolean->string (localref-unbox? z))) 300 | (lcons "pos" (number->string (localref-pos z))) 301 | (lcons "clear?" (boolean->string (localref-clear? z))) 302 | (lcons "other-clears?" (boolean->string (localref-other-clears? z))) 303 | (lcons "type" (symbol-or-f->string (localref-type z))))) 304 | 305 | (define 306 | (toplevel->spec z) 307 | (list 308 | "toplevel" 309 | (lcons "depth" (number->string (toplevel-depth z))) 310 | (lcons "pos" (number->string (toplevel-pos z))) 311 | (lcons "const?" (boolean->string (toplevel-const? z))) 312 | (lcons "ready?" (boolean->string (toplevel-ready? z))))) 313 | 314 | (define 315 | (application->spec z) 316 | (list "application" 317 | (lcons "rator" (expr-seq-any->string (application-rator z))) 318 | (lcons "rands" (list->string expr-seq-any->string (application-rands z))))) 319 | 320 | (define 321 | (branch->spec z) 322 | (list "branch" 323 | (lcons "test" (expr-seq-any->string (branch-test z))) 324 | (lcons "then" (expr-seq-any->string (branch-then z))) 325 | (lcons "else" (expr-seq-any->string (branch-else z))))) 326 | 327 | (define 328 | (with-cont-mark->spec z) 329 | (list "with-cont-mark" 330 | (lcons "key" (expr-seq-any->string (with-cont-mark-key z))) 331 | (lcons "val" (expr-seq-any->string (with-cont-mark-val z))) 332 | (lcons "body" (expr-seq-any->string (with-cont-mark-body z))))) 333 | 334 | (define 335 | (beg0->spec z) 336 | (list "beg0" 337 | (lcons "seq" (list->string expr-seq-any->string (beg0-seq z))))) 338 | 339 | (define 340 | (varref->spec z) 341 | (list "varref" 342 | (lcons "toplevel" (match (varref-toplevel z) 343 | [(? toplevel? tl) (toplevel->spec tl)] 344 | [(? boolean? tl) (boolean->string tl)] 345 | [(? symbol? tl) (symbol->string tl)])) 346 | (lcons "dummy" (match (varref-dummy z) 347 | [(? toplevel? dm) (toplevel->spec dm)] 348 | [#f "#f"])) 349 | (lcons "constant?" (boolean->string (varref-constant? z))) 350 | (lcons "from-unsafe?" (boolean->string (varref-from-unsafe? z))))) 351 | 352 | (define 353 | (assign->spec z) 354 | (list "assign" 355 | (lcons "id" (toplevel->spec (assign-id z))) 356 | (lcons "rhs" (expr-seq-any->string (assign-rhs z))) 357 | (lcons "undef-ok?" (boolean->string (assign-undef-ok? z))))) 358 | 359 | (define 360 | (apply-values->spec z) 361 | (list "apply-values" 362 | (lcons "proc" (expr-seq-any->string (apply-values-proc z))) 363 | (lcons "args-expr" (expr-seq-any->string (apply-values-args-expr z))))) 364 | 365 | (define 366 | (with-immed-mark->spec z) 367 | (list "with-immed-mark" 368 | (lcons "key" (expr-seq-any->string (with-immed-mark-key z))) 369 | (lcons "def-val" (expr-seq-any->string (with-immed-mark-def-val z))) 370 | (lcons "body" (expr-seq-any->string (with-immed-mark-body z))))) 371 | 372 | (define 373 | (primval->spec z) 374 | (list "primval" 375 | (lcons "id" (number->string (primval-id z))))) 376 | 377 | ;; --- Shapes 378 | 379 | ;; Shapes are not zo structs per se, but they are documented in the 380 | ;; decompile guide and do not seem to have a nice formatting method. 381 | 382 | (define (symbol->spec s) 383 | (symbol->string s)) 384 | 385 | (define 386 | (function-shape->spec fs) 387 | (format-list #:sep " " 388 | (list "function-shape" 389 | (format "arity : ~a" (function-shape-arity fs)) 390 | (format "preserves-marks? : ~a" (function-shape-preserves-marks? fs))))) 391 | 392 | (define struct-shape->spec 393 | (make-table 394 | #:action ->spec 395 | struct-type-shape 396 | constructor-shape 397 | predicate-shape 398 | accessor-shape 399 | mutator-shape 400 | struct-type-property-shape 401 | property-predicate-shape 402 | property-accessor-shape 403 | struct-other-shape)) 404 | 405 | (define 406 | (struct-type-shape->spec sts) 407 | (format-list #:sep " " 408 | (list "struct-type-shape" 409 | (format "field-count : ~a" (struct-type-shape-field-count sts))))) 410 | 411 | (define 412 | (constructor-shape->spec cs) 413 | (format-list #:sep " " 414 | (list "constructor-shape" 415 | (format "arity : ~a" (constructor-shape-arity cs))))) 416 | 417 | (define 418 | (predicate-shape->spec ps) 419 | (format-list (list "predicate-shape"))) 420 | 421 | (define 422 | (accessor-shape->spec sts) 423 | (format-list #:sep " " 424 | (list "accessor-shape" 425 | (format "field-count : ~a" (accessor-shape-field-count sts))))) 426 | 427 | (define 428 | (mutator-shape->spec sts) 429 | (format-list #:sep " " 430 | (list "mutator-shape" 431 | (format "field-count : ~a" (mutator-shape-field-count sts))))) 432 | 433 | (define 434 | (struct-type-property-shape->spec stps) 435 | (format-list (list "struct-type-property-shape" 436 | (format "has-guard? : ~a" (struct-type-property-shape-has-guard? stps))))) 437 | 438 | (define 439 | (property-predicate-shape->spec stps) 440 | (format-list (list "property-predicate-shape"))) 441 | 442 | (define 443 | (property-accessor-shape->spec stps) 444 | (format-list (list "property-accessor-shape"))) 445 | 446 | (define 447 | (struct-other-shape->spec ps) 448 | (format-list (list "struct-other-shape"))) 449 | 450 | ;; --- helpers 451 | 452 | ;; Turn any value into a string. 453 | (define 454 | (any->string z) 455 | (format "~a" z)) 456 | 457 | ;; Turn a boolean value into a string. 458 | (define 459 | (boolean->string b) 460 | (any->string b)) 461 | 462 | ;; Turn an 'expr' struct or a 'seq' struct or any other value into a string. 463 | (define 464 | (expr-seq-any->string z) 465 | (cond [(expr? z) (format-spec #f (expr->spec z))] 466 | [(seq? z) (format-spec #f (seq->spec z))] 467 | [else (any->string z)])) 468 | 469 | ;; Turn a 'form' struct or anything else into a string. 470 | (define 471 | (form-or-any->string fm) 472 | (cond [(form? fm) (format-spec #f (form->spec fm))] 473 | [else (any->string fm)])) 474 | 475 | ;; Alternate syntax for `string-join` -- the `sep` argument appears as a label 476 | ;; and defaults to a newline character. 477 | (define 478 | (format-list xs #:sep [sep "\n"]) 479 | (string-join xs sep)) 480 | 481 | ;; Turn a spec into a string. 482 | ;; If `deep?` is false, only format the title (ignore the field names + thunks). 483 | (define 484 | (format-spec deep? struct-spec) 485 | (define fields (cdr struct-spec)) 486 | (define title (format "" (car struct-spec))) 487 | (define field-name-lengths 488 | (for/list ([fd fields]) (string-length (car fd)))) 489 | (define w ;; width of longest struct field name 490 | (if (null? fields) 0 (apply max field-name-lengths))) 491 | (if (not deep?) 492 | title 493 | (format-list (cons title 494 | (for/list ([fd fields]) 495 | (define forced ((cdr fd))) 496 | (define rest (if (string? forced) 497 | forced 498 | (format-spec #f forced))) 499 | (format " ~a : ~a" (pad (car fd) w) rest)))))) 500 | 501 | ;; Turn a list into a string. 502 | (define 503 | (list->string f xs) 504 | (format "[~a]" 505 | (format-list #:sep " " 506 | (for/list ([x xs]) (f x))))) 507 | 508 | ;; Turn a list of things that might be 'form' structs into a list of strings. 509 | (define 510 | (listof-form-or-any->string xs) 511 | (list->string form-or-any->string xs)) 512 | 513 | ;; Turn a list of zo structs into a list of strings using the helper function 514 | ;; `z->spec`. 515 | (define 516 | (listof-zo->string z->spec zs) 517 | (cond [(null? zs) "[]"] 518 | [else (format "~a[~a]" (format-spec #f (z->spec (car zs))) (length zs))])) 519 | 520 | (define 521 | (hash->spec k->str v->str h) 522 | (format "#hash(~a)" 523 | (string-join 524 | (for/list ([(k v) (in-hash h)]) 525 | (format "(~a . ~a)" (k->str k) (v->str v))) 526 | " "))) 527 | 528 | ;; Turn a module-path-index into a string 529 | ;; TODO I think we can do better than ~a 530 | ;; http://docs.racket-lang.org/reference/Module_Names_and_Loading.html 531 | (define 532 | (module-path-index->string mpi) 533 | (any->string mpi)) 534 | 535 | ;; Turn a module path into a string 536 | ;; TODO can probably improve on ~a 537 | (define 538 | (module-path->spec mp) 539 | (any->string mp)) 540 | 541 | ;; Turn a number or #f into a string. 542 | (define 543 | (number-or-f->string nf) 544 | (if (eq? #f nf) 545 | "#f" 546 | (number->string nf))) 547 | 548 | ;; Turn a symbol or #f into a string. 549 | (define 550 | (symbol-or-f->string sf) 551 | (if (eq? #f sf) 552 | "#f" 553 | (symbol->string sf))) 554 | 555 | (define 556 | (hash->string h) 557 | (format "~a" h)) 558 | 559 | ;; Turn something that might be a 'toplevel' struct into a string. 560 | (define 561 | (toplevel-or-any->string tl) 562 | (cond [(toplevel? tl) (format-spec #f (toplevel->spec tl))] 563 | [else (any->string tl)])) 564 | 565 | (define 566 | (toplevel-or-symbol->string tl) 567 | (match tl 568 | [(? toplevel?) 569 | (format-spec #f (toplevel->spec tl))] 570 | [(? symbol?) 571 | (symbol->string tl)])) 572 | 573 | ;; --- misc 574 | 575 | ;; If `str` has fewer than `w` characters, 576 | ;; append `(w - (len str))` characters to its right end. 577 | (define 578 | (pad str w #:char [c #\space]) 579 | (define l (string-length str)) 580 | (cond [(< l w) (format "~a~a" str (make-string (- w l) c))] 581 | [else str])) 582 | 583 | ;; ----------------------------------------------------------------------------- 584 | ;; --- testing 585 | 586 | (module+ test 587 | (require rackunit compiler/zo-structs) 588 | 589 | ; Helper: force lazy tails so we can compare them. 590 | (define (force-spec sp) 591 | (cons (car sp) (for/list ([xy (cdr sp)]) (cons (car xy) 592 | (let ([tl ((cdr xy))]) 593 | (if (string? tl) 594 | tl 595 | (format-spec #f tl))))))) 596 | 597 | ;; --- API functions 598 | (test-case "zo->spec" 599 | (check-exn exn:fail? (lambda () (zo->spec (zo)))) 600 | (check-equal? (force-spec (zo->spec (branch #t #f #t))) 601 | (list "branch" 602 | (cons "test" "#t") 603 | (cons "then" "#f") 604 | (cons "else" "#t")))) 605 | 606 | (test-case "zo->string" 607 | (check-exn exn:fail? (lambda () (zo->string (zo)))) 608 | (check-equal? (zo->string (toplevel 1 1 #t #t)) "\n depth : 1\n pos : 1\n const? : #t\n ready? : #t") 609 | (check-equal? (zo->string #:deep? #t (toplevel 1 1 #t #t)) "\n depth : 1\n pos : 1\n const? : #t\n ready? : #t") 610 | (check-equal? (zo->string #:deep? #f (toplevel 1 1 #t #t)) "")) 611 | 612 | ;; --- private 613 | (test-case "linkl-directory->spec" 614 | (let* ([lb (linkl-bundle (make-hash (list (cons 'B #true))))] 615 | [z (linkl-directory (make-hash (list (cons '(A) lb))))]) 616 | (check-equal? (force-spec (linkl-directory->spec z)) 617 | '("linkl-directory" ("table" . "#hash(((A) . ))"))))) 618 | 619 | (test-case "linkl-bundle->spec" 620 | (let* ([ll (linkl 'dummy '() '() '() '() '() (make-hash) '() 0 #false)] 621 | [z0 (linkl-bundle (make-hash (list (cons 'A #true))))] 622 | [z1 (linkl-bundle (make-hash (list (cons 44 ll))))]) 623 | (check-equal? (force-spec (linkl-bundle->spec z0)) 624 | '("linkl-bundle" ("table" . "#hash((A . #t))"))) 625 | (check-equal? (force-spec (linkl-bundle->spec z1)) 626 | '("linkl-bundle" ("table" . "#hash((44 . ))"))))) 627 | 628 | (test-case "linkl-or-any->string" 629 | (check-equal? (linkl-or-any->string 44) 630 | "44")) 631 | 632 | (test-case "linkl->spec" 633 | (let* ([z (linkl 'name '((import)) '((constant) (#false)) '(exp) 634 | '(internals #f) '(lifts) (make-hash '((src . names))) 635 | '(body) 8 #t)]) 636 | (check-equal? (force-spec (linkl->spec z)) 637 | '("linkl" ("name" . "name") 638 | ("importss" . "((import))") 639 | ("import-shapess" . "[[constant] [#f]]") 640 | ("exports" . "(exp)") 641 | ("internals" . "(internals #f)") 642 | ("lifts" . "(lifts)") 643 | ("source-names" . "#hash((src . names))") 644 | ("body" . "[body]") 645 | ("max-let-depth" . "8") 646 | ("need-instance-access?" . "#t"))))) 647 | 648 | (test-case "form->spec" 649 | (let* ([z (form)]) 650 | (check-equal? (form->spec z) #f))) 651 | 652 | (test-case "expr->spec" 653 | (let* ([z (expr)]) 654 | (check-equal? (expr->spec z) #f))) 655 | 656 | (test-case "def-values->spec" 657 | (let* ([ids (list (toplevel 1 2 #t #f))] 658 | [rhs (beg0 '())] 659 | [z (def-values ids rhs)]) 660 | (check-equal? (force-spec (def-values->spec z)) 661 | (cons "def-values" 662 | (list (cons "ids" "[]") 663 | (cons "rhs" "")))))) 664 | 665 | (test-case "seq->spec" 666 | (let* ([fms (list (seq '()) (seq '()) (seq '()))] 667 | [z (seq fms)]) 668 | (check-equal? (force-spec (seq->spec z)) 669 | (cons "seq" 670 | (list (cons "forms" "[ ]")))))) 671 | 672 | 673 | (test-case "inline-variant->spec" 674 | (let* ([dr (beg0 '())] 675 | [il (beg0 '())] 676 | [z (inline-variant dr il)]) 677 | (check-equal? (force-spec (inline-variant->spec z)) 678 | (cons "inline-variant" 679 | (list (cons "direct" "") 680 | (cons "inline" "")))))) 681 | 682 | (test-case "lam->spec" 683 | (let* ([bd (beg0 '())] 684 | [z (lam 'name '() 3 '() #f '#() '() #f 1 bd)]) 685 | (check-equal? (force-spec (lam->spec z)) 686 | (cons "lam" 687 | (list (cons "name" "name") 688 | (cons "flags" "[]") 689 | (cons "num-params" "3") 690 | (cons "param-types" "[]") 691 | (cons "rest?" "#f") 692 | (cons "closure-map" "[]") 693 | (cons "closure-types" "[]") 694 | (cons "toplevel-map" "#f") 695 | (cons "max-let-depth" "1") 696 | (cons "body" "")))))) 697 | 698 | (test-case "closure->spec" 699 | (let* ([lm (lam 'nmme '() 3 '() #f '#() '() #f 1 (seq '()))] 700 | [z (closure lm 'genid)]) 701 | (check-equal? (force-spec (closure->spec z)) 702 | (cons "closure" 703 | (list (cons "code" "") 704 | (cons "gen-id" "genid")))))) 705 | 706 | (test-case "case-lam->spec" 707 | (let* ([lm (lam 'nmme '() 3 '() #f '#() '() #f 1 (seq '()))] 708 | [cl (closure lm 'id)] 709 | [cls (list lm cl lm)] 710 | [z (case-lam 'name cls)]) 711 | (check-equal? (force-spec (case-lam->spec z)) 712 | (cons "case-lam" 713 | (list (cons "name" "name") 714 | (cons "clauses" "[ ]")))))) 715 | 716 | (test-case "let-one->spec" 717 | (let* ([rhs (beg0 '())] 718 | [bdy (beg0 '())] 719 | [z (let-one rhs bdy #f #f)]) 720 | (check-equal? (force-spec (let-one->spec z)) 721 | (cons "let-one" 722 | (list (cons "rhs" "") 723 | (cons "body" "") 724 | (cons "type" "#f") 725 | (cons "unused?" "#f")))))) 726 | 727 | (test-case "let-void->spec" 728 | (let* ([bdy (beg0 '())] 729 | [z (let-void 1 #f bdy)]) 730 | (check-equal? (force-spec (let-void->spec z)) 731 | (cons "let-void" 732 | (list (cons "count" "1") 733 | (cons "boxes" "#f") 734 | (cons "body" "")))))) 735 | 736 | (test-case "install-value->spec" 737 | (let* ([rhs (branch #t #t #t)] 738 | [bdy (beg0 '())] 739 | [z (install-value 2 3 #f rhs bdy)]) 740 | (check-equal? (force-spec (install-value->spec z)) 741 | (cons "install-value" 742 | (list (cons "count" "2") 743 | (cons "pos" "3") 744 | (cons "boxes?" "#f") 745 | (cons "rhs" "") 746 | (cons "body" "")))))) 747 | 748 | (test-case "let-rec->spec" 749 | (let* ([lm (lam 'nmme '() 3 '() #f '#() '() #f 1 (seq '()))] 750 | [pcs (list lm lm)] 751 | [bdy (beg0 '())] 752 | [z (let-rec pcs bdy)]) 753 | (check-equal? (force-spec (let-rec->spec z)) 754 | (cons "let-rec" 755 | (list (cons "procs" "[2]") 756 | (cons "body" "")))))) 757 | 758 | (test-case "boxenv->spec" 759 | (let* ([bdy (beg0 '())] 760 | [z (boxenv 2 bdy)]) 761 | (check-equal? (force-spec (boxenv->spec z)) 762 | (cons "boxenv" 763 | (list (cons "pos" "2") 764 | (cons "body" "")))))) 765 | 766 | (test-case "localref->spec" 767 | (let ([z (localref #t 1 #t #t #f)]) 768 | (check-equal? (force-spec (localref->spec z)) 769 | (cons "localref" 770 | (list (cons "unbox?" "#t") 771 | (cons "pos" "1") 772 | (cons "clear?" "#t") 773 | (cons "other-clears?" "#t") 774 | (cons "type" "#f")))))) 775 | 776 | (test-case "toplevel->spec" 777 | (let ([z (toplevel 1 2 #f #f)]) 778 | (check-equal? (force-spec (toplevel->spec z)) 779 | (cons "toplevel" 780 | (list (cons "depth" "1") 781 | (cons "pos" "2") 782 | (cons "const?" "#f") 783 | (cons "ready?" "#f")))))) 784 | 785 | (test-case "application->spec" 786 | (let* ([e (beg0 '())] 787 | [s (seq '())] 788 | [z (application s (list e s s '() 'any 54 e))]) 789 | (check-equal? (force-spec (application->spec z)) 790 | (cons "application" 791 | (list (cons "rator" "") 792 | (cons "rands" "[ () any 54 ]")))))) 793 | 794 | (test-case "branch->spec" 795 | (let* ([z (branch #t (beg0 '()) #f)]) 796 | (check-equal? (force-spec (branch->spec z)) 797 | (cons "branch" 798 | (list (cons "test" "#t") 799 | (cons "then" "") 800 | (cons "else" "#f")))))) 801 | 802 | (test-case "beg0->spec" 803 | (let ([z (beg0 (list (beg0 '()) 'asdf (beg0 (list (expr)))))]) 804 | (check-equal? (force-spec (beg0->spec z)) 805 | (cons "beg0" 806 | (list (cons "seq" "[ asdf ]")))))) 807 | 808 | (test-case "varref->spec" 809 | (let* ([tl (toplevel 1 1 #f #f)] 810 | [z (varref tl #f #f #f)] 811 | [z1 (varref #f #f #f #f)] 812 | [z2 (varref 'hi #f #f #f)]) 813 | (check-equal? (force-spec (varref->spec z)) 814 | (cons "varref" 815 | (list (cons "toplevel" "") 816 | (cons "dummy" "#f") 817 | (cons "constant?" "#f") 818 | (cons "from-unsafe?" "#f")))) 819 | (check-equal? (force-spec (varref->spec z1)) 820 | (cons "varref" 821 | (list (cons "toplevel" "#f") 822 | (cons "dummy" "#f") 823 | (cons "constant?" "#f") 824 | (cons "from-unsafe?" "#f")))) 825 | (check-equal? (force-spec (varref->spec z2)) 826 | (cons "varref" 827 | (list (cons "toplevel" "hi") 828 | (cons "dummy" "#f") 829 | (cons "constant?" "#f") 830 | (cons "from-unsafe?" "#f")))))) 831 | 832 | (test-case "assign->spec" 833 | (let* ([id (toplevel 1 1 #f #f)] 834 | [rhs (beg0 '())] 835 | [z (assign id rhs #t)]) 836 | (check-equal? (force-spec (assign->spec z)) 837 | (cons "assign" 838 | (list (cons "id" "") 839 | (cons "rhs" "") 840 | (cons "undef-ok?" "#t")))))) 841 | 842 | (test-case "apply-values->spec" 843 | (let ([z (apply-values (beg0 '()) (beg0 '(1 2 8)))]) 844 | (check-equal? (force-spec (apply-values->spec z)) 845 | (cons "apply-values" 846 | (list (cons "proc" "") 847 | (cons "args-expr" "")))))) 848 | 849 | (test-case "with-immed-mark->spec" 850 | (let ([z (with-immed-mark (beg0 '()) (beg0 '()) (beg0 '(1 2 8)))]) 851 | (check-equal? (force-spec (with-immed-mark->spec z)) 852 | (cons "with-immed-mark" 853 | (list (cons "key" "") 854 | (cons "def-val" "") 855 | (cons "body" "")))))) 856 | 857 | (test-case "primval->spec" 858 | (let ([z (primval 420)]) 859 | (check-equal? (force-spec (primval->spec z)) 860 | (cons "primval" 861 | (list (cons "id" "420")))))) 862 | 863 | ;; --- helpers 864 | (test-case "any->string" 865 | (check-equal? (any->string 'any) "any") 866 | (check-equal? (any->string "any") "any") 867 | (check-equal? (any->string #t) "#t") 868 | (check-equal? (any->string (vector 1 2 3)) "#(1 2 3)")) 869 | 870 | (test-case "boolean->string" 871 | (check-equal? (boolean->string #t) "#t") 872 | (check-equal? (boolean->string #f) "#f")) 873 | 874 | (test-case "expr-seq-any->string" 875 | (check-equal? (expr-seq-any->string (beg0 '())) "") 876 | (check-equal? (expr-seq-any->string (branch #t (expr) (expr))) "") 877 | (check-equal? (expr-seq-any->string (seq '(blah))) "") 878 | (check-equal? (expr-seq-any->string 420) "420") 879 | (check-equal? (expr-seq-any->string +) "#")) 880 | 881 | (test-case "form-or-any->string" 882 | (check-equal? (form-or-any->string (def-values '() (expr))) "") 883 | (check-equal? (form-or-any->string (lam 'name '() 3 '() #f '#() '() #f 1 (expr))) "") 884 | (check-equal? (form-or-any->string (zo)) "#s(zo)") 885 | (check-equal? (form-or-any->string "()") "()") 886 | (check-equal? (form-or-any->string #\H) "H")) 887 | 888 | (test-case "format-list" 889 | ; (this is just string-join) 890 | (check-equal? (format-list '()) "") 891 | (check-equal? (format-list (list "a" "bear" "man")) "a\nbear\nman") 892 | (check-equal? (format-list #:sep "---" (list "racket" "eering")) "racket---eering")) 893 | 894 | (test-case "format-spec" 895 | ; No fields 896 | (check-equal? (format-spec #f (cons "hello" '())) "") 897 | (check-equal? (format-spec #t (cons "hello" '())) "") 898 | ; String fields 899 | (check-equal? (format-spec #f (cons "str" (list (cons "hello" (lambda () "there"))))) "") 900 | (check-equal? (format-spec #t (cons "str" (list (cons "hello" (lambda () "there"))))) "\n hello : there") 901 | ; Nested struct fields 902 | (check-equal? (format-spec #f (cons "pika" (list (cons "f1" (lambda () "val1")) 903 | (cons "f2" (lambda () (list "nested" (cons "n1" (lambda () "wepa")))))))) "") 904 | (check-equal? (format-spec #t (cons "pika" (list (cons "f1" (lambda () "val1")) 905 | (cons "f2" (lambda () (list "nested" (cons "n1" (lambda () "wepa")))))))) "\n f1 : val1\n f2 : ") 906 | ; Padding 907 | (check-equal? (format-spec #t (cons "pika" (list (cons "long-name" (lambda () "v1")) 908 | (cons "name" (lambda () "v2"))))) "\n long-name : v1\n name : v2")) 909 | 910 | (test-case "list->string" 911 | (check-equal? (list->string (lambda (x) "blah") '()) "[]") 912 | (check-equal? (list->string number->string (list 1 2 3 4)) "[1 2 3 4]") 913 | (check-equal? (list->string (lambda (x) (format-spec #f (expr->spec x))) (list (branch #t #t #t))) "[]")) 914 | 915 | (test-case "listof-form-or-any->string" 916 | (check-equal? (listof-form-or-any->string (list (seq '()) 'cat 53)) "[ cat 53]")) 917 | 918 | (test-case "listof-zo->string" 919 | (check-equal? (listof-zo->string toplevel->spec (list (toplevel 1 1 #f #f))) "[1]")) 920 | 921 | (test-case "module-path-index->string" 922 | (check-equal? (module-path-index->string (module-path-index-join #f #f)) "#")) 923 | 924 | (test-case "module-path->spec" 925 | (check-equal? (module-path->spec 'lalala) "lalala")) 926 | 927 | (test-case "number-or-f->string" 928 | (check-equal? (number-or-f->string #f) "#f") 929 | (check-equal? (number-or-f->string 0) "0") 930 | (check-equal? (number-or-f->string -1) "-1") 931 | (check-equal? (number-or-f->string 98) "98")) 932 | 933 | (test-case "symbol-or-f->string" 934 | (check-equal? (symbol-or-f->string #f) "#f") 935 | (check-equal? (symbol-or-f->string '#f) "#f") 936 | (check-equal? (symbol-or-f->string 'foobar) "foobar") 937 | (check-equal? (symbol-or-f->string 'wunderbar) "wunderbar")) 938 | 939 | (test-case "toplevel-or-any->string" 940 | (check-equal? (toplevel-or-any->string (toplevel 19 462 #t #t)) "") 941 | (check-equal? (toplevel-or-any->string (toplevel 0 0 #f #f)) "") 942 | ; Only toplevel zo structs get pretty-printed 943 | (check-equal? (toplevel-or-any->string (branch #t #t (beg0 '()))) "#s((branch expr 0 form 0 zo 0) #t #t #s((beg0 expr 0 form 0 zo 0) ()))") 944 | (check-equal? (toplevel-or-any->string "help") "help")) 945 | 946 | (test-case "pad" 947 | (check-equal? (pad "str" 3) "str") 948 | (check-equal? (pad "str" 4) "str ") 949 | (check-equal? (pad "str" 5 #:char #\X) "strXX")) 950 | ) 951 | -------------------------------------------------------------------------------- /private/zo-syntax.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Utilities for decompiling syntax fragments, rather than whole .zo files 4 | 5 | ;; This code brought to you by Leif Andersen. 6 | ;; https://github.com/LeifAndersen/racket-compiler-goodies 7 | 8 | (provide 9 | 10 | compiled-expression->zo 11 | ;; (-> Compiled-Expression compilation-top) 12 | ;; Turn a compiled expression into a zo struct 13 | 14 | syntax->zo 15 | ;; (-> Syntax zo) 16 | ;; Parse a syntax object as a zo struct 17 | 18 | syntax->decompile 19 | ;; (-> Syntax Any) 20 | ;; Decompile a syntax object into an S-expression 21 | 22 | toplevel-syntax->zo 23 | ;; (-> Syntax (Listof zo)) 24 | ;; Convert a toplevel expression into a list of zo compilations 25 | 26 | zo->compiled-expression 27 | ;; (-> compilation-top Compiled-Expression) 28 | ;; Parse a zo struct (output of zo-parse) as an S-expression 29 | ) 30 | 31 | ;; ----------------------------------------------------------------------------- 32 | 33 | (require 34 | compiler/zo-parse 35 | compiler/zo-marshal 36 | compiler/decompile 37 | syntax/toplevel 38 | syntax/strip-context 39 | (only-in racket/port with-input-from-bytes port->bytes) 40 | (only-in racket/linklet linklet?) 41 | ) 42 | 43 | ;; ============================================================================= 44 | 45 | (define (compiled-expression->zo compiled) 46 | (define-values (in out) (make-pipe)) 47 | (display compiled out) 48 | (close-output-port out) 49 | (define y (port->bytes in)) 50 | (close-input-port in) 51 | (zo-parse (open-input-bytes y))) 52 | 53 | (define (syntax->zo stx) 54 | (compiled-expression->zo (compile-syntax (expand-syntax-top-level-with-compile-time-evals stx)))) 55 | 56 | (define (toplevel-syntax->zo stx) 57 | (parameterize ([current-namespace (make-base-namespace)]) 58 | (namespace-require 'racket/undefined) 59 | (namespace-require 'racket) 60 | (map compiled-expression->zo 61 | (eval-compile-time-part-of-top-level/compile 62 | (expand-syntax-top-level-with-compile-time-evals 63 | (namespace-syntax-introduce (strip-context stx))))))) 64 | 65 | (define (syntax->decompile stx) 66 | (decompile (syntax->zo stx))) 67 | 68 | (define (zo->compiled-expression zo) 69 | ;; read-accept-compiled tells the default reader to accept 70 | ;; compiled code (flagged with #~) 71 | (parameterize ([read-accept-compiled #t]) 72 | (define x (zo-marshal zo)) 73 | (with-input-from-bytes (zo-marshal zo) 74 | read))) 75 | 76 | ;; ============================================================================= 77 | 78 | (module+ test 79 | (require rackunit compiler/compile-file racket/runtime-path 80 | (only-in racket/port with-input-from-string) 81 | (only-in racket/extflonum extflonum-available?) 82 | (only-in syntax/modread with-module-reading-parameterization)) 83 | 84 | (define-runtime-path test-rkt "test/file.rkt") 85 | (define-runtime-path test-zo "test/file.zo") 86 | (define racketcs? (eq? 'chez-scheme (system-type 'vm))) 87 | 88 | (define (machine-code-sexp? x) 89 | (and (pair? x) 90 | (eq? (car x) '#%machine-code))) 91 | 92 | (define (linkl-directory->code z) 93 | (linkl-body 94 | (hash-ref 95 | (linkl-bundle-table 96 | (hash-ref 97 | (linkl-directory-table z) '())) 0))) 98 | 99 | (test-case "-- compiled-expression->zo" 100 | (unless racketcs? 101 | (let* ([e (compile-syntax #'(box 3))] 102 | [z (compiled-expression->zo e)]) 103 | (check-pred linkl-directory? z) 104 | (check-pred application? (car (linkl-directory->code z)))))) 105 | 106 | (test-case "-- syntax->zo" 107 | (unless racketcs? 108 | (let* ([stx #'(+ 1 3)] 109 | [z (syntax->zo stx)]) 110 | (check-pred linkl-directory? z) 111 | (check-equal? 4 (car (linkl-directory->code z)))))) 112 | 113 | (test-case "syntax->zo 2" 114 | (unless racketcs? 115 | (let* ([stx #'(let ([a (box 'a)]) 116 | (if (unbox a) (set-box! a 'b) (set-box! a 'c)) (unbox a))] 117 | [z (syntax->zo stx)]) 118 | (check-pred linkl-directory? z) 119 | (define l (car (linkl-directory->code z))) 120 | (check-true (let-one? l)) 121 | ;; --- rhs 122 | (define rhs (let-one-rhs l)) 123 | (check-true (application? rhs)) 124 | (define rator (application-rator rhs)) 125 | (check-true (primval? rator)) 126 | (check-pred integer? (primval-id rator)) 127 | (check-equal? (application-rands rhs) '(a)) 128 | ;; --- body 129 | (define body (let-one-body l)) 130 | (check-true (seq? body)) 131 | (check-true (branch? (car (seq-forms body)))) 132 | (check-true (application? (cadr (seq-forms body))))))) 133 | 134 | (test-case "-- syntax->decompile" 135 | (let* ([stx #'(string-append "hello" "world")] 136 | [d (syntax->decompile stx)]) 137 | (if racketcs? 138 | (check-pred machine-code-sexp? d) 139 | (begin 140 | (check-eq? (car d) 'string-append) 141 | (check-equal? (car (cdr (car (cdr d)))) "hello")))) 142 | 143 | (let* ([stx #'(displayln "hello world")] 144 | [d (syntax->decompile stx)]) 145 | (if racketcs? 146 | (check-pred machine-code-sexp? d) 147 | (check-equal? (car (cdr d)) '(quote "hello world"))))) 148 | 149 | #;(test-case "-- zo->compiled-expression" 150 | (let* (;[expr '(+ 600 60 6)] 151 | [_ (with-output-to-file test-rkt #:exists 'replace 152 | (lambda () (displayln "#lang racket/base") (displayln expr)))] 153 | [_ (parameterize ([current-namespace (make-base-namespace)]) 154 | (with-module-reading-parameterization (lambda () (compile-file test-rkt test-zo))))] 155 | [z (with-input-from-file test-zo zo-parse)] 156 | [c (zo->compiled-expression z)]) 157 | (check-equal? (eval c (make-base-namespace)) 666)) 158 | 159 | (let* ([p (prefix 9 '() '() 'wepa)] 160 | [box-id (primval-id (compilation-top-code (syntax->zo #'box)))] 161 | [z (compilation-top 0 (hash) p (primval box-id))] 162 | [c (zo->compiled-expression z)]) 163 | (check-equal? (eval c) box))) 164 | ) 165 | -------------------------------------------------------------------------------- /private/zo-transition.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Access the fields of a struct by name at runtime. 4 | 5 | ;; Uses predicates to guess what struct its argument is, 6 | ;; then compares strings with statically-known field names. 7 | ;; Functions that end with '->' are the specific transition function 8 | ;; for a type of zo struct. 9 | 10 | (provide 11 | zo-transition 12 | ;; (-> zo? string? (values (or/c zo? (listof zo?)) boolean?)) 13 | ;; Access "structName-fieldName myStruct" at runtime. 14 | ) 15 | 16 | ;; ----------------------------------------------------------------------------- 17 | 18 | (require 19 | compiler/zo-structs 20 | ;zordoz/typed/zo-structs ;; For testing 21 | racket/match 22 | (only-in zordoz/private/dispatch-table make-table) 23 | ) 24 | 25 | ;; ============================================================================= 26 | 27 | ;; --- API functions 28 | 29 | ;; Look up the field name `field-name` in the struct `z`. 30 | ;; First use predicates to decide what type of struct `z` is, 31 | ;; then use string equality to check if `field-name` matches any 32 | ;; statically-known name. 33 | ;; Return two values. 34 | ;; - First is a zo struct or list of zo structs, depending on the 35 | ;; value stored in the field denoted by `field-name` 36 | ;; - Second is a boolean indicating success or failure. 37 | ;; On failure, the returned zo struct is `z`. 38 | (define (zo-transition z field-name) 39 | ;; (-> zo? string? (values (or/c zo? (listof zo?)) boolean?)) 40 | ;; Check if transition failed or returned a list without any zo, pack result values. 41 | (match (try-transition z field-name) 42 | [(? zo? nxt) 43 | (values nxt #t)] 44 | [(? list? nxt) 45 | (match (filter zo? nxt) 46 | ['() (values z #f)] 47 | [zs (values zs #t)])] 48 | [(? hash? nxt) 49 | (define zh 50 | (for/hash (((k v) (in-hash nxt)) 51 | #:when (zo? v)) 52 | (values k v))) 53 | (if (hash-empty? zh) 54 | (values z #false) 55 | (values zh #true))] 56 | [_ 57 | (values z #f)])) 58 | 59 | ;; --- dispatch 60 | 61 | (define try-transition 62 | (make-table 63 | #:action -> 64 | linkl-directory 65 | linkl-bundle 66 | linkl 67 | form 68 | inline-variant 69 | expr)) 70 | 71 | (define form-> 72 | (make-table 73 | #:action -> 74 | def-values 75 | seq 76 | expr)) 77 | 78 | (define expr-> 79 | (make-table 80 | #:action -> 81 | lam 82 | closure 83 | case-lam 84 | let-one 85 | let-void 86 | install-value 87 | let-rec 88 | boxenv 89 | localref 90 | toplevel 91 | application 92 | branch 93 | with-cont-mark 94 | seq 95 | beg0 96 | varref 97 | assign 98 | apply-values 99 | with-immed-mark 100 | primval)) 101 | 102 | ;; --- getters 103 | 104 | (define (linkl-directory-> ld field-name) 105 | (match field-name 106 | ["table" 107 | (linkl-directory-table ld)] 108 | [_ #f])) 109 | 110 | (define (linkl-bundle-> lb field-name) 111 | (match field-name 112 | ["table" 113 | (linkl-bundle-table lb)] 114 | [_ #f])) 115 | 116 | (define (linkl-> ll field-name) 117 | (match field-name 118 | ["body" 119 | (linkl-body ll)] 120 | [_ #f])) 121 | 122 | ;; --- form 123 | 124 | (define (def-values-> z field-name) 125 | ;; (-> def-values? string? (or/c (listof zo?) zo? #f)) 126 | (match field-name 127 | ["ids" 128 | (def-values-ids z)] 129 | ["rhs" 130 | (match (def-values-rhs z) 131 | [(or (? expr? rhs) (? seq? rhs) (? inline-variant? rhs)) 132 | rhs] 133 | [_ #f])] 134 | [_ #f])) 135 | 136 | (define (seq-> z field-name) 137 | ;; (-> seq? string? (or/c (listof zo?) zo? #f)) 138 | (match field-name 139 | ["forms" 140 | (filter expr? (seq-forms z))] 141 | [_ #f])) 142 | 143 | (define (inline-variant-> z field-name) 144 | ;; (-> inline-variant? string? (or/c (listof zo?) zo? #f)) 145 | (match field-name 146 | ["direct" 147 | (inline-variant-direct z)] 148 | ["inline" 149 | (inline-variant-inline z)] 150 | [_ #f])) 151 | 152 | ;; --- expr 153 | 154 | (define (lam-> z field-name) 155 | ;; (-> lam? string? (or/c (listof zo?) zo? #f)) 156 | (match field-name 157 | ["body" 158 | (match (lam-body z) 159 | [(? expr-or-seq? bd) bd] 160 | [_ #f])] 161 | [_ #f])) 162 | 163 | (define (closure-> z field-name) 164 | ;; (-> closure? string? (or/c (listof zo?) zo? #f)) 165 | (match field-name 166 | ["code" 167 | (closure-code z)] 168 | [_ #f])) 169 | 170 | (define (case-lam-> z field-name) 171 | ;; (-> case-lam? string? (or/c (listof zo?) zo? #f)) 172 | (match field-name 173 | ["clauses" 174 | (case-lam-clauses z)] 175 | [_ #f])) 176 | 177 | (define (let-one-> z field-name) 178 | ;; (-> let-one? string? (or/c (listof zo?) zo? #f)) 179 | (match field-name 180 | ["rhs" 181 | (match (let-one-rhs z) 182 | [(? expr-or-seq? rhs) rhs] 183 | [_ #f])] 184 | ["body" 185 | (match (let-one-body z) 186 | [(? expr-or-seq? body) body] 187 | [_ #f])] 188 | [_ #f])) 189 | 190 | (define (let-void-> z field-name) 191 | ;; (-> let-void? string? (or/c (listof zo?) zo? #f)) 192 | (match field-name 193 | ["body" 194 | (match (let-void-body z) 195 | [(? expr-or-seq? body) body] 196 | [_ #f])] 197 | [_ #f])) 198 | 199 | (define (install-value-> z field-name) 200 | ;; (-> install-value? string? (or/c (listof zo?) zo? #f)) 201 | (match field-name 202 | ["rhs" 203 | (match (install-value-rhs z) 204 | [(? expr-or-seq? rhs) rhs] 205 | [_ #f])] 206 | ["body" 207 | (match (install-value-body z) 208 | [(? expr-or-seq? body) body] 209 | [_ #f])] 210 | [_ #f])) 211 | 212 | (define (let-rec-> z field-name) 213 | ;; (-> let-rec? string? (or/c (listof zo?) zo? #f)) 214 | (match field-name 215 | ["procs" 216 | (let-rec-procs z)] 217 | ["body" 218 | (match (let-rec-body z) 219 | [(? expr-or-seq? body) body] 220 | [_ #f])] 221 | [_ #f])) 222 | 223 | (define (boxenv-> z field-name) 224 | ;; (-> boxenv? string? (or/c (listof zo?) zo? #f)) 225 | (match field-name 226 | ["body" 227 | (match (boxenv-body z) 228 | [(? expr-or-seq? body) body] 229 | [_ #f])] 230 | [_ #f])) 231 | 232 | (define (localref-> z field-name) 233 | ;; (-> localref? string? (or/c (listof zo?) zo? #f)) 234 | #f) 235 | 236 | (define (toplevel-> z field-name) 237 | ;; (-> toplevel? string? (or/c (listof zo?) zo? #f)) 238 | #f) 239 | 240 | (define (application-> z field-name) 241 | ;; (-> application? string? (or/c (listof zo?) zo? #f)) 242 | (match field-name 243 | ["rator" 244 | (match (application-rator z) 245 | [(? expr-or-seq? rator) rator] 246 | [_ #f])] 247 | ["rands" 248 | (filter expr-or-seq? (application-rands z))] 249 | [_ #f])) 250 | 251 | (define (branch-> z field-name) 252 | ;; (-> branch? string? (or/c (listof zo?) zo? #f)) 253 | (match field-name 254 | ["test" 255 | (match (branch-test z) 256 | [(? expr-or-seq? test) test] 257 | [_ #f])] 258 | ["then" 259 | (match (branch-then z) 260 | [(? expr-or-seq? then) then] 261 | [_ #f])] 262 | ["else" 263 | (match (branch-else z) 264 | [(? expr-or-seq? el) el] 265 | [_ #f])] 266 | [_ #f])) 267 | 268 | (define (with-cont-mark-> z field-name) 269 | ;; (-> with-cont-mark? string? (or/c (listof zo?) zo? #f)) 270 | (match field-name 271 | ["key" 272 | (match (with-cont-mark-key z) 273 | [(? expr-or-seq? key) key] 274 | [_ #f])] 275 | ["val" 276 | (match (with-cont-mark-val z) 277 | [(? expr-or-seq? val) val] 278 | [_ #f])] 279 | ["body" 280 | (match (with-cont-mark-body z) 281 | [(? expr-or-seq? body) body] 282 | [_ #f])] 283 | [_ #f])) 284 | 285 | (define (beg0-> z field-name) 286 | ;; (-> beg0? string? (or/c (listof zo?) zo? #f)) 287 | (match field-name 288 | ["seq" (filter expr-or-seq? (beg0-seq z))] 289 | [_ #f])) 290 | 291 | (define (varref-> z field-name) 292 | ;; (-> varref? string? (or/c (listof zo?) zo? #f)) 293 | (match field-name 294 | ["toplevel" 295 | (match (varref-toplevel z) 296 | [(? toplevel? tl) tl] 297 | [_ #f])] 298 | ["dummy" 299 | (match (varref-dummy z) 300 | [(? toplevel? dm) dm] 301 | [_ #f])] 302 | [_ #f])) 303 | 304 | (define (assign-> z field-name) 305 | ;; (-> assign? string? (or/c (listof zo?) zo? #f)) 306 | (match field-name 307 | ["id" (assign-id z)] 308 | ["rhs" (match (assign-rhs z) 309 | [(? expr-or-seq? rhs) rhs] 310 | [_ #f])] 311 | [_ #f])) 312 | 313 | (define (apply-values-> z field-name) 314 | ;; (-> apply-values? string? (or/c (listof zo?) zo? #f)) 315 | (match field-name 316 | ["proc" 317 | (match (apply-values-proc z) 318 | [(? expr-or-seq? proc) proc] 319 | [_ #f])] 320 | ["args-expr" 321 | (match (apply-values-args-expr z) 322 | [(? expr-or-seq? args-expr) args-expr] 323 | [_ #f])] 324 | [_ #f])) 325 | 326 | (define (with-immed-mark-> z field-name) 327 | (match field-name 328 | ["key" 329 | (match (with-immed-mark-key z) 330 | [(? expr-or-seq? proc) proc] 331 | [_ #f])] 332 | ["def-val" 333 | (match (with-immed-mark-def-val z) 334 | [(? expr-or-seq? args-expr) args-expr] 335 | [_ #f])] 336 | ["body" 337 | (match (with-immed-mark-body z) 338 | [(? expr-or-seq? proc) proc] 339 | [_ #f])] 340 | [_ #f])) 341 | 342 | (define (primval-> z field-name) 343 | ;; (-> primval? string? (or/c (listof zo?) zo? #f)) 344 | #f) 345 | 346 | ;; --- helpers 347 | 348 | ;; True if the argument is an 'expr' or a 'seq' zo struct. 349 | (define (expr-or-seq? x) 350 | ;; (-> any/c boolean?) 351 | (or (expr? x) (seq? x))) 352 | 353 | ;; ----------------------------------------------------------------------------- 354 | ;; --- testing 355 | 356 | (module+ test 357 | (require rackunit compiler/zo-structs) 358 | 359 | (test-case "linkl-directory->" 360 | (let* ([lb (linkl-bundle (make-hash (list (cons 'B #true))))] 361 | [t (make-hash (list (cons '(A) lb)))] 362 | [z (linkl-directory t)]) 363 | (check-equal? (linkl-directory-> z "table") t) 364 | (check-equal? (linkl-directory-> z "") #f))) 365 | 366 | (test-case "linkl-bundle->" 367 | (let* ([ll (linkl 'dummy '() '() '() '() '() (make-hash) '() 0 #false)] 368 | [t (make-hash (list (cons 'A #true) (cons 44 ll)))] 369 | [z (linkl-bundle t)]) 370 | (check-equal? (linkl-bundle-> z "table") t) 371 | (check-equal? (linkl-bundle-> z "") #false))) 372 | 373 | (test-case "linkl->" 374 | (let* ([z (linkl 'name '((import)) '((constant) (#false)) '(exp) 375 | '(internals #f) '(lifts) (make-hash '((src . names))) 376 | '(body) 8 #t)]) 377 | (check-equal? (linkl-> z "name") #false) 378 | (check-equal? (linkl-> z "importss") #false) 379 | (check-equal? (linkl-> z "import-shapess") #false) 380 | (check-equal? (linkl-> z "import-shapess") #false) 381 | (check-equal? (linkl-> z "exports") #false) 382 | (check-equal? (linkl-> z "internals") #false) 383 | (check-equal? (linkl-> z "lifts") #false) 384 | (check-equal? (linkl-> z "source-names") #false) 385 | (check-equal? (linkl-> z "body") '(body)) 386 | (check-equal? (linkl-> z "max-let-depth") #false) 387 | (check-equal? (linkl-> z "need-instance-access?") #false))) 388 | 389 | (test-case "form->" 390 | ;; (this is better tested by the specific tests for 'def-values->', 'req->', ...) 391 | (let* ([z (form)]) 392 | (check-equal? (form-> z "") #f))) 393 | 394 | (test-case "expr-> (see tests for specific expressions below)" 395 | (let* ([z (expr)]) 396 | (check-equal? (expr-> z "") #f))) 397 | 398 | (test-case "def-values->" 399 | (let* ([ids (list (toplevel 1 2 #t #f))] 400 | [rhs (expr)] 401 | [z (def-values ids rhs)]) 402 | (begin (check-equal? (def-values-> z "ids") ids) 403 | (check-equal? (def-values-> z "rhs") rhs) 404 | (check-equal? (def-values-> z "") #f)))) 405 | 406 | (test-case "seq->" 407 | (let* ([fms (list (expr) (expr) (expr))] 408 | [z (seq fms)] 409 | [z* (seq '(N O T F O R M S))]) 410 | (check-equal? (seq-> z "forms") fms) 411 | (check-equal? (seq-> z "") #f) 412 | (check-equal? (seq-> z* "forms") '()) 413 | (let-values ([(ctx* pass?) (zo-transition z* "forms")]) 414 | (begin (check-equal? ctx* z*) 415 | (check-false pass?)))) 416 | (let* ([tgt (inline-variant (branch #f #f #f) (branch #f #f #f))] 417 | [sq (seq (list tgt))] 418 | [z (with-cont-mark (let-one (boxenv 7 #f) (localref #t 1 #t #t #f) #f #t) 419 | sq 420 | #f)]) 421 | (check-equal? (seq-> sq "forms") '()))) 422 | 423 | (test-case "inline-variant->" 424 | (let* ([dr (expr)] 425 | [il (expr)] 426 | [z (inline-variant dr il)]) 427 | (begin (check-equal? (inline-variant-> z "direct") dr) 428 | (check-equal? (inline-variant-> z "inline") il) 429 | (check-equal? (inline-variant-> z "") #f))) 430 | (let* ([tgt (lam 'name '() 0 '() #f '#() '() #f 0 #f)] 431 | [other (let-rec '() #f)] 432 | [z (inline-variant tgt other)]) 433 | (check-equal? (inline-variant-> z "direct") tgt) 434 | (check-equal? (inline-variant-> z "inline") other))) 435 | 436 | (test-case "lam->" 437 | (let* ([bd (expr)] 438 | [z (lam 'name '() 3 '() #f '#() '() #f 1 bd)]) 439 | (begin (check-equal? (lam-> z "body") bd) 440 | (check-equal? (lam-> z "name") #f) 441 | (check-equal? (lam-> z "flags") #f) 442 | (check-equal? (lam-> z "num-params") #f) 443 | (check-equal? (lam-> z "param-types") #f) 444 | (check-equal? (lam-> z "rest?") #f) 445 | (check-equal? (lam-> z "closure-map") #f) 446 | (check-equal? (lam-> z "closure-types") #f) 447 | (check-equal? (lam-> z "toplevel-map") #f) 448 | (check-equal? (lam-> z "max-let-depth") #f) 449 | (check-equal? (lam-> z "") #f)))) 450 | 451 | (test-case "closure->" 452 | (let* ([lm (lam 'nmme '() 3 '() #f '#() '() #f 1 (seq '()))] 453 | [z (closure lm 'genid)]) 454 | (begin (check-equal? (closure-> z "code") lm) 455 | (check-equal? (closure-> z "gen-id") #f) 456 | (check-equal? (closure-> z "") #f)))) 457 | 458 | (test-case "case-lam->" 459 | (let* ([lm (lam 'nmme '() 3 '() #f '#() '() #f 1 (seq '()))] 460 | [cl (closure lm 'id)] 461 | [cls (list lm cl lm)] 462 | [z (case-lam 'name cls)]) 463 | (begin (check-equal? (case-lam-> z "clauses") cls) 464 | (check-equal? (case-lam-> z "name") #f) 465 | (check-equal? (case-lam-> z "") #f)))) 466 | 467 | (test-case "let-one->" 468 | (let* ([rhs (expr)] 469 | [bdy (expr)] 470 | [z (let-one rhs bdy #f #f)] 471 | ;; Testing any/c rhs and body 472 | [z* (let-one #f #f #f #f)]) 473 | (begin (check-equal? (let-one-> z "rhs") rhs) 474 | (check-equal? (let-one-> z "body") bdy) 475 | (check-equal? (let-one-> z "type") #f) 476 | (check-equal? (let-one-> z "unused?") #f) 477 | (check-equal? (let-one-> z "") #f) 478 | (check-equal? (let-one-> z* "rhs") #f) 479 | (check-equal? (let-one-> z* "body") #f)))) 480 | 481 | (test-case "let-void->" 482 | (let* ([bdy (expr)] 483 | [z (let-void 1 #f bdy)] 484 | [z* (let-void 1 #f #f)]) 485 | (begin (check-equal? (let-void-> z "body") bdy) 486 | (check-equal? (let-void-> z "count") #f) 487 | (check-equal? (let-void-> z "boxes") #f) 488 | (check-equal? (let-void-> z "") #f) 489 | (check-equal? (let-void-> z* "body") #f)))) 490 | 491 | (test-case "install-value->" 492 | (let* ([rhs (expr)] 493 | [bdy (expr)] 494 | [z (install-value 2 3 #f rhs bdy)] 495 | [z* (install-value 0 0 #f #f #f)]) 496 | (begin (check-equal? (install-value-> z "rhs") rhs) 497 | (check-equal? (install-value-> z "body") bdy) 498 | (check-equal? (install-value-> z "count") #f) 499 | (check-equal? (install-value-> z "pos") #f) 500 | (check-equal? (install-value-> z "boxes?") #f) 501 | (check-equal? (install-value-> z "") #f) 502 | (check-equal? (install-value-> z* "rhs") #f) 503 | (check-equal? (install-value-> z* "body") #f)))) 504 | 505 | (test-case "let-rec->" 506 | (let* ([lm (lam 'nmme '() 3 '() #f '#() '() #f 1 (seq '()))] 507 | [pcs (list lm lm)] 508 | [bdy (expr)] 509 | [z (let-rec pcs bdy)] 510 | [z* (let-rec '() '())]) 511 | (begin (check-equal? (let-rec-> z "procs") pcs) 512 | (check-equal? (let-rec-> z "body") bdy) 513 | (check-equal? (let-rec-> z "") #f) 514 | (check-equal? (let-rec-> z* "procs") '()) 515 | (check-equal? (let-rec-> z* "body") #f)))) 516 | 517 | (test-case "boxenv->" 518 | (let* ([bdy (expr)] 519 | [z (boxenv 2 bdy)] 520 | [z* (boxenv 3 4)]) 521 | (begin (check-equal? (boxenv-> z "body") bdy) 522 | (check-equal? (boxenv-> z "pos") #f) 523 | (check-equal? (boxenv-> z "") #f) 524 | (check-equal? (boxenv-> z* "body") #f)))) 525 | 526 | (test-case "localref->" 527 | (let ([z (localref #t 1 #t #t #f)]) 528 | (begin (check-equal? (localref-> z "unbox?") #f) 529 | (check-equal? (localref-> z "pos") #f) 530 | (check-equal? (localref-> z "clear?") #f) 531 | (check-equal? (localref-> z "other-clears?") #f) 532 | (check-equal? (localref-> z "type") #f) 533 | (check-equal? (localref-> z "") #f)))) 534 | 535 | (test-case "toplevel->" 536 | (let ([z (toplevel 1 2 #f #f)]) 537 | (begin (check-equal? (toplevel-> z "depth") #f) 538 | (check-equal? (toplevel-> z "pos") #f) 539 | (check-equal? (toplevel-> z "const?") #f) 540 | (check-equal? (toplevel-> z "ready?") #f) 541 | (check-equal? (toplevel-> z "") #f)))) 542 | 543 | (test-case "application->" 544 | (let* ([e (expr)] 545 | [s (seq '())] 546 | [z (application s (list e s s '() 'any 54 e))]) 547 | (begin (check-equal? (application-> z "rator") s) 548 | (check-equal? (application-> z "rands") (list e s s e)) 549 | (check-equal? (application-> z "") #f)))) 550 | 551 | (test-case "branch->" 552 | (let* ([z (branch (expr) (expr) (expr))] 553 | [z* (branch #f #f #f)]) 554 | (begin (check-equal? (branch-> z "test") (expr)) 555 | (check-equal? (branch-> z "then") (expr)) 556 | (check-equal? (branch-> z "else") (expr)) 557 | (check-equal? (branch-> z "") #f) 558 | (check-equal? (branch-> z* "test") #f) 559 | (check-equal? (branch-> z* "then") #f) 560 | (check-equal? (branch-> z* "else") #f)))) 561 | 562 | (test-case "with-cont-mark->" 563 | (let* ([z (with-cont-mark (expr) (expr) (expr))] 564 | [z* (with-cont-mark #f #f #f)]) 565 | (begin (check-equal? (with-cont-mark-> z "key") (expr)) 566 | (check-equal? (with-cont-mark-> z "val") (expr)) 567 | (check-equal? (with-cont-mark-> z "body") (expr)) 568 | (check-equal? (with-cont-mark-> z "") #f) 569 | (check-equal? (with-cont-mark-> z* "key") #f) 570 | (check-equal? (with-cont-mark-> z* "val") #f) 571 | (check-equal? (with-cont-mark-> z* "body") #f)))) 572 | 573 | (test-case "beg0->" 574 | (let ([z (beg0 (list (expr) 'asdf (expr)))]) 575 | (begin (check-equal? (beg0-> z "seq") (list (expr) (expr))) 576 | (check-equal? (beg0-> z "") #f)))) 577 | 578 | (test-case "varref->" 579 | (let* ([tl (toplevel 1 1 #f #f)] 580 | [z (varref tl tl #f #f)] 581 | [z* (varref #t #f #t #t)]) 582 | (begin (check-equal? (varref-> z "toplevel") tl) 583 | (check-equal? (varref-> z "dummy") tl) 584 | (check-equal? (varref-> z "constant?") #f) 585 | (check-equal? (varref-> z "from-unsafe?") #f) 586 | (check-equal? (varref-> z "") #f) 587 | (check-equal? (varref-> z* "dummy") #f) 588 | (check-equal? (varref-> z* "toplevel") #f) 589 | (check-equal? (varref-> z* "constant?") #f) 590 | (check-equal? (varref-> z* "from-unsafe?") #f)))) 591 | 592 | (test-case "assign->" 593 | (let* ([id (toplevel 1 1 #f #f)] 594 | [rhs (expr)] 595 | [z (assign id rhs #t)] 596 | [z* (assign id #f #t)]) 597 | (begin (check-equal? (assign-> z "id") id) 598 | (check-equal? (assign-> z "rhs") rhs) 599 | (check-equal? (assign-> z "undef-ok?") #f) 600 | (check-equal? (assign-> z "") #f) 601 | (check-equal? (assign-> z* "rhs") #f)))) 602 | 603 | (test-case "apply-values->" 604 | (let* ([z (apply-values (expr) (expr))] 605 | [z* (apply-values #f #f)]) 606 | (begin (check-equal? (apply-values-> z "proc") (expr)) 607 | (check-equal? (apply-values-> z "args-expr") (expr)) 608 | (check-equal? (apply-values-> z "") #f) 609 | (check-equal? (apply-values-> z* "proc") #f) 610 | (check-equal? (apply-values-> z* "args-expr") #f)))) 611 | 612 | (test-case "with-immed-mark->" 613 | (let* ([z (with-immed-mark (expr) (expr) (expr))] 614 | [z* (with-immed-mark 'x 'y 'z)]) 615 | (begin (check-equal? (with-immed-mark-> z "key") (expr)) 616 | (check-equal? (with-immed-mark-> z "def-val") (expr)) 617 | (check-equal? (with-immed-mark-> z "body") (expr)) 618 | (check-equal? (with-immed-mark-> z "") #f) 619 | (check-equal? (with-immed-mark-> z* "key") #f) 620 | (check-equal? (with-immed-mark-> z* "def-val") #f) 621 | (check-equal? (with-immed-mark-> z* "body") #f)))) 622 | 623 | (test-case "primval->" 624 | (let ([z (primval 420)]) 625 | (begin (check-equal? (primval-> z "id") #f) 626 | (check-equal? (primval-> z "") #f)))) 627 | 628 | (test-case "expr-or-seq?" 629 | (check-true (expr-or-seq? (expr))) 630 | (check-true (expr-or-seq? (branch #t #t #t))) 631 | (check-true (expr-or-seq? (application (expr) (list expr)))) 632 | (check-true (expr-or-seq? (seq '())))) 633 | 634 | (check-false (expr-or-seq? 'asdf)) 635 | (check-false (expr-or-seq? "yolo")) 636 | (check-false (expr-or-seq? (form))) 637 | ) 638 | -------------------------------------------------------------------------------- /scribblings/.gitignore: -------------------------------------------------------------------------------- 1 | zordoz 2 | 3 | *\.html 4 | *\.js 5 | *\.css 6 | -------------------------------------------------------------------------------- /scribblings/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | raco scribble \ 3 | --htmls \ 4 | ++main-xref-in \ 5 | --redirect-main http://docs.racket-lang.org/ \ 6 | zordoz.scrbl 7 | 8 | clean: 9 | rm -rf zordoz 10 | -------------------------------------------------------------------------------- /scribblings/api.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | @require[racket/include 3 | scribble/eval 4 | scriblib/footnote 5 | compiler/zo-parse 6 | @for-label[compiler/zo-parse 7 | zordoz 8 | racket/base 9 | syntax/toplevel]] 10 | 11 | @(define zordoz-eval 12 | (make-base-eval 13 | '(begin (require compiler/zo-structs zordoz racket/string)))) 14 | 15 | @title{API} 16 | 17 | These functions support the REPL, but may be useful in more general settings. 18 | Import them with @racket[(require zordoz)]. 19 | 20 | 21 | 22 | @section{Starting a REPL} 23 | 24 | @defproc[(filename->shell [fname path-string?]) void?]{ 25 | Start a REPL to explore a @racket[.zo] bytecode file. 26 | } 27 | 28 | @defproc[(zo->shell [z zo]) void?]{ 29 | Start a REPL to explore a zo struct. 30 | } 31 | 32 | @defproc[(syntax->shell [stx syntax?]) void?]{ 33 | Start a REPL to explore a syntax object. 34 | First compiles the syntax to a zo representation. 35 | } 36 | 37 | 38 | @section{String Representations} 39 | 40 | These tools convert a zo structure to a pretty-printed string, or a more structured representation. 41 | 42 | @defproc[(zo->string [z zo?] [#:deep? deep boolean?]) string?]{ 43 | Convert a zo struct into a string. 44 | When the optional argument @code{#:deep?} is set, include the struct's fields in the string representation. 45 | Otherwise, only print the name. 46 | } 47 | 48 | @examples[#:eval zordoz-eval 49 | (displayln (zo->string (primval 129))) 50 | (displayln (zo->string (primval 129) #:deep? #f)) 51 | (displayln (zo->string (branch (= 3 1) "true" 'false))) 52 | ] 53 | 54 | @defproc[(zo->spec [z zo?]) spec/c]{ 55 | Convert a zo struct into a @racket[spec/c] representation. 56 | A @racket[spec/c] is a list containing: 57 | @itemlist[ 58 | @item{A string, representing its name.} 59 | @item{Pairs, representing the struct's fields. 60 | The first element of each pair should be a string representing the field name. 61 | The second element should be a thunk that, when forced, yields either a string or another spec.} 62 | ] 63 | The thunks delay pretty-printing an entire nested struct. 64 | } 65 | 66 | @examples[#:eval zordoz-eval 67 | (zo->spec (primval 129)) 68 | (zo->spec (branch (= 3 1) "true" 'false)) 69 | ] 70 | 71 | 72 | @section{Traversing @racket[zo] Structs} 73 | 74 | Racket does not provide a reflective way of accessing struct fields at runtime. 75 | So we provide a function that does this by-force, just for zo structures. 76 | 77 | 78 | @defproc[(zo-transition [z zo?] [str string?]) (values (values (or/c zo? (listof zo?)) boolean?))]{ 79 | Identify what specific zo struct @racket[z] is, then access its field named @racket[str], if any. 80 | The multiple return values deal with the following cases: 81 | @itemlist[ 82 | @item{If the field @racket[str] does not exist, or does not denote a zo struct, return the argument @racket[z] and the boolean value @racket[#f].} 83 | @item{If the field @racket[str] denotes a list and we can parse zo structs from the list, return a list of zo structs and the boolean @racket[#t].} 84 | @item{(Expected case) If the field points to a zo struct, return the new zo struct and the boolean @racket[#t].} 85 | ] 86 | } 87 | 88 | @examples[#:eval zordoz-eval 89 | (let-values ([(z success?) (zo-transition (primval 42) "foo")]) 90 | (displayln success?) 91 | z) 92 | (let-values ([(z success?) (zo-transition (primval 42) "id")]) 93 | (displayln success?) 94 | z) 95 | (let-values ([(z success?) (zo-transition 96 | (application (primval 42) '()) 97 | "rator")]) 98 | (displayln success?) 99 | z) 100 | ] 101 | 102 | 103 | @section{Searching Structs} 104 | 105 | If you know the name of the @racket[zo struct] you hope to find by exploring a subtree, you can automate the exploring. 106 | Literally, @racket[find] is repeated application of @racket[zo->string] and @racket[zo-transition]. 107 | 108 | @defproc[(zo-find [z zo?] [str string?] [#:limit lim (or/c natural-number/c #f) #f]) (listof result?)]{ 109 | Starting with the children of the struct @racket[z], search recursively for struct instances matching the string @racket[str]. 110 | For example, if @racket[str] is @racket[application] then @racket[find] will return all @racket[application] structs nested below @racket[z]. 111 | 112 | The return value is a list of @racket[result] structs rather than plain zo structs because we record the path from the argument @racket[z] down to each match. 113 | } 114 | 115 | @examples[#:eval zordoz-eval 116 | (let* ([seq* (list (seq '()) (seq '()))] 117 | [z (seq (list (seq seq*) (seq seq*)))]) 118 | (zo-find z "seq" #:limit 1)) 119 | (let* ([thn (primval 0)] 120 | [els (branch #t (primval 1) (primval 2))] 121 | [z (branch #t thn els)]) 122 | (map result-zo (zo-find z "primval"))) 123 | ] 124 | 125 | @defproc[(result-zo [result zo-result?]) zo?]{ 126 | Converts a @racket[zo-result?] to the found @racket[zo?] field. 127 | See @racket[zo-find]. 128 | } 129 | 130 | @defstruct*[result ([z zo?] [path (listof zo?)]) #:transparent]{ 131 | A @racket[result] contains a zo struct and a path leading to it from the search root. 132 | In the context of @racket[find], the path is always from the struct @racket[find] was called with. 133 | } 134 | 135 | @defproc[(find-all [fname path-string?] [qry* (Listof String)] [#:limit lim (or/c natural-number/c #f) #f]) void?]{ 136 | Apply find iteratively on the bytecode file @racket[fname]. 137 | Print the results for each string in the list @racket[qry*] to @racket[current-output-port]. 138 | } 139 | 140 | 141 | @section{Compiling and Decompiling} 142 | 143 | Tools for compiling syntax fragments rather than entire modules. 144 | 145 | @defproc[(syntax->zo [stx syntax?]) zo?]{ 146 | Compiles a syntax object to a @racket[zo] struct. 147 | } 148 | 149 | @examples[#:eval zordoz-eval 150 | (syntax->zo #'6) 151 | (syntax->zo #'(member 'a '(a b c))) 152 | (syntax->zo #'(if #t 'left 'right)) 153 | ] 154 | 155 | @defproc[(syntax->decompile [stx syntax?]) any/c]{ 156 | Compiles a syntax object, then immediately decompiles the compiled code back to an S-expression. 157 | Similar to @racket[syntax->zo], except the final output is Racket code and not a @racket[zo] structure. 158 | } 159 | 160 | @examples[#:eval zordoz-eval 161 | (syntax->decompile #'6) 162 | (syntax->decompile #'(member 'a '(a b c))) 163 | (syntax->decompile #'(if #t 'left 'right)) 164 | ] 165 | 166 | @defproc[(compiled-expression->zo [cmp compiled-expression?]) zo?]{ 167 | Converts a compiled expression into a zo struct. 168 | Differs from @racket[zo-parse] in that the input is expected to be a 169 | @racket[compiled-expression?]. 170 | This function is the inverse of @racket[zo->compiled-expression]. 171 | } 172 | 173 | @examples[#:eval zordoz-eval 174 | (compiled-expression->zo (compile-syntax #'6)) 175 | (compiled-expression->zo (compile-syntax #'(member 'a '(a b c)))) 176 | (compiled-expression->zo (compile-syntax #'(if #t 'left 'right))) 177 | ] 178 | 179 | @defproc[(zo->compiled-expression [z zo?]) compiled-expression?]{ 180 | Transform a @racket[zo] struct to compiled code. 181 | The compiled code can be run with @racket[eval]. 182 | If the struct @racket[z] encodes a module (i.e., contains a @racket[mod] sub-struct) 183 | then the result @racket[zo->compiled-expressions z] can be written to a @racket[.rkt] file and run using the Racket executable. 184 | } 185 | 186 | @examples[#:eval zordoz-eval 187 | (let* ([stx #'(string-append "hello, " "world")] 188 | [z (syntax->zo stx)] 189 | [e (zo->compiled-expression z)]) 190 | (eval e (make-base-namespace))) 191 | ] 192 | 193 | @defproc[(toplevel-syntax->zo [stx syntax?]) (listof zo?)]{ 194 | Variant of @racket[syntax->zo], except can handle top level syntax 195 | expressions. 196 | Uses @racket[eval-compile-time-part-of-top-level/compile] to compile syntax 197 | rather than just @racket[compile]. 198 | As such, this function returns a list of @racket[zo] structs rather than just 199 | one. 200 | } 201 | 202 | @examples[#:eval zordoz-eval 203 | (toplevel-syntax->zo #'(begin 204 | (define x 5) 205 | x)) 206 | ] 207 | 208 | @section{Compiling C Modules} 209 | 210 | Tools for compiling modules implemented in C. 211 | 212 | @defproc[(compile-c-module [c-path (or/c path-string? path?)]) void?]{ 213 | Compiles a C module to a form where it can be required later. 214 | 215 | See @other-doc['(lib "scribblings/inside/inside.scrbl")] for more information on how 216 | to build Racket modules in C. 217 | 218 | @bold{@larger{@larger{WARNING:}}} 219 | Do not replace the file produced by the functions while still 220 | inside the Racket VM. 221 | Doing so will cause undefined and potentially catastrophic behavior. 222 | As a general rule of thumb, if you modify a C file implementing a module, 223 | shut down all Racket VMs using that library. This means restarting 224 | DrRacket (not just reloading the file) whenever the C file is modified. 225 | 226 | 227 | @racket[c-path] is the path to the C file that implemented the module. 228 | 229 | For example: 230 | 231 | @racketblock[ 232 | (require zordoz) 233 | (compile-c-module "c-module.c") 234 | (dynamic-require "c-module" 0) 235 | ] 236 | } 237 | 238 | @defform[(from-c c-path) 239 | #:contracts ([c-path path-string?])]{ 240 | A convenience form to compile a C module and require it directly. Use outside 241 | of a @racket[require] form is a syntax error. 242 | 243 | @racket[c-path] is the path to the C file that implements the module. 244 | 245 | For example: 246 | 247 | @racketblock[ 248 | (require zordoz 249 | (from-c "c-module.c")) 250 | ] 251 | } 252 | 253 | @include-section{typed-api.scrbl} 254 | -------------------------------------------------------------------------------- /scribblings/overview.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @title{Overview} 4 | 5 | @local-table-of-contents[] 6 | 7 | 8 | @section{Quickstart} 9 | 10 | To install, either use @tt{raco} 11 | 12 | @racketblock[raco pkg install zordoz] 13 | 14 | Or clone the repository and install manually, via raco. 15 | 16 | @racketblock[ 17 | $ git clone https://github.com/bennn/zordoz 18 | $ raco pkg install zordoz/ 19 | ] 20 | 21 | Zordoz provides a raco command. 22 | To see help information, run: 23 | 24 | @racketblock[raco zordoz --help] 25 | 26 | 27 | @subsection{Explorer} 28 | The default mode is to interactively explore a bytecode file. 29 | Assuming @tt{FILE.zo} is a compiled file on your computer, 30 | 31 | @racketblock[raco zordoz FILE.zo] 32 | 33 | will start a REPL session. 34 | Type @tt{help} at the REPL to see available commands. 35 | See @Secref{REPL} for a detailed explanation of each. 36 | 37 | 38 | @subsection{Automated Search} 39 | To search a bytecode file for occurrences of a certain zo struct, use the @tt{-f} flag. 40 | (This flag may be supplied more than once.) 41 | @racketblock[raco zordoz -f STRUCT-NAME FILE.zo] 42 | 43 | The number of occurrences of each struct will be printed to the console. 44 | For example: 45 | @racketblock[ 46 | $ raco zordoz -f branch -f lam private/compiled/zo-string_rkt.zo 47 | INFO: Loading bytecode file 'private/compiled/zo-string_rkt.zo'... 48 | INFO: Parsing bytecode... 49 | INFO: Parsing complete! Searching... 50 | FIND 'branch' : 427 results 51 | FIND 'lam' : 433 results 52 | All done! 53 | ] 54 | 55 | 56 | @subsection{Just Print the Parsed Bytecode} 57 | @racketblock[ 58 | $ raco zordoz -p compiled/foo_rkt.zo 59 | ] 60 | 61 | 62 | @section{Testing} 63 | 64 | Each source file contains a @tt{module+ test} with unit tests. 65 | Run them all with: 66 | 67 | @racketblock[raco test zordoz] 68 | 69 | or individually using: 70 | 71 | @racketblock[raco test FILE.rkt] 72 | 73 | 74 | @section{Project Goals} 75 | 76 | Racket offers a de-compilation @hyperlink["http://docs.racket-lang.org/raco/decompile.html"]{API}, however the structs it produces are still dense reading. 77 | This project takes a de-compiled @racket[zo] struct and offers: 78 | 79 | @itemlist[ 80 | 81 | @item{A string representation of the struct, with name and fields clearly labeled.} 82 | 83 | @item{Interactive exploration of the struct's fields.} 84 | 85 | @item{A simple search interface for finding patterns nested within a struct.} 86 | 87 | ] 88 | 89 | This library should be available to as many versions of Racket as possible, 90 | and kept up-to-date. 91 | 92 | We also hope to add more features, especially a tool for comparing two bytecode files. 93 | @hyperlink["https://github.com/bennn/zordoz/issues"]{Feedback} and suggestions appreciated! 94 | 95 | -------------------------------------------------------------------------------- /scribblings/repl.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | 3 | @local-table-of-contents[] 4 | 5 | @title{REPL} 6 | 7 | The REPL is a simple, interactive way to explore bytecode files. 8 | This document is a users' guide for the REPL. 9 | See the @secref{API} page for alternate ways of starting a REPL (besides the command line). 10 | 11 | @section{Summary} 12 | 13 | The REPL works by storing an internal @emph{context} and reacting to commands. 14 | This context is either: 15 | @itemlist[ 16 | @item{A zo struct} 17 | @item{A list of zo structs} 18 | @item{Search results, obtained by calling @secref{find}.} 19 | ] 20 | 21 | The commands observe or advance this context. 22 | Commands may be separated by newlines or semicolons. 23 | 24 | For convenience, the REPL records previous states. 25 | We call this recorded past the @emph{history} of the REPL; it is a stack of contexts. 26 | 27 | Keeping this stack in mind is useful for understanding the REPL commands. 28 | 29 | 30 | @section{Commands} 31 | 32 | @subsection{alst} 33 | 34 | List all command aliases. 35 | 36 | For uniformity, the canonical name of each command has 4 letters. 37 | But each has a few mnemonic aliases to choose from. 38 | For example, you can type @tt{ls} instead of @secref{info} and @tt{cd} instead of @secref{dive}. 39 | 40 | 41 | @subsection{back} 42 | 43 | Move up to the previous context. 44 | 45 | Each successful @secref{dive} or @secref{find} command changes the current context to new struct or list. 46 | Before making these transitions, we save the previous context to a stack. 47 | The @secref{back} command pops and switches to the most recent element from this stack. 48 | 49 | Note that @secref{back} will fail (and print a warning) at the top of the zo struct hierarchy or the top of a saved subtree. 50 | 51 | 52 | @subsection{dive} 53 | 54 | Enter a struct's field. 55 | 56 | This is where exploring happens. 57 | Each struct has a few fields; you can see these by printing with @secref{info}. 58 | Any field containing zo structs is a candidate for dive. 59 | For example, the struct @racket[assign] has a field @tt{rhs}, which can be accessed by: 60 | @racketblock[ 61 | dive rhs 62 | ] 63 | 64 | If you know where you are going, you can chain paths together. 65 | Starting at a @racket[beg0] struct, this command moves to the first @racket[expr] or @racket[seq] in the sequence. 66 | @racketblock[ 67 | dive seq/0 68 | ] 69 | 70 | Extra Notes: 71 | @itemlist[ 72 | @item{Only fields that contain zo structures or lists of zo structures may be explored.} 73 | @item{Changing to a zo structure field changes the context to the child zo structure. 74 | Changing to a list field changes context to that list, from which you can select a natural-number position 75 | in the list to explore.} 76 | @item{@secref{dive} takes exactly one argument. Any more or less is not permitted.} 77 | ] 78 | 79 | 80 | @subsection{find} 81 | 82 | Search the current struct's children for a certain zo struct. 83 | 84 | Find uses string matching to automate a simple search process. 85 | Give it a string, for instance @secref{find} @racket[lam] structs nested within the current context. 86 | The string must be the name of a zo struct---anything else will return null results. 87 | 88 | A successful find changes context to a list of zo structs. 89 | Exploring any element of the list changes the current history to be that element's history. 90 | You are free to explore the children and parents of any struct returned by a find query. 91 | Use @secref{jump} to immediately return to the search results. 92 | 93 | Note: 94 | @itemlist[ 95 | @item{If, after exploring a search result, you move @tt{back} past the list of search results, the REPL will print a notice.} 96 | ] 97 | 98 | 99 | @subsection{help} 100 | 101 | Print command information. 102 | 103 | Shows a one-line summary of each command. 104 | The tabernacle is all-knowing. 105 | 106 | 107 | @subsection{info} 108 | 109 | Print the current context. 110 | 111 | This @secref{info} command does the real work of exploring. 112 | It shows the current context, whether struct or list. 113 | Lists give their length and the names of their elements. 114 | Zo structs show their name, their fields' names, and their fields' values. 115 | 116 | Struct fields are printed as best we can. 117 | @itemlist[ 118 | @item{Fields which are zo structures print their names. These fields may be @secref{dive}-ed into.} 119 | @item{Fields which are lists containing at least one zo structure are printed with a natural number in square braces, 120 | indicating the number of zo structs inside the list. These fields may also be @secref{dive}d into.} 121 | @item{Other fields are printed with Racket's default printer. Be aware, lists and hashes can sometimes cause very large 122 | printouts.} 123 | ] 124 | 125 | 126 | @subsection{jump} 127 | 128 | Warp back to a previously-saved context. 129 | 130 | The commands @secref{jump} and @secref{save} work together. 131 | After saving or making a successful query with @secref{find}, the current history is saved. 132 | At this point, a step backwards will recover this history. 133 | The interesting thing is that steps forward create a new history, and you can immediately forget that new history by calling @secref{jump}. 134 | 135 | For example, if you call @secref{find} and explore one of the results, you can immediately @secref{jump} back to your search results. 136 | 137 | 138 | @subsection{save} 139 | 140 | Mark the current context and history as a future target for @secref{jump}. 141 | This is useful for marking a struct you want to backtrack to. 142 | 143 | Note that, if you manually backtrack past a @secref{save}d struct then its mark disappears and the REPL prints a notice. 144 | 145 | 146 | @subsection{quit} 147 | 148 | Exit the REPL. 149 | 150 | 151 | @section{Sample Interaction} 152 | 153 | Let's explore the REPL's own bytecode. 154 | Starting from the directory you cloned this repo to 155 | (or where `raco` put it on your filesystem): 156 | 157 | @racketblock[ 158 | $ raco zordoz private/compiled/zo-string_rkt.zo 159 | INFO: Loading bytecode file 'private/compiled/zo-string_rkt.zo'... 160 | INFO: Parsing bytecode... 161 | INFO: Parsing complete! 162 | --- Welcome to the .zo shell, version 1.0 'vortex' --- 163 | zo> 164 | ] 165 | 166 | Now we can start typing commands, like @secref{info}. 167 | 168 | @racketblock[ 169 | zo> info 170 | 171 | max-let-depth : 31 172 | prefix : 173 | code : 174 | ] 175 | 176 | Next, let's try a @secref{dive}. 177 | 178 | @racketblock[ 179 | zo> dive max-let-depth 180 | 'dive max-let-depth' not permitted. 181 | ] 182 | 183 | Didn't work! 184 | That's because @tt{max-let-depth} is an integer. 185 | Let's try one of the structs. 186 | 187 | @racketblock[ 188 | zo> dive prefix 189 | zo> info 190 | 191 | num-lifts : 0 192 | toplevels : [#f] 193 | stxs : [] 194 | ] 195 | 196 | Great! 197 | We can't dive any further from here, so let's go back up. 198 | 199 | @racketblock[ 200 | zo> back 201 | zo> info 202 | 203 | max-let-depth : 31 204 | prefix : 205 | code : 206 | ] 207 | 208 | And we're back to where we began. 209 | From here we @emph{could} dive to the @tt{code} field and print it, but the printout is a little overwhelming. 210 | The module we're exploring, @tt{zo-string}, creates over 40 different functions. 211 | There's just a lot of data to look at, and because it's heterogenous data we do not have a nice way of truncating it. 212 | 213 | Instead, we'll try the @secref{find} command. 214 | Be warned, the search might take a minute. 215 | 216 | @racketblock[ 217 | zo> find compilation-top 218 | FIND returned 0 results 219 | ] 220 | 221 | Zero results is good: there should not be any other @tt{compilation-top} structs besides the one we're currently in. 222 | Now try searching for something else, like @racket[branch]. 223 | 224 | @racketblock[ 225 | zo> find branch 226 | FIND returned 422 results 227 | FIND automatically saving context 228 | [422] 229 | ] 230 | 231 | Wow! Over 400 results. 232 | We can start exploring one of them: 233 | 234 | @racketblock[ 235 | zo> dive 17 236 | zo> info 237 | 238 | test : 239 | then : 240 | else : 241 | ] 242 | 243 | We can also explore its children and parents. 244 | 245 | @racketblock[ 246 | zo> dive test 247 | zo> info 248 | 249 | rator : 250 | rands : [] 251 | zo> dive rator 252 | zo> info 253 | 254 | id : 90 255 | zo> up 256 | zo> up 257 | zo> info 258 | 259 | test : 260 | then : 261 | else : 262 | zo> up 263 | zo> info 264 | 265 | test : 266 | then : 267 | else : #f 268 | ] 269 | 270 | And if we do a @secref{jump}, we return to the search results. 271 | 272 | @racketblock[ 273 | zo> jump 274 | zo> info 275 | [422] 276 | ] 277 | 278 | -------------------------------------------------------------------------------- /scribblings/typed-api.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | @require[ 3 | zordoz/typed ;; To format provided identifiers 4 | (for-syntax racket/base 5 | (only-in racket/list make-list split-at))] 6 | 7 | @title{Typed API} 8 | 9 | A typed version of this API is available with @racket[(require zordoz/typed)]. 10 | 11 | @; Collect identifiers from zordoz/typed, render in a table 12 | @(define-for-syntax (parse-provide* x*) 13 | (for*/list ([phase+id* (in-list x*)] 14 | [id* (in-list (cdr phase+id*))]) 15 | #`@racket[#,(car id*)] )) 16 | @(define-for-syntax (split-at/no-fail n x*) 17 | (define N (length x*)) 18 | (if (< N n) 19 | (let ([padded (append x* (make-list (- n N) ""))]) 20 | (values padded '())) 21 | (split-at x* n))) 22 | @(define-syntax (render-zordoz/typed stx) 23 | (define flat-id* 24 | (let-values (((var* stx*) (module->exports '(lib "zordoz/typed")))) 25 | (append (parse-provide* var*) (parse-provide* stx*)))) 26 | (with-syntax ([((id* ...) ...) 27 | (let loop ([id* flat-id*]) 28 | (if (null? id*) 29 | '() 30 | (let-values ([(row rest) (split-at/no-fail 3 id*)]) 31 | (cons row (loop rest)))))]) 32 | #'@tabular[#:sep @hspace[4] (list (list id* ...) ...)])) 33 | 34 | @defmodule[zordoz/typed]{ 35 | A typed version of @racketmodname[zordoz]. 36 | Provided identifiers are: 37 | @;@(render-zordoz/typed) 38 | } 39 | 40 | @defmodule[zordoz/typed/zo-structs #:no-declare]{ 41 | A typed version of Racket's @racketmodname[compiler/zo-structs]. 42 | } 43 | -------------------------------------------------------------------------------- /scribblings/zordoz.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/manual 2 | @require[racket/include] 3 | 4 | @title[#:tag "top"]{Zordoz} 5 | @author[@hyperlink["https://github.com/bennn"]{Ben Greenman} 6 | @hyperlink["https://github.com/LeifAndersen"]{Leif Andersen}] 7 | 8 | @defmodule[zordoz]{ 9 | @bold{Zordoz} is a tool for exploring @tt{.zo} bytecode files. 10 | It offers a simple command-line interface for exploring string representations of bytecode structures. 11 | } 12 | 13 | These files describe the REPL and the API functions supporting it. 14 | Jump to the bottom of the @secref{REPL} section for example usage. 15 | 16 | @local-table-of-contents[] 17 | 18 | @include-section{overview.scrbl} 19 | @include-section{repl.scrbl} 20 | @include-section{api.scrbl} 21 | -------------------------------------------------------------------------------- /test.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket/base 2 | 3 | (require zordoz/typed) 4 | 5 | (module+ main 6 | (for ((x (in-vector (current-command-line-arguments)))) 7 | (find-all x '("branch")))) 8 | -------------------------------------------------------------------------------- /typed.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket/base 2 | 3 | (require 4 | zordoz/typed/zo-structs 5 | typed/racket/unsafe) 6 | 7 | (require/typed zordoz/private/zo-find 8 | (#:opaque result result?) 9 | (result-zo (-> result Zo)) 10 | (result-path (-> result (Listof Zo)))) 11 | 12 | ;; ----------------------------------------------------------------------------- 13 | 14 | (unsafe-require/typed zordoz/private/zo-string 15 | (zo->string (->* [Zo] [#:deep? Boolean] String)) 16 | (zo->spec (-> Zo Spec))) 17 | 18 | (unsafe-require/typed zordoz/private/zo-transition 19 | (zo-transition (-> Zo String (Values (U Zo (Listof Zo)) Boolean)))) 20 | 21 | (unsafe-require/typed zordoz/private/zo-find 22 | (zo-find (->* [Zo] [#:limit (U Natural #f)] (Listof result)))) 23 | 24 | (unsafe-require/typed zordoz/private/zo-shell 25 | (find-all (->* [Path-String (Listof String)] [#:limit (U Natural #f)] Void)) 26 | (filename->shell (-> Path-String Void)) 27 | (zo->shell (-> Zo Void)) 28 | (syntax->shell (-> Syntax Void))) 29 | 30 | (unsafe-require/typed zordoz/private/zo-syntax 31 | (compiled-expression->zo (-> Compiled-Expression Zo)) 32 | (syntax->zo (-> Syntax Zo)) 33 | (syntax->decompile (-> Syntax Any)) 34 | (toplevel-syntax->zo (-> Syntax (Listof Zo))) 35 | (zo->compiled-expression (-> Zo Compiled-Expression))) 36 | 37 | ;; ============================================================================= 38 | 39 | (provide 40 | result result? result-zo result-path 41 | zo->string 42 | zo->spec 43 | zo-transition 44 | zo-find 45 | find-all 46 | filename->shell 47 | zo->shell 48 | syntax->shell 49 | compiled-expression->zo 50 | syntax->zo 51 | syntax->decompile 52 | toplevel-syntax->zo 53 | zo->compiled-expression 54 | ) 55 | -------------------------------------------------------------------------------- /typed/zo-structs.rkt: -------------------------------------------------------------------------------- 1 | #lang typed/racket 2 | 3 | 4 | ;; A Spec is the name of a zo struct and a list of pairs representing its fields: 5 | ;; - The car of each field is the name of that field 6 | ;; - The cdr of each field is a thunk for building a representation of the field's value. 7 | ;; If the value is a zo-struct, the thunk should build a Spec 8 | ;; Otherwise, the thunk should build a string 9 | (define-type Spec 10 | (Rec Spec 11 | (Pair String (Listof (Pair String (-> (U Spec String))))))) 12 | (define-type Zo zo) 13 | (provide Spec Zo) 14 | 15 | (require/typed/provide 16 | compiler/zo-structs 17 | [#:struct zo ()] 18 | [#:struct (linkl-directory zo) ( 19 | [table : (HashTable (Listof Symbol) linkl-bundle)])] 20 | [#:struct (linkl-bundle zo) ( 21 | [table : (HashTable (U Symbol Fixnum) (U linkl Any))])] 22 | [#:struct (linkl zo) ( 23 | [name : Symbol] 24 | [importss : (Listof (Listof Symbol))] 25 | [import-shapess : (Listof (Listof (U #f 'constant 'fixed function-shape struct-shape)))] 26 | [exports : (Listof Symbol)] 27 | [internals : (Listof (U Symbol #f))] 28 | [lifts : (Listof Symbol)] 29 | [source-names : (HashTable Symbol Symbol)] 30 | [body : (Listof (U form Any))] 31 | [max-let-depth : Exact-Nonnegative-Integer] 32 | [need-instance-access? : Boolean])] 33 | [#:struct function-shape ( 34 | [arity : (U Natural arity-at-least (Listof (U Natural arity-at-least)))] 35 | [preserves-marks? : Boolean])] ;; bennn: got type from (:print-type procedure-arity) 36 | [#:struct struct-shape ()] 37 | [#:struct (struct-type-shape struct-shape) ( 38 | [field-count : Exact-Nonnegative-Integer] 39 | [authentic? : Boolean])] 40 | [#:struct (constructor-shape struct-shape) ( 41 | [arity : Exact-Nonnegative-Integer])] 42 | [#:struct (predicate-shape struct-shape) ( 43 | [authentic? : Boolean])] 44 | [#:struct (accessor-shape struct-shape) ( 45 | [field-count : Exact-Nonnegative-Integer] 46 | [authentic? : Boolean])] 47 | [#:struct (mutator-shape struct-shape) ( 48 | [field-count : Exact-Nonnegative-Integer] 49 | [authentic? : Boolean])] 50 | [#:struct (struct-type-property-shape struct-shape) ( 51 | [has-guard? : Boolean])] 52 | [#:struct (property-predicate-shape struct-shape) ()] 53 | [#:struct (property-accessor-shape struct-shape) ()] 54 | [#:struct (struct-other-shape struct-shape) ()] 55 | [#:struct (form zo) ()] 56 | [#:struct (expr form) ()] 57 | [#:struct (def-values form) ( 58 | [ids : (Listof toplevel)] 59 | [rhs : (U expr seq inline-variant Any)])] 60 | [#:struct (inline-variant zo) ( 61 | [direct : expr] 62 | [inline : expr])] 63 | [#:struct (seq form) ( 64 | [forms : (Listof (U expr Any))])] 65 | [#:struct (lam expr) ( 66 | [name : (U Symbol (Vectorof Any))] ;empty list 67 | [flags : (Listof (U 'preserves-marks 'is-method 'single-result 68 | 'only-rest-arg-not-used 'sfs-clear-rest-args))] 69 | [num-params : Exact-Nonnegative-Integer] 70 | [param-types : (Listof (U 'val 'ref 'flonum 'fixnum 'extflonum))] 71 | [rest? : Boolean] 72 | [closure-map : (Vectorof Exact-Nonnegative-Integer)] 73 | [closure-types : (Listof (U 'val/ref 'flonum 'fixnum 'extflonum))] 74 | [toplevel-map : (U #f (Setof Exact-Nonnegative-Integer))] 75 | [max-let-depth : Exact-Nonnegative-Integer] 76 | [body : (U expr seq Any)])] 77 | [#:struct (closure expr) ( 78 | [code : lam] 79 | [gen-id : Symbol])] 80 | [#:struct (case-lam expr) ( 81 | [name : (U Symbol (Vectorof Any) (List ))] 82 | [clauses : (Listof (U lam closure))])] 83 | [#:struct (let-one expr) ( 84 | [rhs : (U expr seq Any)] ; pushes one value onto stack 85 | [body : (U expr seq Any)] 86 | [type : (U #f 'flonum 'fixnum 'extflonum)] 87 | [unused? : Boolean])] 88 | [#:struct (let-void expr) ( 89 | [count : Exact-Nonnegative-Integer] 90 | [boxes? : Boolean] 91 | [body : (U expr seq Any)])] 92 | [#:struct (install-value expr) ( 93 | [count : Exact-Nonnegative-Integer] 94 | [pos : Exact-Nonnegative-Integer] 95 | [boxes? : Boolean] 96 | [rhs : (U expr seq Any)] 97 | [body : (U expr seq Any)])] 98 | [#:struct (let-rec expr) ( 99 | [procs : (Listof lam)] 100 | [body : (U expr seq Any)])] 101 | [#:struct (boxenv expr) ( 102 | [pos : Exact-Nonnegative-Integer] 103 | [body : (U expr seq Any)])] 104 | [#:struct (localref expr) ( 105 | [unbox? : Boolean] 106 | [pos : Exact-Nonnegative-Integer] 107 | [clear? : Boolean] 108 | [other-clears? : Boolean] 109 | [type : (U #f 'flonum 'fixnum 'extflonum)])] 110 | [#:struct (toplevel expr) ( 111 | [depth : Exact-Nonnegative-Integer] 112 | [pos : Exact-Nonnegative-Integer] 113 | [const? : Boolean] 114 | [ready? : Boolean])] 115 | [#:struct (application expr) ( 116 | [rator : (U expr seq Any)] 117 | [rands : (Listof (U expr seq Any))])] 118 | [#:struct (branch expr) ( 119 | [test : (U expr seq Any)] 120 | [then : (U expr seq Any)] 121 | [else : (U expr seq Any)])] 122 | [#:struct (with-cont-mark expr) ( 123 | [key : (U expr seq Any)] 124 | [val : (U expr seq Any)] 125 | [body : (U expr seq Any)])] 126 | [#:struct (beg0 expr) ( 127 | [seq : (Listof (U expr seq Any))])] 128 | [#:struct (varref expr) ( 129 | [toplevel : (U toplevel #t #f Symbol)] 130 | [dummy : (U toplevel #f)] 131 | [constant? : Boolean] 132 | [from-unsafe? : Boolean])] 133 | [#:struct (assign expr) ( 134 | [id : toplevel] 135 | [rhs : (U expr seq Any)] 136 | [undef-ok? : Boolean])] 137 | [#:struct (apply-values expr) ( 138 | [proc : (U expr seq Any)] 139 | [args-expr : (U expr seq Any)])] 140 | [#:struct (with-immed-mark expr) ( 141 | [key : (U expr seq Any)] 142 | [def-val : (U expr seq Any)] 143 | [body : (U expr seq Any)])] 144 | [#:struct (primval expr) ([id : Exact-Nonnegative-Integer])] 145 | ) 146 | -------------------------------------------------------------------------------- /zordoz.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | ;; Executing this file starts a new REPL session. 4 | 5 | (module+ main 6 | (require racket/cmdline 7 | racket/pretty 8 | (prefix-in u: zordoz/private/zo-shell)) 9 | ;; -- parameters 10 | (define search-limit (make-parameter #f)) 11 | (define start-repl? (make-parameter #t)) 12 | (define just-print? (make-parameter #f)) 13 | (define to-find (make-parameter '())) 14 | ;; -- helpers 15 | (define (assert-zo filename) 16 | (define offset (- (string-length filename) 3)) 17 | (or (and (positive? offset) 18 | (equal? ".zo" (substring filename offset))) 19 | (and (u:print-usage) 20 | #f))) 21 | ;; -- commandline 22 | (command-line 23 | #:program "zordoz" 24 | #:multi 25 | [("-f" "--find") 26 | f* 27 | "Name of zo structs to find" 28 | (begin 29 | (start-repl? #f) 30 | (to-find (cons f* (to-find))))] 31 | #:once-each 32 | [("-l" "--limit") 33 | l 34 | "Maximum depth to search during --find queries" 35 | (search-limit l)] 36 | [("-p" "--print") 37 | "Just the the parsed zo to STDOUT, do not open a REPL" 38 | (just-print? #t)] 39 | #:args (filename) 40 | (when (assert-zo filename) 41 | (cond 42 | [(just-print?) 43 | (pretty-print (u:filename->zo filename))] 44 | [(start-repl?) 45 | (u:filename->shell filename)] 46 | [else 47 | (u:find-all filename (to-find) #:limit (search-limit))]))) 48 | ) 49 | --------------------------------------------------------------------------------