runner.factor
1 ! Copyright (C) 2023 Aleksander Sabak. 2 ! See https://factorcode.org/license.txt for BSD license. 3 USING: accessors arrays assocs combinators 4 combinators.short-circuit command-line continuations debugger 5 hashtables interpolate kernel make math math.parser namespaces 6 prettyprint splitting strings 7 io io.encodings.utf8 io.files io.pathnames 8 sequences sequences.extras sequences.repeating ; 9 IN: concat-evaluator.runner 10 11 12 ERROR: incorrect-arity operator arity ; 13 14 ERROR: unexpected-symbol symbol ; 15 16 ERROR: unclosed-quotation ; 17 18 ERROR: unclosed-comment ; 19 20 ERROR: non-integer-in-skeleton word ; 21 22 ERROR: no-operator-name ; 23 24 25 : report-error ( error -- ) drop ; 26 ! error-stream get [ print-error ] with-output-stream* ; 27 28 29 TUPLE: concat-eval operators zero succ words expression stack ; 30 31 : <concat-eval> ( ops zero succ words expr -- concat-eval ) 32 V{ } clone concat-eval boa ; 33 34 : expression>string ( expression -- string ) 35 [ dup string? [ expression>string ] unless ] map reverse 36 { "[" } { "]" } surround " " join ; 37 38 : concat-eval>string ( concat-eval -- string ) 39 [ stack>> ] [ expression>> reverse ] bi append 40 [ dup string? [ expression>string ] unless ] map 41 " " join ; 42 43 44 TUPLE: operator arity skeleton ; 45 46 : <operator> ( arity skeleton -- operator ) operator boa ; 47 48 : <skeleton> ( expression -- skeleton ) 49 [ dup string? 50 [ dup string>number 51 [ non-integer-in-skeleton ] unless* nip ] 52 [ <skeleton> ] if ] map ; 53 54 55 : skip-comment ( strings -- rest ) 56 [ dup empty? [ unclosed-comment ] when unclip dup ")" = ] 57 [ "(" = [ skip-comment ] when ] until drop ; 58 59 60 : (parse-expression) ( strings -- rest expression ) 61 V{ } clone swap 62 [ dup empty? [ unclosed-quotation ] when unclip dup "]" = ] 63 [ { { "" [ ] } 64 { "[" [ (parse-expression) pick push ] } 65 { "(" [ skip-comment ] } 66 { ")" [ ")" unexpected-symbol ] } 67 { "--" [ "--" unexpected-symbol ] } 68 [ pick push ] } case ] until drop swap reverse ; 69 70 71 : parse-expression ( strings -- expression ) 72 V{ } clone swap [ dup empty? ] 73 [ unclip 74 { { "" [ ] } 75 { "[" [ (parse-expression) pick push ] } 76 { "]" [ "]" unexpected-symbol ] } 77 { "(" [ skip-comment ] } 78 { ")" [ ")" unexpected-symbol ] } 79 { "--" [ "--" unexpected-symbol ] } 80 [ pick push ] } case ] until drop reverse ; 81 82 83 : ?parse-operator ( string -- {name,operator}? ) 84 " " split harvest 85 [ ?unclip dup string>number dup [ 0 >= swap and ] when* 86 [ swap ?unclip rot incorrect-arity ] unless* 87 nip swap ?unclip [ no-operator-name ] unless* -rot 88 parse-expression <skeleton> <operator> 2array ] 89 [ report-error drop f ] recover ; 90 91 : ?parse-word ( string -- {name,expression}? ) 92 " " split harvest [ ?unclip swap parse-expression 2array ] 93 [ report-error drop f ] recover ; 94 95 96 : parse-operators ( strings -- operators ) 97 [ ?parse-operator ] map sift >hashtable ; 98 99 100 : parse-numbers ( strings -- zero succ ) 101 ?first2 102 [ [ [ " " split parse-expression ] 103 [ report-error drop f ] recover ] [ f ] if* ] bi@ ; 104 105 106 : parse-words ( strings -- words ) 107 [ ?parse-word ] map sift >hashtable ; 108 109 110 : ?parse-expression ( string -- expression ) 111 " " split harvest [ parse-expression ] 112 [ report-error drop V{ } clone ] recover ; 113 114 115 : parse-concat-eval ( string -- concat-eval ) 116 "\n" split { "" } split1 [ parse-operators ] dip 117 { "" } split1 [ parse-numbers ] dip 118 { "" } split1 [ parse-words ] dip 119 " " join ?parse-expression <concat-eval> ; 120 121 122 SYMBOL: args 123 124 125 : fill-skeleton ( skeleton -- expression ) 126 [ [ dup number? [ 1 - args get nth % ] 127 [ fill-skeleton , ] if ] each ] V{ } make ; 128 129 130 : run-operator ( concat-eval name operator -- concat-eval ) 131 swapd over stack>> length over arity>> >= 132 [ over stack>> over arity>> tail* dup [ string? not ] all? 133 [ reverse args set 134 [ arity>> over stack>> swap head* >>stack ] keep 135 skeleton>> fill-skeleton over expression>> push-all nip ] 136 [ 2drop tuck stack>> push ] if ] 137 [ drop tuck stack>> push ] if ; 138 139 140 : step ( concat-eval -- concat-eval ) 141 dup expression>> 142 [ pop 143 { { [ dup string? not ] [ over stack>> push step ] } 144 { [ over operators>> dupd at ] 145 [ over operators>> dupd at run-operator ] } 146 { [ over words>> dupd at ] 147 [ over words>> at over expression>> push-all ] } 148 { [ { [ dup string>number dup [ 0 >= and ] when* ] 149 [ over zero>> ] 150 [ over succ>> ] } 0&& ] 151 [ string>number [ dup succ>> ] dip repeat 152 over expression>> push-all 153 dup zero>> over expression>> push-all ] } 154 { [ { [ dup "0" = ] [ over zero>> ] } 0&& ] 155 [ drop dup zero>> over expression>> push-all ] } 156 [ over stack>> push ] } cond ] unless-empty ; 157 158 159 : run-infinite ( concat-eval -- concat-eval ) 160 [ dup expression>> empty? ] [ step ] until ; 161 162 163 : run-steps ( concat-eval steps -- concat-eval ) 164 [ step ] times ; 165 166 167 : run-file ( steps? file -- ) 168 utf8 [ read-contents ] with-file-reader parse-concat-eval 169 swap [ run-steps ] [ run-infinite ] if* 170 concat-eval>string write ; 171 172 173 : argv[0] ( -- string ) 174 (command-line) command-line get length head* 175 unclip file-name swap " " join " " glue ; 176 177 178 : usage ( -- ) 179 argv[0] "Usage: ${0} [limits] script" interpolate>string print 180 nl 181 " limits : the second to last argument will be used as a limit on the number" 182 print 183 " of steps before terminating evaluation. If it's not a number or if" 184 print 185 " only one parameter is provided the evaluation will run until full" 186 print 187 " reduction." 188 print nl 189 " script : path to a concatenative evaluator file you want to evaluate" 190 print ; 191 192 193 : main ( -- ) 194 command-line get [ usage ] 195 [ [ but-last [ f ] 196 [ last string>number 197 dup [ 0 >= swap and ] when* ] if-empty ] 198 [ last ] bi run-file ] if-empty ; 199 200 201 MAIN: main