├── .github └── workflows │ └── build.yml ├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── arith-test.txt ├── arith.txt ├── default.nix ├── flake.lock ├── flake.nix ├── floop-test.txt ├── floop.fs ├── floop.txt ├── meta-c.txt ├── meta-forth.txt ├── meta.c └── meta.fs /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | name: Build 2 | on: [push, pull_request] 3 | 4 | jobs: 5 | build: 6 | runs-on: ubuntu-latest 7 | steps: 8 | - uses: actions/checkout@v2.3.4 9 | with: 10 | # Nix Flakes doesn't work on shallow clones 11 | fetch-depth: 0 12 | - uses: cachix/install-nix-action@v12 13 | with: 14 | install_url: https://github.com/numtide/nix-flakes-installer/releases/download/nix-2.4pre20201221_9fab14a/install 15 | extra_nix_config: | 16 | experimental-features = nix-command flakes 17 | - run: nix build -L 18 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | result 2 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright © 2020 Siraphob (Ben) Phipathananunth 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the “Software”), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 4 | 5 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 6 | 7 | THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 8 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | CC ?= cc 2 | CFLAGS ?= -O2 3 | out ?= /usr 4 | 5 | all: 6 | $(CC) $(CFLAGS) -o meta meta.c 7 | recomp: meta meta-c.txt 8 | ./meta meta-c.txt meta.c && $(CC) $(CFLAGS) -o meta meta.c && ./meta meta-c.txt meta.c 9 | forth_bootstrap: meta meta-forth.txt 10 | ./meta meta-forth.txt forth.c && $(CC) $(CFLAGS) -o forth forth.c && ./forth meta-forth.txt meta.fs 11 | forth_recomp: meta-forth.txt 12 | gforth meta.fs meta-forth.txt meta.fs 13 | install: 14 | install -Dm755 meta -t $(out)/bin 15 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Self-hosting YACC-like parser generators in Forth and C 2 | ![Build 3 | Status](https://github.com/siraben/meta-yacc/workflows/Build/badge.svg) 4 | 5 | ## Building 6 | ### C 7 | ```ShellSession 8 | $ nix build # with Nix 9 | $ make # without Nix 10 | ``` 11 | ### Forth 12 | ```ShellSession 13 | $ gforth meta.fs meta-forth.txt meta.fs 14 | ``` 15 | ### Regenerate C/Forth code 16 | ```ShellSession 17 | $ make recomp # for C code 18 | $ make forth_recomp # for Forth code 19 | ``` 20 | ## Usage 21 | Suppose one has a grammar file called `my-grammar.txt`: 22 | - Using the Forth parser generator, run `gforth meta.fs my-grammar.txt 23 | my-grammar.fs` 24 | - Using the C parser generator, run `./meta my-grammar.txt 25 | my-grammar.c` 26 | 27 | Check the generated file. Syntax errors will be indicated in the 28 | output file. 29 | ## Example compilers included 30 | ### FlooP language from Gödel, Escher, Bach 31 | The version of FlooP in this repository is differs from the book in 32 | several ways, some of which are (list is subject to change): 33 | - The last statement in a block does not have a semicolon 34 | - Variables must be declared before use 35 | - Comments are allowed only after procedure declarations 36 | - There must be a following block or statement after an `if` statement 37 | (i.e. the `else` clause) 38 | 39 | A FlooP → C compiler is given in `floop.txt`. See `floop-test.txt` 40 | for an example FlooP program that prints out the prime numbers 41 | under 1000. Here's another simple Floop program that produces the 42 | output: 43 | ``` 44 | Hello, world! 45 | Counting up to 10: 1 2 3 4 5 6 7 8 9 10 46 | ``` 47 | ``` 48 | def count (n): 49 | 50 | 'Count up from 1 to n inclusive.' 51 | 52 | begin 53 | int out; 54 | out <- 1; 55 | loop at most n times: 56 | begin 57 | print out; 58 | out <- out + 1 59 | end; 60 | println '' 61 | end 62 | 63 | main 64 | begin 65 | println 'Hello, world!'; 66 | print 'Counting up to 10: '; 67 | do count(10) 68 | end 69 | ``` 70 | Generated C code: 71 | ```c 72 | #include 73 | #include 74 | 75 | int count(int n) { 76 | int out = 0; 77 | do { 78 | out = 1; 79 | for(int i = 0, f = 1; i < n && f; i++) { 80 | do { 81 | printf("%d ",out); 82 | out = out + 1; 83 | } while (0); 84 | } 85 | puts(""); 86 | } while (0); 87 | } 88 | int main(void) { 89 | do { 90 | puts("Hello, world!"); 91 | printf("Counting up to 10: "); 92 | count(10); 93 | } while (0); 94 | } 95 | ``` 96 | ### Convert infix to postfix 97 | Input: 98 | ``` 99 | 29 * 19293 - 129 + (992 * 30 - 10) - (15 * (-15 + 34 * (182 + 3 - 4)) + 382) * 3 + (102 + 239 * 314) - 222 100 | ``` 101 | Output: 102 | ``` 103 | 29 19293 * 129 - 992 30 * 10 - + 15 -15 34 182 3 + 4 - * + * 382 + 3 * - 102 239 314 * + + 222 - 104 | ``` 105 | -------------------------------------------------------------------------------- /arith-test.txt: -------------------------------------------------------------------------------- 1 | 29 * 19293 - 129 + (992 * 30 - 10) - (15 * (-15 + 34 * (182 + 3 - 4)) + 382) * 3 + (102 + 239 * 314) - foo 2 | 3 | -------------------------------------------------------------------------------- /arith.txt: -------------------------------------------------------------------------------- 1 | .syntax [ ex3 ex2 ex1 ] ex1 2 | 3 | ex1 = ex2 $ ( ('+' ex2 < '+ ' > ) 4 | | ('-' ex2 < '- ' > )) ; 5 | 6 | ex2 = ex3 $ ('*' ex3 < '* ' > ) ; 7 | 8 | ex3 = (.id | .number) < * ' ' > | '(' ex1 ')' ; 9 | 10 | 11 | .end 12 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | (import ( 2 | fetchTarball { 3 | url = "https://github.com/edolstra/flake-compat/archive/99f1c2157fba4bfe6211a321fd0ee43199025dbf.tar.gz"; 4 | sha256 = "0x2jn3vrawwv9xp15674wjz9pixwjyj3j771izayl962zziivbx2"; } 5 | ) { 6 | src = ./.; 7 | }).defaultNix 8 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-utils": { 4 | "locked": { 5 | "lastModified": 1610051610, 6 | "narHash": "sha256-U9rPz/usA1/Aohhk7Cmc2gBrEEKRzcW4nwPWMPwja4Y=", 7 | "owner": "numtide", 8 | "repo": "flake-utils", 9 | "rev": "3982c9903e93927c2164caa727cd3f6a0e6d14cc", 10 | "type": "github" 11 | }, 12 | "original": { 13 | "owner": "numtide", 14 | "repo": "flake-utils", 15 | "type": "github" 16 | } 17 | }, 18 | "nixpkgs": { 19 | "locked": { 20 | "lastModified": 1614440148, 21 | "narHash": "sha256-TdlTg4Nel7QUJ4tmm10giL0ZsNMafc7119Bx8u+ui0g=", 22 | "owner": "NixOS", 23 | "repo": "nixpkgs", 24 | "rev": "5240639ab6bc56824302d32e52753725aa9a963d", 25 | "type": "github" 26 | }, 27 | "original": { 28 | "owner": "NixOS", 29 | "repo": "nixpkgs", 30 | "type": "github" 31 | } 32 | }, 33 | "root": { 34 | "inputs": { 35 | "flake-utils": "flake-utils", 36 | "nixpkgs": "nixpkgs" 37 | } 38 | } 39 | }, 40 | "root": "root", 41 | "version": 7 42 | } 43 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "Self-hosting parser generators in Forth and C."; 3 | inputs = { 4 | nixpkgs.url = "github:NixOS/nixpkgs"; 5 | flake-utils.url = "github:numtide/flake-utils"; 6 | }; 7 | 8 | outputs = { self, nixpkgs, flake-utils }: 9 | flake-utils.lib.eachDefaultSystem (system: 10 | with import nixpkgs { inherit system; }; { 11 | defaultPackage = stdenv.mkDerivation { 12 | name = "meta-yacc"; 13 | nativeBuildInputs = [ gforth ]; 14 | src = ./.; 15 | }; 16 | } 17 | ); 18 | } 19 | -------------------------------------------------------------------------------- /floop-test.txt: -------------------------------------------------------------------------------- 1 | def mod(a, b): 2 | 'Compute a (mod b).' 3 | begin 4 | forever: 5 | begin 6 | if a - b < 0, then: return a; 7 | a <- a - b 8 | end 9 | end 10 | 11 | def prime(n): 12 | 'Return 1 if n is prime, 0 if not.' 13 | begin 14 | int j; 15 | if n = 2, then: return 1; 16 | begin 17 | j <- 2; 18 | loop at most n times: 19 | begin 20 | if j * j > n, then: return 1; 21 | if do mod(n, j) = 0, then: return 0; 22 | j <- j + 1 23 | end 24 | end 25 | end 26 | 27 | main 28 | begin 29 | int a; 30 | println 'Primes under 1000'; 31 | a <- 1; 32 | loop at most 1000 times: 33 | begin 34 | a <- a + 1; 35 | if do prime(a), then: print a; 36 | continue 37 | end; 38 | println '' 39 | end 40 | -------------------------------------------------------------------------------- /floop.fs: -------------------------------------------------------------------------------- 1 | variable meta-arglist' 2 | variable meta-arglistp' 3 | variable meta-assignst' 4 | variable meta-block' 5 | variable meta-floop' 6 | variable meta-breakst' 7 | variable meta-callarglist' 8 | variable meta-callarglistp' 9 | variable meta-callexpr' 10 | variable meta-callst' 11 | variable meta-compare' 12 | variable meta-expr' 13 | variable meta-factor' 14 | variable meta-foreverst' 15 | variable meta-ifst' 16 | variable meta-intst' 17 | variable meta-loopst' 18 | variable meta-pmain' 19 | variable meta-printlnst' 20 | variable meta-printst' 21 | variable meta-proc' 22 | variable meta-continuest' 23 | variable meta-returnst' 24 | variable meta-st' 25 | variable meta-term' 26 | 27 | \ input string | string length | token buffer | token length 28 | variable s variable slen 0 value t variable tlen 29 | 30 | \ Current location in string 31 | variable p 0 p ! 32 | 33 | \ Flags 34 | false value flagged? false value newlined? 35 | 36 | \ Indentation level 37 | variable indent 38 | 39 | \ Line counter 40 | variable lines 1 lines ! 41 | 42 | 10 constant \n 9 constant \t 126 constant tilde 43 | 39 constant tick 34 constant dtick 44 | 45 | : set-flag! ( -- ) true to flagged? ; 46 | : unflag! ( -- ) false to flagged? ; 47 | 48 | \ Run a parser, which is a pointer to a word. 49 | : do-parse ( -- ) @ execute ; 50 | 51 | : set-source! ( c-addr u -- ) slen ! s ! ; 52 | : c-array-ref ( a b -- a[b] ) + c@ ; 53 | : isspace ( c -- # ) 54 | dup dup 55 | bl = 56 | swap 57 | \t = 58 | or swap 59 | \n = 60 | or 61 | ; 62 | 63 | : isdelim ( c -- # ) dup tick = swap tilde = or ; 64 | : curr-char ( -- c ) s @ p @ c-array-ref ; 65 | 66 | : advance ( -- ) 1 p +! ; 67 | : inc-lines ( -- ) 1 lines +! ; 68 | 69 | : skip-whitespace ( -- ) 70 | begin curr-char isspace while 71 | curr-char \n = if inc-lines then 72 | advance 73 | repeat 74 | ; 75 | 76 | : ?free ( p|0 -- ) 77 | ?dup-if free if s" failed to free token buffer" exception throw then then 78 | ; 79 | : ?free-token ( -- ) t ?free ; 80 | 81 | : realloc-token ( -- ) 82 | tlen @ 1+ allocate if ." failed to allocate memory for token" then 83 | to t 84 | ; 85 | 86 | : nul-terminate-token ( -- ) 0 t tlen @ + c! ; 87 | : copy-token-from-string ( sp -- ) s @ + t tlen @ cmove ; 88 | 89 | : write-token ( sp -- ) nul-terminate-token copy-token-from-string ; 90 | : calc-token-length ( sp -- sp ) p @ over - tlen ! ; 91 | 92 | \ Make a token up to char sp. 93 | : make-token ( sp -- ) ?free-token calc-token-length realloc-token write-token ; 94 | 95 | \ Emit a character in a string, possibly quoted. 96 | : emit-string-char ( c -- ) 97 | case 98 | \n of .\" \\n" endof 99 | dtick of .\" \\\"" endof 100 | tick of .\" \\\'" endof 101 | [char] \ of .\" \\\\" endof 102 | \ Otherwise, print the character. 103 | dup emit 104 | endcase 105 | ; 106 | 107 | \ Current character from the token buffer. 108 | : tok-char ( -- c ) t c@ ; 109 | 110 | : emit-string ( -- ) 111 | tok-char 112 | tlen @ 1 do 113 | t i c-array-ref 2dup 114 | = if 2drop leave then 115 | emit-string-char 116 | loop 117 | dtick emit 118 | ; 119 | 120 | : emit-token ( -- ) tok-char isdelim if emit-string else t tlen @ type then ; 121 | 122 | 123 | : print-indent ( -- ) indent @ spaces ; 124 | : mtype ( c-addr u -- ) newlined? if print-indent then type 0 to newlined? ; 125 | : emit-newline 1 to newlined? cr ; 126 | 127 | : read-literal ( c-addr u -- ) 128 | { length } 129 | p @ 0 { l e i } 130 | skip-whitespace 131 | 132 | length 0 do 133 | curr-char 0<> 134 | l i c-array-ref 0<> 135 | and 136 | curr-char l i c-array-ref = 137 | and 138 | if 139 | advance 140 | i 1+ to i 141 | else 142 | leave 143 | then 144 | loop 145 | 146 | i length = if 147 | set-flag! 148 | e make-token 149 | else 150 | e p ! unflag! 151 | then 152 | ; 153 | 154 | : isupper ( c -- # ) [char] A [char] Z 1+ within ; 155 | : islower ( c -- # ) [char] a [char] z 1+ within ; 156 | : isalpha ( c -- # ) dup isupper swap islower or ; 157 | 158 | : isdigit ( c -- # ) [char] 0 [char] 9 1+ within ; 159 | : isalnum ( c -- # ) dup isalpha swap isdigit or ; 160 | 161 | : advance-while-alnum ( -- ) begin curr-char isalnum while advance repeat ; 162 | : advance-while-digit ( -- ) begin curr-char isdigit while advance repeat ; 163 | 164 | : read-id ( -- ) 165 | skip-whitespace 166 | p @ 167 | curr-char isalpha if 168 | advance set-flag! 169 | else 170 | unflag! drop exit 171 | then 172 | 173 | advance-while-alnum make-token 174 | ; 175 | 176 | 177 | : read-number ( -- ) 178 | skip-whitespace 179 | p @ 180 | 181 | \ Possibly with a leading dash. 182 | curr-char [char] - = if advance then 183 | 184 | curr-char isdigit if 185 | advance set-flag! 186 | advance-while-digit make-token 187 | else 188 | drop unflag! exit 189 | then 190 | ; 191 | 192 | \ Advance the pointer until the next occurence of c. 193 | : advance-while-<> ( c -- ) 194 | begin dup curr-char <> while 195 | curr-char \n = if inc-lines then 196 | advance 197 | repeat 198 | ; 199 | 200 | : read-string ( -- ) 201 | skip-whitespace 202 | p @ 203 | 204 | curr-char isdelim if 205 | curr-char advance advance-while-<> 206 | 207 | curr-char = if 208 | advance set-flag! make-token 209 | else 210 | \ If we hit the end of the file, backtrack. 211 | curr-char 0= if p ! then 212 | then 213 | else 214 | drop unflag! 215 | then 216 | ; 217 | 218 | : maybe-error 219 | flagged? invert if ( -- ) 220 | ." Error in line " lines ? ." at token '" t tlen @ type ." ' " 221 | ." at character " p @ . cr 222 | s" Parse error" exception throw 223 | then 224 | ; 225 | 226 | \ File ID in | File ID out 227 | 0 value fd-in 0 value fd-out 228 | 229 | : open-input ( addr u -- ) r/o open-file throw to fd-in ; 230 | : open-output ( addr u -- ) w/o create-file throw to fd-out ; 231 | 232 | \ Size of each read. 233 | 1000 1000 * constant blk-size 234 | 235 | \ Current size of the file buffer | Pointer to the file buffer. 236 | 0 value curr-buf-size 0 value file-buffer 237 | 238 | blk-size allocate throw to file-buffer 239 | 240 | \ Read a file, zero-delimited. 241 | : do-read-file ( -- ) 242 | file-buffer blk-size fd-in read-file 243 | if s" failed to read file" exception throw then 244 | dup to curr-buf-size 245 | file-buffer + 0 swap ! 246 | ; 247 | 248 | : close-input ( -- ) fd-in close-file throw ; 249 | : close-output ( -- ) fd-out close-file throw ; 250 | 251 | : set-file-as-input file-buffer curr-buf-size set-source! ; 252 | : print-file file-buffer curr-buf-size type ; 253 | 254 | 255 | : check-args 256 | argc @ 3 <> if s" usage: meta " exception throw then ; 257 | 258 | : process-input-arg ( -- ) 259 | next-arg 2dup ." Input file: " type cr open-input 260 | do-read-file set-file-as-input close-input 261 | ; 262 | 263 | : process-output-arg ( -- ) 264 | next-arg 2dup ." Output file: " type cr open-output ; 265 | 266 | : process-args ( -- ) process-input-arg process-output-arg ; 267 | : start-msg ( -- ) cr ." meta-yacc has started." cr ; 268 | : assert-clean-stack ( -- ) 269 | depth if 270 | s" stack not empty on exit" exception throw 271 | else 272 | cr ." Parsed without errors." cr 273 | then 274 | ; 275 | 276 | : run-meta-program find-name name>int fd-out outfile-execute ; 277 | : main 278 | start-msg check-args process-args 279 | s" meta-floop" run-meta-program 280 | close-output assert-clean-stack bye 281 | ; 282 | meta-arglistp' 283 | : meta-arglistp 284 | 1 0 do 285 | s\" ," read-literal 286 | flagged? if 287 | read-id 288 | maybe-error 289 | s\" , int " mtype 290 | emit-token 291 | then 292 | loop 293 | ; latestxt swap ! 294 | meta-arglist' 295 | : meta-arglist 296 | 1 0 do 297 | s\" (" read-literal 298 | flagged? if 299 | s\" (int " mtype 300 | read-id 301 | maybe-error 302 | emit-token 303 | 0 0 do 304 | 1 0 do 305 | meta-arglistp' do-parse 306 | flagged? if 307 | then 308 | loop 309 | flagged? invert if leave then loop 310 | set-flag! 311 | maybe-error 312 | s\" )" read-literal 313 | maybe-error 314 | s\" :" read-literal 315 | maybe-error 316 | s\" )" mtype 317 | then 318 | loop 319 | ; latestxt swap ! 320 | meta-intst' 321 | : meta-intst 322 | 1 0 do 323 | s\" int" read-literal 324 | flagged? if 325 | read-id 326 | maybe-error 327 | s\" int " mtype 328 | emit-token 329 | s\" = 0;" mtype 330 | emit-newline 331 | then 332 | loop 333 | ; latestxt swap ! 334 | meta-assignst' 335 | : meta-assignst 336 | 1 0 do 337 | read-id 338 | flagged? if 339 | s\" " mtype 340 | emit-token 341 | s\" = " mtype 342 | s\" <-" read-literal 343 | maybe-error 344 | meta-expr' do-parse 345 | maybe-error 346 | s\" ;" mtype 347 | emit-newline 348 | then 349 | loop 350 | ; latestxt swap ! 351 | meta-printst' 352 | : meta-printst 353 | 1 0 do 354 | s\" print" read-literal 355 | flagged? if 356 | 1 0 do 357 | read-id 358 | flagged? if 359 | s\" printf(\"%d \"," mtype 360 | emit-token 361 | s\" );" mtype 362 | emit-newline 363 | then 364 | flagged? if leave then 365 | read-string 366 | flagged? if 367 | s\" printf(\"" mtype 368 | emit-token 369 | s\" );" mtype 370 | emit-newline 371 | then 372 | loop 373 | maybe-error 374 | then 375 | loop 376 | ; latestxt swap ! 377 | meta-printlnst' 378 | : meta-printlnst 379 | 1 0 do 380 | s\" println" read-literal 381 | flagged? if 382 | 1 0 do 383 | read-id 384 | flagged? if 385 | s\" printf(\"%d\\n\"," mtype 386 | emit-token 387 | s\" );" mtype 388 | emit-newline 389 | then 390 | flagged? if leave then 391 | read-string 392 | flagged? if 393 | s\" puts(\"" mtype 394 | emit-token 395 | s\" );" mtype 396 | emit-newline 397 | then 398 | loop 399 | maybe-error 400 | then 401 | loop 402 | ; latestxt swap ! 403 | meta-ifst' 404 | : meta-ifst 405 | 1 0 do 406 | s\" if" read-literal 407 | flagged? if 408 | s\" " mtype 409 | s\" if (" mtype 410 | meta-expr' do-parse 411 | maybe-error 412 | s\" ) {" mtype 413 | emit-newline 414 | 2 indent +! 415 | maybe-error 416 | s\" ," read-literal 417 | maybe-error 418 | s\" then" read-literal 419 | maybe-error 420 | s\" :" read-literal 421 | maybe-error 422 | meta-st' do-parse 423 | maybe-error 424 | s\" ;" read-literal 425 | maybe-error 426 | -2 indent +! 427 | maybe-error 428 | s\" } else { " mtype 429 | emit-newline 430 | 2 indent +! 431 | maybe-error 432 | meta-st' do-parse 433 | maybe-error 434 | -2 indent +! 435 | maybe-error 436 | s\" }" mtype 437 | emit-newline 438 | then 439 | loop 440 | ; latestxt swap ! 441 | meta-continuest' 442 | : meta-continuest 443 | 1 0 do 444 | s\" continue" read-literal 445 | flagged? if 446 | s\" continue;" mtype 447 | emit-newline 448 | then 449 | loop 450 | ; latestxt swap ! 451 | meta-breakst' 452 | : meta-breakst 453 | 1 0 do 454 | s\" break" read-literal 455 | flagged? if 456 | s\" f = 0;" mtype 457 | emit-newline 458 | then 459 | loop 460 | ; latestxt swap ! 461 | meta-loopst' 462 | : meta-loopst 463 | 1 0 do 464 | s\" loop" read-literal 465 | flagged? if 466 | s\" at" read-literal 467 | maybe-error 468 | s\" most" read-literal 469 | maybe-error 470 | s\" " mtype 471 | s\" for(int i = 0, f = 1; i < " mtype 472 | meta-expr' do-parse 473 | maybe-error 474 | s\" && f; i++) {" mtype 475 | emit-newline 476 | 2 indent +! 477 | maybe-error 478 | s\" times" read-literal 479 | maybe-error 480 | s\" :" read-literal 481 | maybe-error 482 | meta-block' do-parse 483 | maybe-error 484 | -2 indent +! 485 | maybe-error 486 | s\" }" mtype 487 | emit-newline 488 | then 489 | loop 490 | ; latestxt swap ! 491 | meta-foreverst' 492 | : meta-foreverst 493 | 1 0 do 494 | s\" forever" read-literal 495 | flagged? if 496 | s\" :" read-literal 497 | maybe-error 498 | s\" {" mtype 499 | emit-newline 500 | 2 indent +! 501 | maybe-error 502 | s\" int f = 1;" mtype 503 | emit-newline 504 | s\" " mtype 505 | s\" while(1 && f)" mtype 506 | s\" {" mtype 507 | emit-newline 508 | 2 indent +! 509 | maybe-error 510 | meta-block' do-parse 511 | maybe-error 512 | -2 indent +! 513 | maybe-error 514 | s\" }" mtype 515 | emit-newline 516 | -2 indent +! 517 | maybe-error 518 | s\" }" mtype 519 | emit-newline 520 | then 521 | loop 522 | ; latestxt swap ! 523 | meta-st' 524 | : meta-st 525 | 1 0 do 526 | meta-printlnst' do-parse 527 | flagged? if 528 | then 529 | flagged? if leave then 530 | meta-printst' do-parse 531 | flagged? if 532 | then 533 | flagged? if leave then 534 | meta-ifst' do-parse 535 | flagged? if 536 | then 537 | flagged? if leave then 538 | meta-loopst' do-parse 539 | flagged? if 540 | then 541 | flagged? if leave then 542 | meta-foreverst' do-parse 543 | flagged? if 544 | then 545 | flagged? if leave then 546 | meta-continuest' do-parse 547 | flagged? if 548 | then 549 | flagged? if leave then 550 | meta-breakst' do-parse 551 | flagged? if 552 | then 553 | flagged? if leave then 554 | meta-block' do-parse 555 | flagged? if 556 | then 557 | flagged? if leave then 558 | meta-returnst' do-parse 559 | flagged? if 560 | then 561 | flagged? if leave then 562 | meta-callst' do-parse 563 | flagged? if 564 | then 565 | flagged? if leave then 566 | meta-assignst' do-parse 567 | flagged? if 568 | then 569 | loop 570 | ; latestxt swap ! 571 | meta-block' 572 | : meta-block 573 | 1 0 do 574 | s\" begin" read-literal 575 | flagged? if 576 | 0 0 do 577 | 1 0 do 578 | meta-intst' do-parse 579 | flagged? if 580 | s\" ;" read-literal 581 | maybe-error 582 | then 583 | loop 584 | flagged? invert if leave then loop 585 | set-flag! 586 | maybe-error 587 | s\" do {" mtype 588 | emit-newline 589 | 2 indent +! 590 | maybe-error 591 | meta-st' do-parse 592 | maybe-error 593 | 0 0 do 594 | 1 0 do 595 | s\" ;" read-literal 596 | flagged? if 597 | meta-st' do-parse 598 | maybe-error 599 | then 600 | loop 601 | flagged? invert if leave then loop 602 | set-flag! 603 | maybe-error 604 | -2 indent +! 605 | maybe-error 606 | s\" } while (0);" mtype 607 | emit-newline 608 | s\" end" read-literal 609 | maybe-error 610 | then 611 | loop 612 | ; latestxt swap ! 613 | meta-proc' 614 | : meta-proc 615 | 1 0 do 616 | s\" def" read-literal 617 | flagged? if 618 | read-id 619 | maybe-error 620 | s\" int " mtype 621 | emit-token 622 | meta-arglist' do-parse 623 | maybe-error 624 | s\" {" mtype 625 | emit-newline 626 | 2 indent +! 627 | maybe-error 628 | 0 0 do 629 | 1 0 do 630 | read-string 631 | flagged? if 632 | then 633 | loop 634 | flagged? invert if leave then loop 635 | set-flag! 636 | maybe-error 637 | meta-block' do-parse 638 | maybe-error 639 | -2 indent +! 640 | maybe-error 641 | s\" }" mtype 642 | emit-newline 643 | then 644 | loop 645 | ; latestxt swap ! 646 | meta-pmain' 647 | : meta-pmain 648 | 1 0 do 649 | s\" main" read-literal 650 | flagged? if 651 | s\" int main(void) {" mtype 652 | emit-newline 653 | 2 indent +! 654 | maybe-error 655 | meta-block' do-parse 656 | maybe-error 657 | -2 indent +! 658 | maybe-error 659 | s\" }" mtype 660 | emit-newline 661 | then 662 | loop 663 | ; latestxt swap ! 664 | meta-expr' 665 | : meta-expr 666 | 1 0 do 667 | meta-factor' do-parse 668 | flagged? if 669 | 0 0 do 670 | 1 0 do 671 | 1 0 do 672 | s\" +" read-literal 673 | flagged? if 674 | s\" + " mtype 675 | meta-factor' do-parse 676 | maybe-error 677 | then 678 | loop 679 | flagged? if 680 | then 681 | flagged? if leave then 682 | 1 0 do 683 | s\" -" read-literal 684 | flagged? if 685 | s\" - " mtype 686 | meta-factor' do-parse 687 | maybe-error 688 | then 689 | loop 690 | flagged? if 691 | then 692 | loop 693 | flagged? invert if leave then loop 694 | set-flag! 695 | maybe-error 696 | then 697 | loop 698 | ; latestxt swap ! 699 | meta-term' 700 | : meta-term 701 | 1 0 do 702 | meta-callexpr' do-parse 703 | flagged? if 704 | then 705 | flagged? if leave then 706 | 1 0 do 707 | read-id 708 | flagged? if 709 | then 710 | flagged? if leave then 711 | read-number 712 | flagged? if 713 | then 714 | loop 715 | flagged? if 716 | emit-token 717 | then 718 | flagged? if leave then 719 | s\" (" read-literal 720 | flagged? if 721 | s\" (" mtype 722 | meta-expr' do-parse 723 | maybe-error 724 | s\" )" read-literal 725 | maybe-error 726 | s\" )" mtype 727 | then 728 | loop 729 | ; latestxt swap ! 730 | meta-compare' 731 | : meta-compare 732 | 1 0 do 733 | meta-term' do-parse 734 | flagged? if 735 | 0 0 do 736 | 1 0 do 737 | 1 0 do 738 | s\" <" read-literal 739 | flagged? if 740 | s\" < " mtype 741 | meta-term' do-parse 742 | maybe-error 743 | then 744 | loop 745 | flagged? if 746 | then 747 | flagged? if leave then 748 | 1 0 do 749 | s\" >" read-literal 750 | flagged? if 751 | s\" > " mtype 752 | meta-term' do-parse 753 | maybe-error 754 | then 755 | loop 756 | flagged? if 757 | then 758 | flagged? if leave then 759 | 1 0 do 760 | s\" =" read-literal 761 | flagged? if 762 | s\" == " mtype 763 | meta-term' do-parse 764 | maybe-error 765 | then 766 | loop 767 | flagged? if 768 | then 769 | flagged? if leave then 770 | 1 0 do 771 | s\" >=" read-literal 772 | flagged? if 773 | s\" >=" mtype 774 | meta-term' do-parse 775 | maybe-error 776 | then 777 | loop 778 | flagged? if 779 | then 780 | flagged? if leave then 781 | 1 0 do 782 | s\" <=" read-literal 783 | flagged? if 784 | s\" <=" mtype 785 | meta-term' do-parse 786 | maybe-error 787 | then 788 | loop 789 | flagged? if 790 | then 791 | loop 792 | flagged? invert if leave then loop 793 | set-flag! 794 | maybe-error 795 | then 796 | loop 797 | ; latestxt swap ! 798 | meta-factor' 799 | : meta-factor 800 | 1 0 do 801 | meta-compare' do-parse 802 | flagged? if 803 | 0 0 do 804 | 1 0 do 805 | s\" *" read-literal 806 | flagged? if 807 | s\" * " mtype 808 | meta-compare' do-parse 809 | maybe-error 810 | then 811 | loop 812 | flagged? invert if leave then loop 813 | set-flag! 814 | maybe-error 815 | then 816 | loop 817 | ; latestxt swap ! 818 | meta-callarglistp' 819 | : meta-callarglistp 820 | 1 0 do 821 | s\" ," read-literal 822 | flagged? if 823 | s\" , " mtype 824 | meta-expr' do-parse 825 | maybe-error 826 | then 827 | loop 828 | ; latestxt swap ! 829 | meta-callarglist' 830 | : meta-callarglist 831 | 1 0 do 832 | s\" (" read-literal 833 | flagged? if 834 | s\" (" mtype 835 | meta-expr' do-parse 836 | maybe-error 837 | 0 0 do 838 | 1 0 do 839 | meta-callarglistp' do-parse 840 | flagged? if 841 | then 842 | loop 843 | flagged? invert if leave then loop 844 | set-flag! 845 | maybe-error 846 | s\" )" read-literal 847 | maybe-error 848 | s\" )" mtype 849 | then 850 | loop 851 | ; latestxt swap ! 852 | meta-callst' 853 | : meta-callst 854 | 1 0 do 855 | s\" do" read-literal 856 | flagged? if 857 | read-id 858 | maybe-error 859 | s\" " mtype 860 | emit-token 861 | meta-callarglist' do-parse 862 | maybe-error 863 | s\" ;" mtype 864 | emit-newline 865 | then 866 | loop 867 | ; latestxt swap ! 868 | meta-returnst' 869 | : meta-returnst 870 | 1 0 do 871 | s\" return" read-literal 872 | flagged? if 873 | s\" " mtype 874 | s\" return " mtype 875 | meta-expr' do-parse 876 | maybe-error 877 | s\" ;" mtype 878 | emit-newline 879 | then 880 | loop 881 | ; latestxt swap ! 882 | meta-callexpr' 883 | : meta-callexpr 884 | 1 0 do 885 | s\" do" read-literal 886 | flagged? if 887 | read-id 888 | maybe-error 889 | s\" " mtype 890 | emit-token 891 | meta-callarglist' do-parse 892 | maybe-error 893 | then 894 | loop 895 | ; latestxt swap ! 896 | meta-floop' 897 | : meta-floop 898 | 1 0 do 899 | s\" #include \n#include \n" mtype 900 | emit-newline 901 | true if 902 | 0 0 do 903 | 1 0 do 904 | meta-proc' do-parse 905 | flagged? if 906 | then 907 | flagged? if leave then 908 | read-string 909 | flagged? if 910 | then 911 | loop 912 | flagged? invert if leave then loop 913 | set-flag! 914 | maybe-error 915 | meta-pmain' do-parse 916 | maybe-error 917 | then 918 | loop 919 | ; latestxt swap ! 920 | main 921 | -------------------------------------------------------------------------------- /floop.txt: -------------------------------------------------------------------------------- 1 | .syntax [ arglist arglistp assignst block floop breakst callarglist 2 | callarglistp callexpr callst compare expr factor foreverst 3 | ifst intst loopst pmain printlnst printst proc continuest 4 | returnst st term ] floop 5 | 6 | arglistp = ',' .id < ', int ' * > ; 7 | arglist = '(' < '(int ' > .id < * > $(arglistp) ')' ':' < ')' > ; 8 | 9 | intst = 'int' .id { 'int ' * ' = 0;' } ; 10 | 11 | assignst = .id < '' * ' = ' > '<-' expr { ';' } ; 12 | 13 | printst = 'print' (.id { 'printf("%d ",' * ');' } 14 | | .string { 'printf("' * ');' }) ; 15 | 16 | printlnst = 'println' (.id { 'printf("%d\n",' * ');' } 17 | | .string { 'puts("' * ');' }) ; 18 | 19 | 20 | ifst = 'if' < '' 'if (' > 21 | expr { ') {' } .lm+ 22 | ',' 'then' ':' 23 | st ';' .lm- { '} else { ' } .lm+ 24 | st .lm- { '}' } ; 25 | 26 | continuest = 'continue' { 'continue;' } ; 27 | breakst = 'break' { 'f = 0;' } ; 28 | 29 | loopst = 'loop' 'at' 'most' < '' 'for(int i = 0, f = 1; i < ' > 30 | expr { ' && f; i++) {' } .lm+ 31 | 'times' ':' 32 | block 33 | .lm- { '}' } ; 34 | 35 | foreverst = 'forever' ':' 36 | { '{' } .lm+ 37 | { 'int f = 1;' } < '' 'while(1 && f)' > { ' {' } .lm+ 38 | block 39 | .lm- { '}' } 40 | .lm- { '}' } ; 41 | 42 | st = printlnst | printst | ifst | loopst | foreverst | continuest | 43 | breakst | block | returnst | callst | assignst ; 44 | 45 | block = 'begin' 46 | $(intst ';' ) 47 | { 'do {' } .lm+ st $(';' st) .lm- { '} while (0);' } 48 | 'end' ; 49 | 50 | proc = 'def' .id < 'int ' * > arglist { ' {' } .lm+ 51 | $(.string) 52 | block 53 | .lm- { '}' } ; 54 | 55 | pmain = 'main' { 'int main(void) {' } .lm+ block .lm- { '}' } ; 56 | 57 | expr = factor $ (('+' < ' + ' > factor) 58 | | ('-' < ' - ' > factor)) ; 59 | 60 | term = callexpr 61 | | (.id | .number) < * > 62 | | '(' < '(' > expr ')' < ')' > ; 63 | 64 | compare = term $ (('<' < ' < ' > term) 65 | | ('>' < ' > ' > term) 66 | | ('=' < ' == ' > term) 67 | | ('>=' < ' >=' > term) 68 | | ('<=' < ' <=' > term)) ; 69 | 70 | factor = compare $ ('*' < ' * ' > compare) ; 71 | 72 | callarglistp = ',' < ', ' > expr ; 73 | callarglist = '(' < '(' > expr $(callarglistp) ')' < ')' > ; 74 | 75 | callst = 'do' .id < '' * > callarglist { ';' } ; 76 | 77 | returnst = 'return' < '' 'return ' > expr { ';' } ; 78 | 79 | callexpr = 'do' .id < '' * > callarglist ; 80 | 81 | floop = { 82 | '#include 83 | #include 84 | ' } 85 | $(proc | .string) pmain ; 86 | 87 | .end 88 | -------------------------------------------------------------------------------- /meta-c.txt: -------------------------------------------------------------------------------- 1 | .syntax [ program exp1 exp3 arg output exp2 exp1 2 | comment stat support declist main ] program 3 | 4 | arg = '*1' { 'emit_label_a();' } { 'll &= 2;' } 5 | | '*2' { 'emit_label_b();' } { 'll &= 1;' } 6 | | '*' { 'emit_token();' } 7 | | .string { 'emit(' * ');' }; 8 | 9 | output = ('{' $ arg '}' { 'emit_newline();' } | '<' $ arg '>' ) ; 10 | 11 | exp3 = .id { 'meta_' * '();' } 12 | | .string { 'read_literal(' * ');' } 13 | | '.id' { 'read_id();' } 14 | | '.number' { 'read_number();' } 15 | | '.string' { 'read_string();' } 16 | | '.lm+' { 'indent += 2;' } 17 | | '.lm-' { 'indent -= 2;' } 18 | | '(' exp1 ')' 19 | | '.e' { 'flag = 1;' } 20 | | '$' { 'do {' } .lm+ 21 | exp3 .lm- {'} while (flag);' } 22 | { 'flag = 1;' }; 23 | 24 | exp2 = ( exp3 { 'if (flag) {' } | output { 'if (1) {' } ) .lm+ 25 | $( exp3 { 'maybe_error();' } | output ) 26 | .lm- { '}' } ; 27 | 28 | exp1 = { 'do {' } .lm+ exp2 29 | $( '|' { 'if (flag) { break; }' } exp2 ) 30 | .lm- { '} while (0);' } ; 31 | 32 | comment = '[' .string ']' ; 33 | stat = .id { 'void meta_' * '() {' } .lm+ 34 | '=' exp1 ';' 35 | .lm- { '}' } { } 36 | | comment ; 37 | 38 | support = {~ 39 | // Output name, input string, token 40 | char *on, *s, *t; 41 | // Output 42 | FILE *o; 43 | // Labels 44 | int ac, bc; 45 | // Label locks 46 | int ll = 3; 47 | // Current location in string, flag, indentation level, newline flag 48 | int p, flag, indent, nl; 49 | // Line counter 50 | int line = 1; 51 | 52 | void skip_whitespace() { 53 | while (isspace(s[p])) { 54 | if (s[p] == '\n') { 55 | line++; 56 | } 57 | p++; 58 | } 59 | } 60 | 61 | void make_token(int sp) { 62 | int length = p - sp; 63 | free(t); 64 | t = malloc(length + 1); 65 | t[length] = 0; 66 | memcpy(t, &s[sp], length); 67 | } 68 | 69 | void emit_token() { 70 | int i; 71 | char d; 72 | // We introduce a new quoting operator, the tilde, which can quote 73 | // single quotes. In this way, we don't need an escape character. 74 | if (t[0] == '\'' || t[0] == '~'~'~') { 75 | d = t[0]; 76 | fprintf(o, "\""); 77 | for (i = 1; t[i] && t[i] != d; i++) { 78 | switch (t[i]) { 79 | case '\n': 80 | fprintf(o, "\\n"); 81 | break; 82 | case '\"': 83 | fprintf(o, "\\\""); 84 | break; 85 | case '\'': 86 | fprintf(o, "\\\'"); 87 | break; 88 | case '\\': 89 | fprintf(o, "\\\\"); 90 | break; 91 | default: 92 | fprintf(o, "%c", t[i]); 93 | break; 94 | } 95 | } 96 | fprintf(o, "\""); 97 | return; 98 | } 99 | fprintf(o, "%s", t); 100 | } 101 | 102 | void emit(const char *s) { 103 | // fprintf(o, "%s", s); 104 | fprintf(o, "%*s%s", nl ? indent : 0, "", s); 105 | nl = 0; 106 | } 107 | 108 | void emit_label_a() { 109 | ac += (ll & 1); 110 | fprintf(o, "a%02d ", ac); 111 | } 112 | 113 | void emit_label_b() { 114 | bc += (ll & 2) >> 1; 115 | fprintf(o, "b%02d ", bc); 116 | } 117 | 118 | void unlock_labels() { 119 | ll = 3; 120 | } 121 | 122 | void emit_newline() { 123 | nl = 1; 124 | fprintf(o, "\n"); 125 | } 126 | 127 | void read_literal(const char *l) { 128 | int e, i; 129 | skip_whitespace(); 130 | e = p; 131 | i = 0; 132 | while (s[p] && l[i] && s[p] == l[i]) { 133 | p++; 134 | i++; 135 | } 136 | if (!l[i]) { 137 | flag = 1; 138 | make_token(e); 139 | } else { 140 | p = e; 141 | flag = 0; 142 | } 143 | } 144 | 145 | void read_id() { 146 | int e; 147 | skip_whitespace(); 148 | e = p; 149 | if (isalpha(s[p])) { 150 | p++; 151 | flag = 1; 152 | } else { 153 | flag = 0; 154 | return; 155 | } 156 | while (isalnum(s[p])) { 157 | p++; 158 | } 159 | make_token(e); 160 | } 161 | 162 | void read_number() { 163 | int e; 164 | skip_whitespace(); 165 | e = p; 166 | if (s[p] == '-') { 167 | p++; 168 | } 169 | if (isdigit(s[p])) { 170 | p++; 171 | flag = 1; 172 | } else { 173 | flag = 0; 174 | return; 175 | } 176 | while (isdigit(s[p])) { 177 | p++; 178 | } 179 | make_token(e); 180 | } 181 | 182 | void read_string() { 183 | int e; 184 | char delim; 185 | skip_whitespace(); 186 | e = p; 187 | if (s[p] == '\'' || s[p] == '~'~'~') { 188 | delim = s[p++]; 189 | while (s[p] && s[p] != delim) { 190 | if (s[p] == '\n') { 191 | line++; 192 | } 193 | p++; 194 | } 195 | if (s[p] == delim) { 196 | p++; 197 | flag = 1; 198 | make_token(e); 199 | } else if (!s[p]) { 200 | p = e; 201 | flag = 0; 202 | } 203 | } else { 204 | flag = 0; 205 | return; 206 | } 207 | } 208 | 209 | void maybe_error() { 210 | if (!flag) { 211 | fprintf(stderr, "Error in line %i at token '%s'\n", line, t); 212 | fclose(o); 213 | remove(on); 214 | free(s); 215 | free(t); 216 | exit(1); 217 | } 218 | } 219 | ~} ; 220 | 221 | declist = { 222 | ~#include 223 | #include 224 | #include 225 | #include 226 | ~ 227 | } '[' $ (.id {'void meta_' * '();' } ) ']' ; 228 | 229 | main = .id { 230 | ~int main(int argc, char *argv[]) { 231 | FILE *input; 232 | int length; 233 | 234 | if (argc < 3) { 235 | fprintf(stderr, "usage: meta \n"); 236 | exit(1); 237 | } 238 | input = fopen(argv[1], "r"); 239 | if (!input) { 240 | fprintf(stderr, "invalid input file\n"); 241 | exit(1); 242 | } 243 | on = argv[2]; 244 | o = fopen(on, "w"); 245 | if (!o) { 246 | fprintf(stderr, "invalid output file\n"); 247 | exit(1); 248 | } 249 | fseek(input, 0, SEEK_END); 250 | length = (int)ftell(input); 251 | fseek(input, 0, SEEK_SET); 252 | s = malloc(length + 1); 253 | fread(s, 1, length, input); 254 | s[length] = 0; 255 | fclose(input); 256 | 257 | t = malloc(1); 258 | t[0] = 0; 259 | 260 | meta_~ * ~(); 261 | 262 | skip_whitespace(); 263 | if (p == strlen(s)) { 264 | fprintf(stdout, "Fully parsed %d characters.\n", p); 265 | } else { 266 | fprintf(stderr, "%d/%d characters processed\n", p, strlen(s)); 267 | } 268 | 269 | fclose(o); 270 | free(s); 271 | free(t); 272 | return 0; 273 | }~} ; 274 | 275 | program = '.syntax' declist support main $ stat '.end'; 276 | 277 | .end 278 | -------------------------------------------------------------------------------- /meta-forth.txt: -------------------------------------------------------------------------------- 1 | .syntax [ program exp1 exp3 arg output exp2 exp1 2 | comment stat support declist main ] program 3 | 4 | arg = '*' { 'emit-token' } 5 | | .string { 's\" ' * ' mtype' }; 6 | 7 | output = ('{' $ arg '}' { 'emit-newline' } | '<' $ arg '>' ) ; 8 | 9 | exp3 = .id { 'meta-' * ~' do-parse~ } 10 | | .string { 's\" ' * ' read-literal' } 11 | | '.id' { 'read-id' } 12 | | '.number' { 'read-number' } 13 | | '.string' { 'read-string' } 14 | | '.lm+' { '2 indent +!' } 15 | | '.lm-' { '-2 indent +!' } 16 | | '(' exp1 ')' 17 | | '.e' { 'set-flag!' } 18 | | '$' { '0 0 do' } .lm+ 19 | exp3 .lm- {'flagged? invert if leave then loop' } 20 | { 'set-flag!' }; 21 | 22 | exp2 = ( exp3 { 'flagged? if' } | output { 'true if' } ) .lm+ 23 | $( exp3 { 'maybe-error' } | output ) 24 | .lm- { 'then' } ; 25 | 26 | exp1 = { '1 0 do' } .lm+ exp2 27 | $( '|' { 'flagged? if leave then' } exp2 ) 28 | .lm- { 'loop' } ; 29 | 30 | comment = '[' .string ']' ; 31 | stat = .id 32 | { 'meta-' * ~'~ } 33 | { ': meta-' * } 34 | .lm+ '=' exp1 ';' 35 | .lm- { '; latestxt swap ! ' } 36 | | comment ; 37 | 38 | support = {~ 39 | \ input string | string length | token buffer | token length 40 | variable s variable slen 0 value t variable tlen 41 | 42 | \ Current location in string 43 | variable p 0 p ! 44 | 45 | \ Flags 46 | false value flagged? false value newlined? 47 | 48 | \ Indentation level 49 | variable indent 50 | 51 | \ Line counter 52 | variable lines 1 lines ! 53 | 54 | 10 constant \n 9 constant \t 126 constant tilde 55 | 39 constant tick 34 constant dtick 56 | 57 | : set-flag! ( -- ) true to flagged? ; 58 | : unflag! ( -- ) false to flagged? ; 59 | 60 | \ Run a parser, which is a pointer to a word. 61 | : do-parse ( -- ) @ execute ; 62 | 63 | : set-source! ( c-addr u -- ) slen ! s ! ; 64 | : c-array-ref ( a b -- a[b] ) + c@ ; 65 | : isspace ( c -- # ) bl over = over \t = or swap \n = or ; 66 | 67 | : isdelim ( c -- # ) dup tick = swap tilde = or ; 68 | : curr-char ( -- c ) s @ p @ c-array-ref ; 69 | 70 | : advance ( -- ) 1 p +! ; 71 | : inc-lines ( -- ) 1 lines +! ; 72 | 73 | : skip-whitespace ( -- ) 74 | begin curr-char isspace while 75 | curr-char \n = negate lines +! advance 76 | repeat 77 | ; 78 | 79 | : ?free ( p|0 -- ) 80 | ?dup-if free if s" failed to free token buffer" exception throw then then 81 | ; 82 | : ?free-token ( -- ) t ?free ; 83 | 84 | : realloc-token ( -- ) 85 | tlen @ 1+ allocate if ." failed to allocate memory for token" then 86 | to t 87 | ; 88 | 89 | : nul-terminate-token ( -- ) 0 t tlen @ + c! ; 90 | : copy-token-from-string ( sp -- ) s @ + t tlen @ cmove ; 91 | 92 | : write-token ( sp -- ) nul-terminate-token copy-token-from-string ; 93 | : calc-token-length ( sp -- sp ) p @ over - tlen ! ; 94 | 95 | \ Make a token up to char sp. 96 | : make-token ( sp -- ) ?free-token calc-token-length realloc-token write-token ; 97 | 98 | \ Emit a character in a string, possibly quoted. 99 | : emit-string-char ( c -- ) 100 | case 101 | \n of .\" \\n" endof 102 | dtick of .\" \\\"" endof 103 | tick of .\" \\\'" endof 104 | [char] \ of .\" \\\\" endof 105 | \ Otherwise, print the character. 106 | dup emit 107 | endcase 108 | ; 109 | 110 | \ Current character from the token buffer. 111 | : tok-char ( -- c ) t c@ ; 112 | 113 | : emit-string ( -- ) 114 | tok-char 115 | tlen @ 1 do 116 | t i c-array-ref 2dup 117 | = if 2drop leave then 118 | emit-string-char 119 | loop 120 | dtick emit 121 | ; 122 | 123 | : emit-token ( -- ) tok-char isdelim if emit-string else t tlen @ type then ; 124 | 125 | 126 | : print-indent ( -- ) indent @ spaces ; 127 | : mtype ( c-addr u -- ) newlined? if print-indent then type 0 to newlined? ; 128 | : emit-newline 1 to newlined? cr ; 129 | 130 | : read-literal ( c-addr u -- ) 131 | { length } 132 | p @ 0 { l e i } 133 | skip-whitespace 134 | 135 | length 0 do 136 | curr-char 0<> 137 | l i c-array-ref 0<> 138 | and 139 | curr-char l i c-array-ref = 140 | and 141 | if 142 | advance 143 | i 1+ to i 144 | else 145 | leave 146 | then 147 | loop 148 | 149 | i length = if 150 | set-flag! 151 | e make-token 152 | else 153 | e p ! unflag! 154 | then 155 | ; 156 | 157 | : isupper ( c -- # ) [char] A [char] Z 1+ within ; 158 | : islower ( c -- # ) [char] a [char] z 1+ within ; 159 | : isalpha ( c -- # ) dup isupper swap islower or ; 160 | 161 | : isdigit ( c -- # ) [char] 0 [char] 9 1+ within ; 162 | : isalnum ( c -- # ) dup isalpha swap isdigit or ; 163 | 164 | : advance-while-alnum ( -- ) begin curr-char isalnum while advance repeat ; 165 | : advance-while-digit ( -- ) begin curr-char isdigit while advance repeat ; 166 | 167 | : read-id ( -- ) 168 | skip-whitespace 169 | p @ 170 | curr-char isalpha if 171 | advance set-flag! 172 | else 173 | unflag! drop exit 174 | then 175 | 176 | advance-while-alnum make-token 177 | ; 178 | 179 | 180 | : read-number ( -- ) 181 | skip-whitespace 182 | p @ 183 | 184 | \ Possibly with a leading dash. 185 | curr-char [char] - = if advance then 186 | 187 | curr-char isdigit if 188 | advance set-flag! 189 | advance-while-digit make-token 190 | else 191 | drop unflag! exit 192 | then 193 | ; 194 | 195 | \ Advance the pointer until the next occurence of c. 196 | : advance-while-<> ( c -- ) 197 | begin dup curr-char <> while 198 | curr-char \n = if inc-lines then 199 | advance 200 | repeat 201 | ; 202 | 203 | : read-string ( -- ) 204 | skip-whitespace 205 | p @ 206 | 207 | curr-char isdelim if 208 | curr-char advance advance-while-<> 209 | 210 | curr-char = if 211 | advance set-flag! make-token 212 | else 213 | \ If we hit the end of the file, backtrack. 214 | curr-char 0= if p ! then 215 | then 216 | else 217 | drop unflag! 218 | then 219 | ; 220 | 221 | : maybe-error 222 | flagged? invert if ( -- ) 223 | ." Error in line " lines ? ." at token '" t tlen @ type ." ' " 224 | ." at character " p @ . cr 225 | s" Parse error" exception throw 226 | then 227 | ; 228 | 229 | \ File ID in | File ID out 230 | 0 value fd-in 0 value fd-out 231 | 232 | : open-input ( addr u -- ) r/o open-file throw to fd-in ; 233 | : open-output ( addr u -- ) w/o create-file throw to fd-out ; 234 | 235 | \ Size of each read. 236 | 1000 1000 * constant blk-size 237 | 238 | \ Current size of the file buffer | Pointer to the file buffer. 239 | 0 value curr-buf-size 0 value file-buffer 240 | 241 | blk-size allocate throw to file-buffer 242 | 243 | \ Read a file, zero-delimited. 244 | : do-read-file ( -- ) 245 | file-buffer blk-size fd-in read-file 246 | if s" failed to read file" exception throw then 247 | dup to curr-buf-size 248 | file-buffer + 0 swap ! 249 | ; 250 | 251 | : close-input ( -- ) fd-in close-file throw ; 252 | : close-output ( -- ) fd-out close-file throw ; 253 | 254 | : set-file-as-input file-buffer curr-buf-size set-source! ; 255 | : print-file file-buffer curr-buf-size type ; 256 | ~} ; 257 | 258 | declist = '[' $ (.id {'variable meta-' * ~'~} ) ']' ; 259 | 260 | main = .id { 261 | ~ 262 | : check-args 263 | argc @ 3 <> if s" usage: meta " exception throw then ; 264 | 265 | : process-input-arg ( -- ) 266 | next-arg 2dup ." Input file: " type cr open-input 267 | do-read-file set-file-as-input close-input 268 | ; 269 | 270 | : process-output-arg ( -- ) 271 | next-arg 2dup ." Output file: " type cr open-output ; 272 | 273 | : process-args ( -- ) process-input-arg process-output-arg ; 274 | : start-msg ( -- ) cr ." meta-yacc has started." cr ; 275 | : assert-clean-stack ( -- ) 276 | depth if 277 | s" stack not empty on exit" exception throw 278 | else 279 | cr ." Parsed without errors." cr 280 | then 281 | ; 282 | 283 | : run-meta-program find-name name>int fd-out outfile-execute ; 284 | : main 285 | start-msg check-args process-args 286 | s" meta-~ * ~" run-meta-program 287 | close-output assert-clean-stack bye 288 | ;~} ; 289 | 290 | program = '.syntax' declist support main $ stat '.end' { 'main' }; 291 | 292 | .end 293 | -------------------------------------------------------------------------------- /meta.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | 6 | void meta_program(); 7 | void meta_exp1(); 8 | void meta_exp3(); 9 | void meta_arg(); 10 | void meta_output(); 11 | void meta_exp2(); 12 | void meta_exp1(); 13 | void meta_comment(); 14 | void meta_stat(); 15 | void meta_support(); 16 | void meta_declist(); 17 | void meta_main(); 18 | 19 | // Output name, input string, token 20 | char *on, *s, *t; 21 | // Output 22 | FILE *o; 23 | // Labels 24 | int ac, bc; 25 | // Label locks 26 | int ll = 3; 27 | // Current location in string, flag, indentation level, newline flag 28 | int p, flag, indent, nl; 29 | // Line counter 30 | int line = 1; 31 | 32 | void skip_whitespace() { 33 | while (isspace(s[p])) { 34 | if (s[p] == '\n') { 35 | line++; 36 | } 37 | p++; 38 | } 39 | } 40 | 41 | void make_token(int sp) { 42 | int length = p - sp; 43 | free(t); 44 | t = malloc(length + 1); 45 | t[length] = 0; 46 | memcpy(t, &s[sp], length); 47 | } 48 | 49 | void emit_token() { 50 | int i; 51 | char d; 52 | // We introduce a new quoting operator, the tilde, which can quote 53 | // single quotes. In this way, we don't need an escape character. 54 | if (t[0] == '\'' || t[0] == '~') { 55 | d = t[0]; 56 | fprintf(o, "\""); 57 | for (i = 1; t[i] && t[i] != d; i++) { 58 | switch (t[i]) { 59 | case '\n': 60 | fprintf(o, "\\n"); 61 | break; 62 | case '\"': 63 | fprintf(o, "\\\""); 64 | break; 65 | case '\'': 66 | fprintf(o, "\\\'"); 67 | break; 68 | case '\\': 69 | fprintf(o, "\\\\"); 70 | break; 71 | default: 72 | fprintf(o, "%c", t[i]); 73 | break; 74 | } 75 | } 76 | fprintf(o, "\""); 77 | return; 78 | } 79 | fprintf(o, "%s", t); 80 | } 81 | 82 | void emit(const char *s) { 83 | // fprintf(o, "%s", s); 84 | fprintf(o, "%*s%s", nl ? indent : 0, "", s); 85 | nl = 0; 86 | } 87 | 88 | void emit_label_a() { 89 | ac += (ll & 1); 90 | fprintf(o, "a%02d ", ac); 91 | } 92 | 93 | void emit_label_b() { 94 | bc += (ll & 2) >> 1; 95 | fprintf(o, "b%02d ", bc); 96 | } 97 | 98 | void unlock_labels() { 99 | ll = 3; 100 | } 101 | 102 | void emit_newline() { 103 | nl = 1; 104 | fprintf(o, "\n"); 105 | } 106 | 107 | void read_literal(const char *l) { 108 | int e, i; 109 | skip_whitespace(); 110 | e = p; 111 | i = 0; 112 | while (s[p] && l[i] && s[p] == l[i]) { 113 | p++; 114 | i++; 115 | } 116 | if (!l[i]) { 117 | flag = 1; 118 | make_token(e); 119 | } else { 120 | p = e; 121 | flag = 0; 122 | } 123 | } 124 | 125 | void read_id() { 126 | int e; 127 | skip_whitespace(); 128 | e = p; 129 | if (isalpha(s[p])) { 130 | p++; 131 | flag = 1; 132 | } else { 133 | flag = 0; 134 | return; 135 | } 136 | while (isalnum(s[p])) { 137 | p++; 138 | } 139 | make_token(e); 140 | } 141 | 142 | void read_number() { 143 | int e; 144 | skip_whitespace(); 145 | e = p; 146 | if (s[p] == '-') { 147 | p++; 148 | } 149 | if (isdigit(s[p])) { 150 | p++; 151 | flag = 1; 152 | } else { 153 | flag = 0; 154 | return; 155 | } 156 | while (isdigit(s[p])) { 157 | p++; 158 | } 159 | make_token(e); 160 | } 161 | 162 | void read_string() { 163 | int e; 164 | char delim; 165 | skip_whitespace(); 166 | e = p; 167 | if (s[p] == '\'' || s[p] == '~') { 168 | delim = s[p++]; 169 | while (s[p] && s[p] != delim) { 170 | if (s[p] == '\n') { 171 | line++; 172 | } 173 | p++; 174 | } 175 | if (s[p] == delim) { 176 | p++; 177 | flag = 1; 178 | make_token(e); 179 | } else if (!s[p]) { 180 | p = e; 181 | flag = 0; 182 | } 183 | } else { 184 | flag = 0; 185 | return; 186 | } 187 | } 188 | 189 | void maybe_error() { 190 | if (!flag) { 191 | fprintf(stderr, "Error in line %i at token '%s'\n", line, t); 192 | fclose(o); 193 | remove(on); 194 | free(s); 195 | free(t); 196 | exit(1); 197 | } 198 | } 199 | 200 | int main(int argc, char *argv[]) { 201 | FILE *input; 202 | int length; 203 | 204 | if (argc < 3) { 205 | fprintf(stderr, "usage: meta \n"); 206 | exit(1); 207 | } 208 | input = fopen(argv[1], "r"); 209 | if (!input) { 210 | fprintf(stderr, "invalid input file\n"); 211 | exit(1); 212 | } 213 | on = argv[2]; 214 | o = fopen(on, "w"); 215 | if (!o) { 216 | fprintf(stderr, "invalid output file\n"); 217 | exit(1); 218 | } 219 | fseek(input, 0, SEEK_END); 220 | length = (int)ftell(input); 221 | fseek(input, 0, SEEK_SET); 222 | s = malloc(length + 1); 223 | fread(s, 1, length, input); 224 | s[length] = 0; 225 | fclose(input); 226 | 227 | t = malloc(1); 228 | t[0] = 0; 229 | 230 | meta_program(); 231 | 232 | skip_whitespace(); 233 | if (p == strlen(s)) { 234 | fprintf(stdout, "Fully parsed %d characters.\n", p); 235 | } else { 236 | fprintf(stderr, "%d/%ld characters processed\n", p, strlen(s)); 237 | } 238 | 239 | fclose(o); 240 | free(s); 241 | free(t); 242 | return 0; 243 | } 244 | void meta_arg() { 245 | do { 246 | read_literal("*1"); 247 | if (flag) { 248 | emit("emit_label_a();"); 249 | emit_newline(); 250 | emit("ll &= 2;"); 251 | emit_newline(); 252 | } 253 | if (flag) { break; } 254 | read_literal("*2"); 255 | if (flag) { 256 | emit("emit_label_b();"); 257 | emit_newline(); 258 | emit("ll &= 1;"); 259 | emit_newline(); 260 | } 261 | if (flag) { break; } 262 | read_literal("*"); 263 | if (flag) { 264 | emit("emit_token();"); 265 | emit_newline(); 266 | } 267 | if (flag) { break; } 268 | read_string(); 269 | if (flag) { 270 | emit("emit("); 271 | emit_token(); 272 | emit(");"); 273 | emit_newline(); 274 | } 275 | } while (0); 276 | } 277 | 278 | void meta_output() { 279 | do { 280 | do { 281 | read_literal("{"); 282 | if (flag) { 283 | do { 284 | meta_arg(); 285 | } while (flag); 286 | flag = 1; 287 | maybe_error(); 288 | read_literal("}"); 289 | maybe_error(); 290 | emit("emit_newline();"); 291 | emit_newline(); 292 | } 293 | if (flag) { break; } 294 | read_literal("<"); 295 | if (flag) { 296 | do { 297 | meta_arg(); 298 | } while (flag); 299 | flag = 1; 300 | maybe_error(); 301 | read_literal(">"); 302 | maybe_error(); 303 | } 304 | } while (0); 305 | if (flag) { 306 | } 307 | } while (0); 308 | } 309 | 310 | void meta_exp3() { 311 | do { 312 | read_id(); 313 | if (flag) { 314 | emit("meta_"); 315 | emit_token(); 316 | emit("();"); 317 | emit_newline(); 318 | } 319 | if (flag) { break; } 320 | read_string(); 321 | if (flag) { 322 | emit("read_literal("); 323 | emit_token(); 324 | emit(");"); 325 | emit_newline(); 326 | } 327 | if (flag) { break; } 328 | read_literal(".id"); 329 | if (flag) { 330 | emit("read_id();"); 331 | emit_newline(); 332 | } 333 | if (flag) { break; } 334 | read_literal(".number"); 335 | if (flag) { 336 | emit("read_number();"); 337 | emit_newline(); 338 | } 339 | if (flag) { break; } 340 | read_literal(".string"); 341 | if (flag) { 342 | emit("read_string();"); 343 | emit_newline(); 344 | } 345 | if (flag) { break; } 346 | read_literal(".lm+"); 347 | if (flag) { 348 | emit("indent += 2;"); 349 | emit_newline(); 350 | } 351 | if (flag) { break; } 352 | read_literal(".lm-"); 353 | if (flag) { 354 | emit("indent -= 2;"); 355 | emit_newline(); 356 | } 357 | if (flag) { break; } 358 | read_literal("("); 359 | if (flag) { 360 | meta_exp1(); 361 | maybe_error(); 362 | read_literal(")"); 363 | maybe_error(); 364 | } 365 | if (flag) { break; } 366 | read_literal(".e"); 367 | if (flag) { 368 | emit("flag = 1;"); 369 | emit_newline(); 370 | } 371 | if (flag) { break; } 372 | read_literal("$"); 373 | if (flag) { 374 | emit("do {"); 375 | emit_newline(); 376 | indent += 2; 377 | maybe_error(); 378 | meta_exp3(); 379 | maybe_error(); 380 | indent -= 2; 381 | maybe_error(); 382 | emit("} while (flag);"); 383 | emit_newline(); 384 | emit("flag = 1;"); 385 | emit_newline(); 386 | } 387 | } while (0); 388 | } 389 | 390 | void meta_exp2() { 391 | do { 392 | do { 393 | meta_exp3(); 394 | if (flag) { 395 | emit("if (flag) {"); 396 | emit_newline(); 397 | } 398 | if (flag) { break; } 399 | meta_output(); 400 | if (flag) { 401 | emit("if (1) {"); 402 | emit_newline(); 403 | } 404 | } while (0); 405 | if (flag) { 406 | indent += 2; 407 | maybe_error(); 408 | do { 409 | do { 410 | meta_exp3(); 411 | if (flag) { 412 | emit("maybe_error();"); 413 | emit_newline(); 414 | } 415 | if (flag) { break; } 416 | meta_output(); 417 | if (flag) { 418 | } 419 | } while (0); 420 | } while (flag); 421 | flag = 1; 422 | maybe_error(); 423 | indent -= 2; 424 | maybe_error(); 425 | emit("}"); 426 | emit_newline(); 427 | } 428 | } while (0); 429 | } 430 | 431 | void meta_exp1() { 432 | do { 433 | emit("do {"); 434 | emit_newline(); 435 | if (1) { 436 | indent += 2; 437 | maybe_error(); 438 | meta_exp2(); 439 | maybe_error(); 440 | do { 441 | do { 442 | read_literal("|"); 443 | if (flag) { 444 | emit("if (flag) { break; }"); 445 | emit_newline(); 446 | meta_exp2(); 447 | maybe_error(); 448 | } 449 | } while (0); 450 | } while (flag); 451 | flag = 1; 452 | maybe_error(); 453 | indent -= 2; 454 | maybe_error(); 455 | emit("} while (0);"); 456 | emit_newline(); 457 | } 458 | } while (0); 459 | } 460 | 461 | void meta_comment() { 462 | do { 463 | read_literal("["); 464 | if (flag) { 465 | read_string(); 466 | maybe_error(); 467 | read_literal("]"); 468 | maybe_error(); 469 | } 470 | } while (0); 471 | } 472 | 473 | void meta_stat() { 474 | do { 475 | read_id(); 476 | if (flag) { 477 | emit("void meta_"); 478 | emit_token(); 479 | emit("() {"); 480 | emit_newline(); 481 | indent += 2; 482 | maybe_error(); 483 | read_literal("="); 484 | maybe_error(); 485 | meta_exp1(); 486 | maybe_error(); 487 | read_literal(";"); 488 | maybe_error(); 489 | indent -= 2; 490 | maybe_error(); 491 | emit("}"); 492 | emit_newline(); 493 | emit_newline(); 494 | } 495 | if (flag) { break; } 496 | meta_comment(); 497 | if (flag) { 498 | } 499 | } while (0); 500 | } 501 | 502 | void meta_support() { 503 | do { 504 | emit("\n// Output name, input string, token\nchar *on, *s, *t;\n// Output\nFILE *o;\n// Labels\nint ac, bc;\n// Label locks\nint ll = 3;\n// Current location in string, flag, indentation level, newline flag\nint p, flag, indent, nl;\n// Line counter\nint line = 1;\n\nvoid skip_whitespace() {\n while (isspace(s[p])) {\n if (s[p] == \'\\n\') {\n line++;\n }\n p++;\n }\n}\n\nvoid make_token(int sp) {\n int length = p - sp;\n free(t);\n t = malloc(length + 1);\n t[length] = 0;\n memcpy(t, &s[sp], length);\n}\n\nvoid emit_token() {\n int i;\n char d;\n // We introduce a new quoting operator, the tilde, which can quote\n // single quotes. In this way, we don\'t need an escape character.\n if (t[0] == \'\\\'\' || t[0] == \'"); 505 | emit("~"); 506 | emit("\') {\n d = t[0];\n fprintf(o, \"\\\"\");\n for (i = 1; t[i] && t[i] != d; i++) {\n switch (t[i]) {\n case \'\\n\':\n fprintf(o, \"\\\\n\");\n break;\n case \'\\\"\':\n fprintf(o, \"\\\\\\\"\");\n break;\n case \'\\\'\':\n fprintf(o, \"\\\\\\\'\");\n break;\n case \'\\\\\':\n fprintf(o, \"\\\\\\\\\");\n break;\n default:\n fprintf(o, \"%c\", t[i]);\n break;\n }\n }\n fprintf(o, \"\\\"\");\n return;\n }\n fprintf(o, \"%s\", t);\n}\n\nvoid emit(const char *s) {\n // fprintf(o, \"%s\", s);\n fprintf(o, \"%*s%s\", nl ? indent : 0, \"\", s);\n nl = 0;\n}\n\nvoid emit_label_a() {\n ac += (ll & 1);\n fprintf(o, \"a%02d \", ac);\n}\n\nvoid emit_label_b() {\n bc += (ll & 2) >> 1;\n fprintf(o, \"b%02d \", bc);\n}\n\nvoid unlock_labels() {\n ll = 3;\n}\n\nvoid emit_newline() {\n nl = 1;\n fprintf(o, \"\\n\");\n}\n\nvoid read_literal(const char *l) {\n int e, i;\n skip_whitespace();\n e = p;\n i = 0;\n while (s[p] && l[i] && s[p] == l[i]) {\n p++;\n i++;\n }\n if (!l[i]) {\n flag = 1;\n make_token(e);\n } else {\n p = e;\n flag = 0;\n }\n}\n\nvoid read_id() {\n int e;\n skip_whitespace();\n e = p;\n if (isalpha(s[p])) {\n p++;\n flag = 1;\n } else {\n flag = 0;\n return;\n }\n while (isalnum(s[p])) {\n p++;\n }\n make_token(e);\n}\n\nvoid read_number() {\n int e;\n skip_whitespace();\n e = p;\n if (s[p] == \'-\') {\n p++;\n }\n if (isdigit(s[p])) {\n p++;\n flag = 1;\n } else {\n flag = 0;\n return;\n }\n while (isdigit(s[p])) {\n p++;\n }\n make_token(e);\n}\n\nvoid read_string() {\n int e;\n char delim;\n skip_whitespace();\n e = p;\n if (s[p] == \'\\\'\' || s[p] == \'"); 507 | emit("~"); 508 | emit("\') {\n delim = s[p++];\n while (s[p] && s[p] != delim) {\n if (s[p] == \'\\n\') {\n line++;\n }\n p++;\n }\n if (s[p] == delim) {\n p++;\n flag = 1;\n make_token(e);\n } else if (!s[p]) {\n p = e;\n flag = 0;\n }\n } else {\n flag = 0;\n return;\n }\n}\n\nvoid maybe_error() {\n if (!flag) {\n fprintf(stderr, \"Error in line %i at token \'%s\'\\n\", line, t);\n fclose(o);\n remove(on);\n free(s);\n free(t);\n exit(1);\n }\n}\n"); 509 | emit_newline(); 510 | if (1) { 511 | } 512 | } while (0); 513 | } 514 | 515 | void meta_declist() { 516 | do { 517 | emit("#include \n#include \n#include \n#include \n"); 518 | emit_newline(); 519 | if (1) { 520 | read_literal("["); 521 | maybe_error(); 522 | do { 523 | do { 524 | read_id(); 525 | if (flag) { 526 | emit("void meta_"); 527 | emit_token(); 528 | emit("();"); 529 | emit_newline(); 530 | } 531 | } while (0); 532 | } while (flag); 533 | flag = 1; 534 | maybe_error(); 535 | read_literal("]"); 536 | maybe_error(); 537 | } 538 | } while (0); 539 | } 540 | 541 | void meta_main() { 542 | do { 543 | read_id(); 544 | if (flag) { 545 | emit("int main(int argc, char *argv[]) {\n FILE *input;\n int length;\n\n if (argc < 3) {\n fprintf(stderr, \"usage: meta \\n\");\n exit(1);\n }\n input = fopen(argv[1], \"r\");\n if (!input) {\n fprintf(stderr, \"invalid input file\\n\");\n exit(1);\n }\n on = argv[2];\n o = fopen(on, \"w\");\n if (!o) {\n fprintf(stderr, \"invalid output file\\n\");\n exit(1);\n }\n fseek(input, 0, SEEK_END);\n length = (int)ftell(input);\n fseek(input, 0, SEEK_SET);\n s = malloc(length + 1);\n fread(s, 1, length, input);\n s[length] = 0;\n fclose(input);\n\n t = malloc(1);\n t[0] = 0;\n\n meta_"); 546 | emit_token(); 547 | emit("();\n\n skip_whitespace();\n if (p == strlen(s)) {\n fprintf(stdout, \"Fully parsed %d characters.\\n\", p);\n } else {\n fprintf(stderr, \"%d/%d characters processed\\n\", p, strlen(s));\n }\n\n fclose(o);\n free(s);\n free(t);\n return 0;\n}"); 548 | emit_newline(); 549 | } 550 | } while (0); 551 | } 552 | 553 | void meta_program() { 554 | do { 555 | read_literal(".syntax"); 556 | if (flag) { 557 | meta_declist(); 558 | maybe_error(); 559 | meta_support(); 560 | maybe_error(); 561 | meta_main(); 562 | maybe_error(); 563 | do { 564 | meta_stat(); 565 | } while (flag); 566 | flag = 1; 567 | maybe_error(); 568 | read_literal(".end"); 569 | maybe_error(); 570 | } 571 | } while (0); 572 | } 573 | 574 | -------------------------------------------------------------------------------- /meta.fs: -------------------------------------------------------------------------------- 1 | variable meta-program' 2 | variable meta-exp1' 3 | variable meta-exp3' 4 | variable meta-arg' 5 | variable meta-output' 6 | variable meta-exp2' 7 | variable meta-exp1' 8 | variable meta-comment' 9 | variable meta-stat' 10 | variable meta-support' 11 | variable meta-declist' 12 | variable meta-main' 13 | 14 | \ input string | string length | token buffer | token length 15 | variable s variable slen 0 value t variable tlen 16 | 17 | \ Current location in string 18 | variable p 0 p ! 19 | 20 | \ Flags 21 | false value flagged? false value newlined? 22 | 23 | \ Indentation level 24 | variable indent 25 | 26 | \ Line counter 27 | variable lines 1 lines ! 28 | 29 | 10 constant \n 9 constant \t 126 constant tilde 30 | 39 constant tick 34 constant dtick 31 | 32 | : set-flag! ( -- ) true to flagged? ; 33 | : unflag! ( -- ) false to flagged? ; 34 | 35 | \ Run a parser, which is a pointer to a word. 36 | : do-parse ( -- ) @ execute ; 37 | 38 | : set-source! ( c-addr u -- ) slen ! s ! ; 39 | : c-array-ref ( a b -- a[b] ) + c@ ; 40 | : isspace ( c -- # ) bl over = over \t = or swap \n = or ; 41 | 42 | : isdelim ( c -- # ) dup tick = swap tilde = or ; 43 | : curr-char ( -- c ) s @ p @ c-array-ref ; 44 | 45 | : advance ( -- ) 1 p +! ; 46 | : inc-lines ( -- ) 1 lines +! ; 47 | 48 | : skip-whitespace ( -- ) 49 | begin curr-char isspace while 50 | curr-char \n = negate lines +! advance 51 | repeat 52 | ; 53 | 54 | : ?free ( p|0 -- ) 55 | ?dup-if free if s" failed to free token buffer" exception throw then then 56 | ; 57 | : ?free-token ( -- ) t ?free ; 58 | 59 | : realloc-token ( -- ) 60 | tlen @ 1+ allocate if ." failed to allocate memory for token" then 61 | to t 62 | ; 63 | 64 | : nul-terminate-token ( -- ) 0 t tlen @ + c! ; 65 | : copy-token-from-string ( sp -- ) s @ + t tlen @ cmove ; 66 | 67 | : write-token ( sp -- ) nul-terminate-token copy-token-from-string ; 68 | : calc-token-length ( sp -- sp ) p @ over - tlen ! ; 69 | 70 | \ Make a token up to char sp. 71 | : make-token ( sp -- ) ?free-token calc-token-length realloc-token write-token ; 72 | 73 | \ Emit a character in a string, possibly quoted. 74 | : emit-string-char ( c -- ) 75 | case 76 | \n of .\" \\n" endof 77 | dtick of .\" \\\"" endof 78 | tick of .\" \\\'" endof 79 | [char] \ of .\" \\\\" endof 80 | \ Otherwise, print the character. 81 | dup emit 82 | endcase 83 | ; 84 | 85 | \ Current character from the token buffer. 86 | : tok-char ( -- c ) t c@ ; 87 | 88 | : emit-string ( -- ) 89 | tok-char 90 | tlen @ 1 do 91 | t i c-array-ref 2dup 92 | = if 2drop leave then 93 | emit-string-char 94 | loop 95 | dtick emit 96 | ; 97 | 98 | : emit-token ( -- ) tok-char isdelim if emit-string else t tlen @ type then ; 99 | 100 | 101 | : print-indent ( -- ) indent @ spaces ; 102 | : mtype ( c-addr u -- ) newlined? if print-indent then type 0 to newlined? ; 103 | : emit-newline 1 to newlined? cr ; 104 | 105 | : read-literal ( c-addr u -- ) 106 | { length } 107 | p @ 0 { l e i } 108 | skip-whitespace 109 | 110 | length 0 do 111 | curr-char 0<> 112 | l i c-array-ref 0<> 113 | and 114 | curr-char l i c-array-ref = 115 | and 116 | if 117 | advance 118 | i 1+ to i 119 | else 120 | leave 121 | then 122 | loop 123 | 124 | i length = if 125 | set-flag! 126 | e make-token 127 | else 128 | e p ! unflag! 129 | then 130 | ; 131 | 132 | : isupper ( c -- # ) [char] A [char] Z 1+ within ; 133 | : islower ( c -- # ) [char] a [char] z 1+ within ; 134 | : isalpha ( c -- # ) dup isupper swap islower or ; 135 | 136 | : isdigit ( c -- # ) [char] 0 [char] 9 1+ within ; 137 | : isalnum ( c -- # ) dup isalpha swap isdigit or ; 138 | 139 | : advance-while-alnum ( -- ) begin curr-char isalnum while advance repeat ; 140 | : advance-while-digit ( -- ) begin curr-char isdigit while advance repeat ; 141 | 142 | : read-id ( -- ) 143 | skip-whitespace 144 | p @ 145 | curr-char isalpha if 146 | advance set-flag! 147 | else 148 | unflag! drop exit 149 | then 150 | 151 | advance-while-alnum make-token 152 | ; 153 | 154 | 155 | : read-number ( -- ) 156 | skip-whitespace 157 | p @ 158 | 159 | \ Possibly with a leading dash. 160 | curr-char [char] - = if advance then 161 | 162 | curr-char isdigit if 163 | advance set-flag! 164 | advance-while-digit make-token 165 | else 166 | drop unflag! exit 167 | then 168 | ; 169 | 170 | \ Advance the pointer until the next occurence of c. 171 | : advance-while-<> ( c -- ) 172 | begin dup curr-char <> while 173 | curr-char \n = if inc-lines then 174 | advance 175 | repeat 176 | ; 177 | 178 | : read-string ( -- ) 179 | skip-whitespace 180 | p @ 181 | 182 | curr-char isdelim if 183 | curr-char advance advance-while-<> 184 | 185 | curr-char = if 186 | advance set-flag! make-token 187 | else 188 | \ If we hit the end of the file, backtrack. 189 | curr-char 0= if p ! then 190 | then 191 | else 192 | drop unflag! 193 | then 194 | ; 195 | 196 | : maybe-error 197 | flagged? invert if ( -- ) 198 | ." Error in line " lines ? ." at token '" t tlen @ type ." ' " 199 | ." at character " p @ . cr 200 | s" Parse error" exception throw 201 | then 202 | ; 203 | 204 | \ File ID in | File ID out 205 | 0 value fd-in 0 value fd-out 206 | 207 | : open-input ( addr u -- ) r/o open-file throw to fd-in ; 208 | : open-output ( addr u -- ) w/o create-file throw to fd-out ; 209 | 210 | \ Size of each read. 211 | 1000 1000 * constant blk-size 212 | 213 | \ Current size of the file buffer | Pointer to the file buffer. 214 | 0 value curr-buf-size 0 value file-buffer 215 | 216 | blk-size allocate throw to file-buffer 217 | 218 | \ Read a file, zero-delimited. 219 | : do-read-file ( -- ) 220 | file-buffer blk-size fd-in read-file 221 | if s" failed to read file" exception throw then 222 | dup to curr-buf-size 223 | file-buffer + 0 swap ! 224 | ; 225 | 226 | : close-input ( -- ) fd-in close-file throw ; 227 | : close-output ( -- ) fd-out close-file throw ; 228 | 229 | : set-file-as-input file-buffer curr-buf-size set-source! ; 230 | : print-file file-buffer curr-buf-size type ; 231 | 232 | 233 | : check-args 234 | argc @ 3 <> if s" usage: meta " exception throw then ; 235 | 236 | : process-input-arg ( -- ) 237 | next-arg 2dup ." Input file: " type cr open-input 238 | do-read-file set-file-as-input close-input 239 | ; 240 | 241 | : process-output-arg ( -- ) 242 | next-arg 2dup ." Output file: " type cr open-output ; 243 | 244 | : process-args ( -- ) process-input-arg process-output-arg ; 245 | : start-msg ( -- ) cr ." meta-yacc has started." cr ; 246 | : assert-clean-stack ( -- ) 247 | depth if 248 | s" stack not empty on exit" exception throw 249 | else 250 | cr ." Parsed without errors." cr 251 | then 252 | ; 253 | 254 | : run-meta-program find-name name>int fd-out outfile-execute ; 255 | : main 256 | start-msg check-args process-args 257 | s" meta-program" run-meta-program 258 | close-output assert-clean-stack bye 259 | ; 260 | meta-arg' 261 | : meta-arg 262 | 1 0 do 263 | s\" *" read-literal 264 | flagged? if 265 | s\" emit-token" mtype 266 | emit-newline 267 | then 268 | flagged? if leave then 269 | read-string 270 | flagged? if 271 | s\" s\\\" " mtype 272 | emit-token 273 | s\" mtype" mtype 274 | emit-newline 275 | then 276 | loop 277 | ; latestxt swap ! 278 | meta-output' 279 | : meta-output 280 | 1 0 do 281 | 1 0 do 282 | s\" {" read-literal 283 | flagged? if 284 | 0 0 do 285 | meta-arg' do-parse 286 | flagged? invert if leave then loop 287 | set-flag! 288 | maybe-error 289 | s\" }" read-literal 290 | maybe-error 291 | s\" emit-newline" mtype 292 | emit-newline 293 | then 294 | flagged? if leave then 295 | s\" <" read-literal 296 | flagged? if 297 | 0 0 do 298 | meta-arg' do-parse 299 | flagged? invert if leave then loop 300 | set-flag! 301 | maybe-error 302 | s\" >" read-literal 303 | maybe-error 304 | then 305 | loop 306 | flagged? if 307 | then 308 | loop 309 | ; latestxt swap ! 310 | meta-exp3' 311 | : meta-exp3 312 | 1 0 do 313 | read-id 314 | flagged? if 315 | s\" meta-" mtype 316 | emit-token 317 | s\" \' do-parse" mtype 318 | emit-newline 319 | then 320 | flagged? if leave then 321 | read-string 322 | flagged? if 323 | s\" s\\\" " mtype 324 | emit-token 325 | s\" read-literal" mtype 326 | emit-newline 327 | then 328 | flagged? if leave then 329 | s\" .id" read-literal 330 | flagged? if 331 | s\" read-id" mtype 332 | emit-newline 333 | then 334 | flagged? if leave then 335 | s\" .number" read-literal 336 | flagged? if 337 | s\" read-number" mtype 338 | emit-newline 339 | then 340 | flagged? if leave then 341 | s\" .string" read-literal 342 | flagged? if 343 | s\" read-string" mtype 344 | emit-newline 345 | then 346 | flagged? if leave then 347 | s\" .lm+" read-literal 348 | flagged? if 349 | s\" 2 indent +!" mtype 350 | emit-newline 351 | then 352 | flagged? if leave then 353 | s\" .lm-" read-literal 354 | flagged? if 355 | s\" -2 indent +!" mtype 356 | emit-newline 357 | then 358 | flagged? if leave then 359 | s\" (" read-literal 360 | flagged? if 361 | meta-exp1' do-parse 362 | maybe-error 363 | s\" )" read-literal 364 | maybe-error 365 | then 366 | flagged? if leave then 367 | s\" .e" read-literal 368 | flagged? if 369 | s\" set-flag!" mtype 370 | emit-newline 371 | then 372 | flagged? if leave then 373 | s\" $" read-literal 374 | flagged? if 375 | s\" 0 0 do" mtype 376 | emit-newline 377 | 2 indent +! 378 | maybe-error 379 | meta-exp3' do-parse 380 | maybe-error 381 | -2 indent +! 382 | maybe-error 383 | s\" flagged? invert if leave then loop" mtype 384 | emit-newline 385 | s\" set-flag!" mtype 386 | emit-newline 387 | then 388 | loop 389 | ; latestxt swap ! 390 | meta-exp2' 391 | : meta-exp2 392 | 1 0 do 393 | 1 0 do 394 | meta-exp3' do-parse 395 | flagged? if 396 | s\" flagged? if" mtype 397 | emit-newline 398 | then 399 | flagged? if leave then 400 | meta-output' do-parse 401 | flagged? if 402 | s\" true if" mtype 403 | emit-newline 404 | then 405 | loop 406 | flagged? if 407 | 2 indent +! 408 | maybe-error 409 | 0 0 do 410 | 1 0 do 411 | meta-exp3' do-parse 412 | flagged? if 413 | s\" maybe-error" mtype 414 | emit-newline 415 | then 416 | flagged? if leave then 417 | meta-output' do-parse 418 | flagged? if 419 | then 420 | loop 421 | flagged? invert if leave then loop 422 | set-flag! 423 | maybe-error 424 | -2 indent +! 425 | maybe-error 426 | s\" then" mtype 427 | emit-newline 428 | then 429 | loop 430 | ; latestxt swap ! 431 | meta-exp1' 432 | : meta-exp1 433 | 1 0 do 434 | s\" 1 0 do" mtype 435 | emit-newline 436 | true if 437 | 2 indent +! 438 | maybe-error 439 | meta-exp2' do-parse 440 | maybe-error 441 | 0 0 do 442 | 1 0 do 443 | s\" |" read-literal 444 | flagged? if 445 | s\" flagged? if leave then" mtype 446 | emit-newline 447 | meta-exp2' do-parse 448 | maybe-error 449 | then 450 | loop 451 | flagged? invert if leave then loop 452 | set-flag! 453 | maybe-error 454 | -2 indent +! 455 | maybe-error 456 | s\" loop" mtype 457 | emit-newline 458 | then 459 | loop 460 | ; latestxt swap ! 461 | meta-comment' 462 | : meta-comment 463 | 1 0 do 464 | s\" [" read-literal 465 | flagged? if 466 | read-string 467 | maybe-error 468 | s\" ]" read-literal 469 | maybe-error 470 | then 471 | loop 472 | ; latestxt swap ! 473 | meta-stat' 474 | : meta-stat 475 | 1 0 do 476 | read-id 477 | flagged? if 478 | s\" meta-" mtype 479 | emit-token 480 | s\" \'" mtype 481 | emit-newline 482 | s\" : meta-" mtype 483 | emit-token 484 | emit-newline 485 | 2 indent +! 486 | maybe-error 487 | s\" =" read-literal 488 | maybe-error 489 | meta-exp1' do-parse 490 | maybe-error 491 | s\" ;" read-literal 492 | maybe-error 493 | -2 indent +! 494 | maybe-error 495 | s\" ; latestxt swap ! " mtype 496 | emit-newline 497 | then 498 | flagged? if leave then 499 | meta-comment' do-parse 500 | flagged? if 501 | then 502 | loop 503 | ; latestxt swap ! 504 | meta-support' 505 | : meta-support 506 | 1 0 do 507 | s\" \n\\ input string | string length | token buffer | token length\nvariable s variable slen 0 value t variable tlen\n\n\\ Current location in string\nvariable p 0 p !\n\n\\ Flags\nfalse value flagged? false value newlined?\n\n\\ Indentation level\nvariable indent\n\n\\ Line counter\nvariable lines 1 lines !\n\n10 constant \\n 9 constant \\t 126 constant tilde\n39 constant tick 34 constant dtick\n\n: set-flag! ( -- ) true to flagged? ;\n: unflag! ( -- ) false to flagged? ;\n\n\\ Run a parser, which is a pointer to a word.\n: do-parse ( -- ) @ execute ;\n\n: set-source! ( c-addr u -- ) slen ! s ! ;\n: c-array-ref ( a b -- a[b] ) + c@ ;\n: isspace ( c -- # ) bl over = over \\t = or swap \\n = or ;\n\n: isdelim ( c -- # ) dup tick = swap tilde = or ;\n: curr-char ( -- c ) s @ p @ c-array-ref ;\n\n: advance ( -- ) 1 p +! ;\n: inc-lines ( -- ) 1 lines +! ;\n\n: skip-whitespace ( -- )\n begin curr-char isspace while\n curr-char \\n = negate lines +! advance\n repeat\n;\n\n: ?free ( p|0 -- )\n ?dup-if free if s\" failed to free token buffer\" exception throw then then\n;\n: ?free-token ( -- ) t ?free ;\n\n: realloc-token ( -- )\n tlen @ 1+ allocate if .\" failed to allocate memory for token\" then\n to t\n;\n\n: nul-terminate-token ( -- ) 0 t tlen @ + c! ;\n: copy-token-from-string ( sp -- ) s @ + t tlen @ cmove ;\n\n: write-token ( sp -- ) nul-terminate-token copy-token-from-string ;\n: calc-token-length ( sp -- sp ) p @ over - tlen ! ;\n\n\\ Make a token up to char sp.\n: make-token ( sp -- ) ?free-token calc-token-length realloc-token write-token ;\n\n\\ Emit a character in a string, possibly quoted.\n: emit-string-char ( c -- )\n case\n \\n of .\\\" \\\\n\" endof\n dtick of .\\\" \\\\\\\"\" endof\n tick of .\\\" \\\\\\\'\" endof\n [char] \\ of .\\\" \\\\\\\\\" endof\n \\ Otherwise, print the character.\n dup emit\n endcase\n;\n\n\\ Current character from the token buffer.\n: tok-char ( -- c ) t c@ ;\n\n: emit-string ( -- )\n tok-char\n tlen @ 1 do\n t i c-array-ref 2dup\n = if 2drop leave then\n emit-string-char\n loop\n dtick emit\n;\n\n: emit-token ( -- ) tok-char isdelim if emit-string else t tlen @ type then ;\n\n\n: print-indent ( -- ) indent @ spaces ;\n: mtype ( c-addr u -- ) newlined? if print-indent then type 0 to newlined? ;\n: emit-newline 1 to newlined? cr ;\n\n: read-literal ( c-addr u -- )\n { length }\n p @ 0 { l e i }\n skip-whitespace\n\n length 0 do\n curr-char 0<>\n l i c-array-ref 0<>\n and\n curr-char l i c-array-ref =\n and\n if\n advance\n i 1+ to i\n else\n leave\n then\n loop\n\n i length = if\n set-flag!\n e make-token\n else\n e p ! unflag!\n then\n;\n\n: isupper ( c -- # ) [char] A [char] Z 1+ within ;\n: islower ( c -- # ) [char] a [char] z 1+ within ;\n: isalpha ( c -- # ) dup isupper swap islower or ;\n\n: isdigit ( c -- # ) [char] 0 [char] 9 1+ within ;\n: isalnum ( c -- # ) dup isalpha swap isdigit or ;\n\n: advance-while-alnum ( -- ) begin curr-char isalnum while advance repeat ;\n: advance-while-digit ( -- ) begin curr-char isdigit while advance repeat ;\n\n: read-id ( -- )\n skip-whitespace\n p @\n curr-char isalpha if\n advance set-flag!\n else\n unflag! drop exit\n then\n\n advance-while-alnum make-token\n;\n\n\n: read-number ( -- )\n skip-whitespace\n p @\n \n \\ Possibly with a leading dash.\n curr-char [char] - = if advance then\n\n curr-char isdigit if\n advance set-flag!\n advance-while-digit make-token\n else\n drop unflag! exit\n then\n;\n\n\\ Advance the pointer until the next occurence of c.\n: advance-while-<> ( c -- )\n begin dup curr-char <> while\n curr-char \\n = if inc-lines then\n advance\n repeat\n;\n\n: read-string ( -- )\n skip-whitespace\n p @\n \n curr-char isdelim if\n curr-char advance advance-while-<>\n \n curr-char = if\n advance set-flag! make-token\n else\n \\ If we hit the end of the file, backtrack.\n curr-char 0= if p ! then\n then\n else\n drop unflag!\n then\n;\n\n: maybe-error\n flagged? invert if ( -- )\n .\" Error in line \" lines ? .\" at token \'\" t tlen @ type .\" \' \"\n .\" at character \" p @ . cr\n s\" Parse error\" exception throw\n then\n;\n\n\\ File ID in | File ID out\n0 value fd-in 0 value fd-out\n\n: open-input ( addr u -- ) r/o open-file throw to fd-in ;\n: open-output ( addr u -- ) w/o create-file throw to fd-out ;\n\n\\ Size of each read.\n1000 1000 * constant blk-size\n\n\\ Current size of the file buffer | Pointer to the file buffer.\n0 value curr-buf-size 0 value file-buffer\n\nblk-size allocate throw to file-buffer\n\n\\ Read a file, zero-delimited.\n: do-read-file ( -- )\n file-buffer blk-size fd-in read-file\n if s\" failed to read file\" exception throw then\n dup to curr-buf-size\n file-buffer + 0 swap !\n;\n\n: close-input ( -- ) fd-in close-file throw ;\n: close-output ( -- ) fd-out close-file throw ;\n\n: set-file-as-input file-buffer curr-buf-size set-source! ;\n: print-file file-buffer curr-buf-size type ;\n" mtype 508 | emit-newline 509 | true if 510 | then 511 | loop 512 | ; latestxt swap ! 513 | meta-declist' 514 | : meta-declist 515 | 1 0 do 516 | s\" [" read-literal 517 | flagged? if 518 | 0 0 do 519 | 1 0 do 520 | read-id 521 | flagged? if 522 | s\" variable meta-" mtype 523 | emit-token 524 | s\" \'" mtype 525 | emit-newline 526 | then 527 | loop 528 | flagged? invert if leave then loop 529 | set-flag! 530 | maybe-error 531 | s\" ]" read-literal 532 | maybe-error 533 | then 534 | loop 535 | ; latestxt swap ! 536 | meta-main' 537 | : meta-main 538 | 1 0 do 539 | read-id 540 | flagged? if 541 | s\" \n: check-args\n argc @ 3 <> if s\" usage: meta \" exception throw then ;\n\n: process-input-arg ( -- )\n next-arg 2dup .\" Input file: \" type cr open-input\n do-read-file set-file-as-input close-input\n;\n\n: process-output-arg ( -- )\n next-arg 2dup .\" Output file: \" type cr open-output ;\n\n: process-args ( -- ) process-input-arg process-output-arg ;\n: start-msg ( -- ) cr .\" meta-yacc has started.\" cr ;\n: assert-clean-stack ( -- )\n depth if\n s\" stack not empty on exit\" exception throw\n else\n cr .\" Parsed without errors.\" cr\n then\n;\n\n: run-meta-program find-name name>int fd-out outfile-execute ;\n: main\n start-msg check-args process-args\n s\" meta-" mtype 542 | emit-token 543 | s\" \" run-meta-program\n close-output assert-clean-stack bye\n;" mtype 544 | emit-newline 545 | then 546 | loop 547 | ; latestxt swap ! 548 | meta-program' 549 | : meta-program 550 | 1 0 do 551 | s\" .syntax" read-literal 552 | flagged? if 553 | meta-declist' do-parse 554 | maybe-error 555 | meta-support' do-parse 556 | maybe-error 557 | meta-main' do-parse 558 | maybe-error 559 | 0 0 do 560 | meta-stat' do-parse 561 | flagged? invert if leave then loop 562 | set-flag! 563 | maybe-error 564 | s\" .end" read-literal 565 | maybe-error 566 | s\" main" mtype 567 | emit-newline 568 | then 569 | loop 570 | ; latestxt swap ! 571 | main 572 | --------------------------------------------------------------------------------