├── maru-2.4 ├── test.dc ├── test-recursion2.txt ├── README.examples ├── asm-common.k ├── compile-grammar.l ├── test-recursion2.g ├── compile-recursion2.l ├── nfibs.c ├── compile-dc.l ├── test-ir.k ├── scope.k ├── test-emit.l ├── ansiterm.l ├── mkosdefs.c ├── compile-irl.l ├── trie.k ├── test-dc.g ├── record-case.l ├── test-peg.l ├── buffer.c ├── libgc.c ├── port.l ├── wcs.c ├── print-structure.l ├── buffer.k ├── data-stream.k ├── repl.l ├── pretty-print.l ├── test-recursion.l ├── dsm-x86.k ├── define-class.l ├── test-elf.l ├── test.l ├── TODO ├── test.irl ├── test-repl.l ├── test-mach-o.l ├── model.l ├── gc.h ├── tpeg.g ├── test-call.k ├── peg-compile.l ├── Makefile ├── chartab.h ├── irl.g ├── compile.l ├── compile-peg.l ├── peg-compiler.l ├── compile-tpeg.l ├── gc.l ├── test-message.l ├── main.c ├── test-pegen.k ├── text-parser.l ├── test-earley.k └── maruby.l ├── maru-2.1 ├── arch ├── eval ├── test ├── contrib │ └── rb.l ├── arch.l └── arch.h └── maru-1.0 ├── test.l └── Makefile /maru-2.4/test.dc: -------------------------------------------------------------------------------- 1 | 3 + 4 2 | 100 * 9 / 5 + 32 3 | -------------------------------------------------------------------------------- /maru-2.1/arch: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kstephens/maru/HEAD/maru-2.1/arch -------------------------------------------------------------------------------- /maru-2.1/eval: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kstephens/maru/HEAD/maru-2.1/eval -------------------------------------------------------------------------------- /maru-2.1/test: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kstephens/maru/HEAD/maru-2.1/test -------------------------------------------------------------------------------- /maru-2.4/test-recursion2.txt: -------------------------------------------------------------------------------- 1 | 0 2 | 1 3 | 1 4 | 1 5 | 2+1 6 | 3+2+1 7 | 4+3+2+1 8 | 5+4+3+2+1 9 | 9+8+7+6+5+4+3+2+1 10 | -------------------------------------------------------------------------------- /maru-2.1/contrib/rb.l: -------------------------------------------------------------------------------- 1 | (define-function rb:lookup ( 2 | (define-function rb:create-object () 3 | (let ( (ivars '()) 4 | (methods '()) 5 | (class '())) 6 | (lambda (selector . args) 7 | ( 8 | ))) 9 | -------------------------------------------------------------------------------- /maru-2.4/README.examples: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -ex 4 | 5 | ./eval "$@" repl.l test-pepsi.l 6 | ./eval "$@" repl.l test-recursion.l 7 | ./eval "$@" test-pegen.k 8 | ./eval "$@" test-earley.k 9 | ./eval "$@" test-call.k 10 | -------------------------------------------------------------------------------- /maru-1.0/test.l: -------------------------------------------------------------------------------- 1 | (define map (lambda (func arg)) 2 | (if (pair? arg) 3 | (cons (func (car arg)) 4 | (map func (cdr arg))) 5 | arg)) 6 | 7 | (map (lambda (x) (* x x)) '(1 2 3 4 5 6)) 8 | 9 | 10 | -------------------------------------------------------------------------------- /maru-2.4/asm-common.k: -------------------------------------------------------------------------------- 1 | (define == =) 2 | (define ASMFAIL error) 3 | 4 | (define-function _s0P (x) (= x 0)) 5 | (define-function _s1P (x) (and (<= -128 x) (<= x 127))) 6 | (define-function _s2P (x) (and (<= -32768 x) (<= x 32767))) 7 | -------------------------------------------------------------------------------- /maru-2.4/compile-grammar.l: -------------------------------------------------------------------------------- 1 | ;;; compile-grammar.l -*- coke -*- 2 | ;;; 3 | ;;; ./eval compile-grammar.l .g ... | tee .l 4 | 5 | (require "parser.l") 6 | (require "peg.l") 7 | 8 | (while *arguments* 9 | (let ((g (parse-file $start (next-argument)))) 10 | (map dumpln g))) 11 | -------------------------------------------------------------------------------- /maru-2.4/test-recursion2.g: -------------------------------------------------------------------------------- 1 | : () 2 | 3 | _ = [ \n\r]* ; 4 | 5 | digit = [0-9]:d -> (println "\t\t\t\t\t$ "d) -> (- d ?0) ; 6 | 7 | op = "+" ; 8 | 9 | term = term:a op digit:b -> (println "\t\t\t\t\t+ "a" "b) -> `(add ,a ,b) 10 | | digit:d -> (println "\t\t\t\t\t# "d) -> d 11 | ; 12 | 13 | program = (_ term)* ; 14 | -------------------------------------------------------------------------------- /maru-2.4/compile-recursion2.l: -------------------------------------------------------------------------------- 1 | ;;; compile-recursion2.l -*- coke -*- 2 | ;;; 3 | ;;; ./eval compile-recursion2.l .txt 4 | 5 | (require "parser.l") 6 | (require "test-recursion2.g.l") 7 | 8 | (peg-enable-recursion) 9 | 10 | (while *arguments* 11 | (let ((g (parse-file $program (next-argument)))) 12 | (dumpln g) 13 | (println) 14 | (list-do elt g (dumpln elt)))) 15 | -------------------------------------------------------------------------------- /maru-2.4/nfibs.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | int fibs(int n) 4 | { 5 | return (n < 2) ? 1 : (fibs(n - 1) + fibs(n - 2) + 1); 6 | } 7 | 8 | int main() 9 | { 10 | printf("%d\n", fibs(35)); 11 | printf("%d\n", fibs(35)); 12 | printf("%d\n", fibs(35)); 13 | printf("%d\n", fibs(35)); 14 | printf("%d\n", fibs(35)); 15 | printf("%d\n", fibs(35)); 16 | printf("%d\n", fibs(35)); 17 | printf("%d\n", fibs(35)); 18 | printf("%d\n", fibs(35)); 19 | printf("%d\n", fibs(35)); 20 | } 21 | -------------------------------------------------------------------------------- /maru-2.4/compile-dc.l: -------------------------------------------------------------------------------- 1 | ;;; compile-dc.l -*- coke -*- 2 | ;;; 3 | ;;; ./eval compile-dc.l .dc 4 | 5 | (require "parser.l") 6 | (require "test-dc.g.l") 7 | 8 | (while *arguments* 9 | (let* ((arg (next-argument)) 10 | (ans ())) 11 | (peg-disable-memoisation) 12 | (map dumpln (parse-file $program arg)) 13 | (peg-enable-memoisation) 14 | (map dumpln (parse-file $program arg)) 15 | (peg-enable-recursion) 16 | (map dumpln (parse-file $program arg)))) 17 | -------------------------------------------------------------------------------- /maru-2.1/arch.l: -------------------------------------------------------------------------------- 1 | ; Generated from ./arch. 2 | (define __MACH__ '(t) ) ; non-nil for Darwin / Mac OS X. (deal with the convoluted ABI) 3 | (define __UNIX__ '( ) ) ; non-nil for Unix, MinGW, etc. (external symbols have underscore prefix) 4 | (define __LINUX__ '( ) ) ; non-nil for Linux, Cygwin, etc. (external symbols have no underscore prefix) 5 | (define __WINDOWS__ '( ) ) ; non-nil for Windows. (external symbols have underscore prefix) 6 | (define __PTR_SIZE__ 8 ) ; sizeof(void*) 7 | (define __LONG_SIZE__ 8 ) ; sizeof(long) 8 | -------------------------------------------------------------------------------- /maru-2.1/arch.h: -------------------------------------------------------------------------------- 1 | /* Generated from ./arch. */ 2 | #define maru___MACH__ 1 /* non-nil for Darwin / Mac OS X. (deal with the convoluted ABI) */ 3 | #define maru___UNIX__ 0 /* non-nil for Unix, MinGW, etc. (external symbols have underscore prefix) */ 4 | #define maru___LINUX__ 0 /* non-nil for Linux, Cygwin, etc. (external symbols have no underscore prefix) */ 5 | #define maru___WINDOWS__ 0 /* non-nil for Windows. (external symbols have underscore prefix) */ 6 | #define maru___PTR_SIZE__ 8 /* sizeof(void*) */ 7 | #define maru___LONG_SIZE__ 8 /* sizeof(long) */ 8 | -------------------------------------------------------------------------------- /maru-2.4/test-ir.k: -------------------------------------------------------------------------------- 1 | (require "ir.k") 2 | 3 | (let ((ir (ir-new ()))) 4 | 5 | (ir-def-struct ir 'Point (list IR-INT 'x 'y)) 6 | 7 | (ir-put ir 8 | (ir-def 'point (ir-struct-type ir 'Point) (ir-struct 'Point (ir-lit 42) (ir-lit 666))) 9 | 10 | (ir-ext 'printf (ir-function-type ir IR-INT)) 11 | 12 | (ir-fun 'doit (ir-function-type ir IR-VOID (ir-struct-type ir 'Point)) 13 | (ir-arg 'p (ir-struct-type ir 'Point)) 14 | (ir-call (ir-get 'printf) (ir-lit "Point with x = %d and y = %d\n") 15 | (ir-member 'x (ir-addr 'p)) 16 | (ir-member 'y (ir-addr 'p)) 17 | )) 18 | 19 | (ir-call (ir-get 'doit) (ir-get 'point)) 20 | ) 21 | 22 | (ir-gen-main ir) 23 | ) 24 | -------------------------------------------------------------------------------- /maru-2.4/scope.k: -------------------------------------------------------------------------------- 1 | (define-structure (parent bindings)) 2 | 3 | (define-function scope-new (parent) (new parent)) 4 | 5 | (define-function scope-find (self key) (assq key (-bindings self))) 6 | 7 | (define-function scope-lookup (self key) 8 | (and self 9 | (or (scope-find self key) 10 | (scope-lookup (-parent self) key)))) 11 | 12 | (define-function scope-define (self key value) 13 | (let ((binding (scope-find self key))) 14 | (if binding 15 | (set-cdr binding value) 16 | (set binding (cons key value)) 17 | (push (-bindings self) binding)) 18 | binding)) 19 | 20 | (define-function scope-define-global (self key value) 21 | (while (-parent self) (set self (-parent self))) 22 | (scope-define self key value)) 23 | -------------------------------------------------------------------------------- /maru-2.4/test-emit.l: -------------------------------------------------------------------------------- 1 | ;;; ---------------------------------------------------------------- 2 | 3 | (compile-begin) 4 | 5 | (define printf (extern 'printf)) 6 | 7 | (define-function fibs (n) (if (< n 2) 1 (+ 1 (+ (fibs (- n 1)) (fibs (- n 2)))))) 8 | 9 | (define main 10 | (lambda (argc argv) 11 | (for (i 0 10) (printf "%d " i)) (printf "\n") 12 | (printf "%d %d %d %d %d\n" (if) (if 1) (if 1 2) (if 1 2 3) (if 1 2 3 4)) 13 | (printf "%d %d %d %d %d\n" (if) (if ()) (if () 5) (if () 5 6) (if () 5 6 7)) 14 | (printf "%d\n" (fibs 15)) 15 | (printf "%d\n" (or 1 2 3)) 16 | (printf "%d\n" (and 1 2 3)) 17 | (let ((y 1 2 3 42)) 18 | (printf "a%d\n" y) 19 | (set y (+ 1 y)) 20 | (printf "b%d\n" y) 21 | ) 22 | 0 23 | )) 24 | 25 | (compile-end) 26 | -------------------------------------------------------------------------------- /maru-2.4/ansiterm.l: -------------------------------------------------------------------------------- 1 | (define RESET "") 2 | (define BOLD "") 3 | (define UNDERLINE "") 4 | (define BLINK "") 5 | (define NEGATIVE "") 6 | (define BOLD-OFF "") 7 | (define UNDERLINE-OFF "") 8 | (define BLINK-OFF "") 9 | (define NEGATIVE-OFF "") 10 | (define FG-BLACK "") 11 | (define FG-RED "") 12 | (define FG-GREEN "") 13 | (define FG-YELLOW "") 14 | (define FG-BLUE "") 15 | (define FG-MAGENTA "") 16 | (define FG-CYAN "") 17 | (define FG-WHITE "") 18 | (define FG-DEFAULT "") 19 | (define BG-BLACK "") 20 | (define BG-RED "") 21 | (define BG-GREEN "") 22 | (define BG-YELLOW "") 23 | (define BG-BLUE "") 24 | (define BG-MAGENTA "") 25 | (define BG-CYAN "") 26 | (define BG-WHITE "") 27 | (define BG-DEFAULT "") 28 | -------------------------------------------------------------------------------- /maru-2.4/mkosdefs.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | #define STR(X) #X 4 | 5 | #define defint(X) printf("(define %s %d)\n", #X, X) 6 | #define defstr(X) printf("(define %s \"%s\")\n", #X, STR(X)) 7 | 8 | int main() 9 | { 10 | # ifdef __APPLE__ 11 | defint(__APPLE__); 12 | # endif 13 | # ifdef __ELF__ 14 | defint(__ELF__); 15 | # endif 16 | # ifdef __LITTLE_ENDIAN__ 17 | defint(__LITTLE_ENDIAN__); 18 | # endif 19 | # ifdef __MACH__ 20 | defint(__MACH__); 21 | # endif 22 | # ifdef __WIN32__ 23 | defint(__WIN32__); 24 | # endif 25 | # ifdef __USER_LABEL_PREFIX__ 26 | defstr(__USER_LABEL_PREFIX__); 27 | # endif 28 | # ifdef __i386__ 29 | defint(__i386__); 30 | # endif 31 | # ifdef __i586__ 32 | defint(__i586__); 33 | # endif 34 | # ifdef __linux__ 35 | defint(__linux__); 36 | # endif 37 | return 0; 38 | } 39 | -------------------------------------------------------------------------------- /maru-2.4/compile-irl.l: -------------------------------------------------------------------------------- 1 | ;;; compile-irl.l -*- coke -*- 2 | ;;; 3 | ;;; ./eval compile-irl.l .irl 4 | 5 | (require "ir.k") 6 | (require "text-parser.l") 7 | 8 | (set text-parser-invoke-rule text-parser-invoke-rule-with-recursion) 9 | 10 | (define-function param-list-types (pl) (map car pl)) 11 | (define-function param-list-decls (pl) (map (lambda (p) `(ir-arg ',(cadr p) ,(car p))) pl)) 12 | 13 | (require "irl.g.l") 14 | 15 | (while *arguments* 16 | (let* ((file (next-argument)) 17 | (source (contents-of-file-named file)) 18 | (parser (text-parser-for-on source)) 19 | (program (if ($program parser) (-result parser) (error "syntax error")))) 20 | (print "/*") 21 | (map (lambda (x) (print "\n ") (println x)) program) 22 | (println "*/") 23 | (eval 24 | `(let ((ir (ir-new ()))) 25 | ,@program 26 | (ir-gen-main ir))))) 27 | -------------------------------------------------------------------------------- /maru-1.0/Makefile: -------------------------------------------------------------------------------- 1 | ARCHFLAG = # -march=i686 2 | ARCHFLAG = -m32 3 | CFLAGS = -v -Wall -g $(ARCHFLAG) # -Os 4 | 5 | .SUFFIXES : 6 | 7 | all : opt eval2 8 | 9 | boot-eval : boot-eval.c 10 | gcc -g $(CFLAGS) -o boot-eval boot-eval.c 11 | 12 | opt : .force 13 | $(MAKE) CFLAGS="$(CFLAGS) -O3 -fomit-frame-pointer -DNDEBUG" boot-eval 14 | 15 | debuggc : .force 16 | $(MAKE) CFLAGS="$(CFLAGS) -DDEBUGGC=1" boot-eval 17 | 18 | eval : *.l boot-eval 19 | time ./boot-eval boot.l emit.l eval.l > eval.s 20 | gcc -c -m32 -o eval.o eval.s 21 | size eval.o 22 | gcc -v -m32 $(ARCHFLAG) -o eval eval.o 23 | 24 | eval2 : eval .force 25 | time ./eval boot.l emit.l eval.l > eval2.s 26 | diff eval.s eval2.s 27 | 28 | stats : .force 29 | cat boot.l emit.l | sed 's/.*debug.*//;s/;.*//' | sort -u | wc -l 30 | cat eval.l | sed 's/.*debug.*//;s/;.*//' | sort -u | wc -l 31 | cat boot.l emit.l eval.l | sed 's/.*debug.*//;s/;.*//' | sort -u | wc -l 32 | 33 | clean : .force 34 | rm -f *~ *.o boot-eval eval *.s 35 | rm -rf *.dSYM 36 | 37 | .force : 38 | -------------------------------------------------------------------------------- /maru-2.4/trie.k: -------------------------------------------------------------------------------- 1 | (define-structure (suffixes key value)) 2 | 3 | (define-function trie-new key-value (new (array) (car key-value) (cadr key-value))) 4 | 5 | (define-function trie-suffix-at (trie key) 6 | (array-detect suffix (-suffixes trie) 7 | (and suffix (= key (-key suffix))))) 8 | 9 | (define-function trie-append-suffix (trie suffix) 10 | (array-append (-suffixes trie) suffix)) 11 | 12 | (define-function trie-at (trie keys) 13 | (while (and trie keys) 14 | (set trie (trie-suffix-at trie (car keys))) 15 | (set keys (cdr keys))) 16 | (and trie (-value trie))) 17 | 18 | (define-function set-trie-at (trie keys value) 19 | (while keys 20 | (let ((key (car keys))) 21 | (set trie (or (trie-suffix-at trie key) 22 | (trie-append-suffix trie (trie-new key))))) 23 | (set keys (cdr keys))) 24 | (set (-value trie) value)) 25 | 26 | (define-function trie-print (trie) 27 | (and trie 28 | (let () 29 | (println (-value trie)) 30 | (array-do suffix (-suffixes trie) (trie-print suffix))))) 31 | -------------------------------------------------------------------------------- /maru-2.4/test-dc.g: -------------------------------------------------------------------------------- 1 | : () 2 | 3 | error = -> (error "syntax error near: "(parser-stream-context self.source)) ; 4 | 5 | space = " " | "\t" ; 6 | eol = "\r" "\n"* | "\n" "\r"* ; 7 | comment = "#" (!eol .)* ; 8 | _ = (space | eol | comment)* ; 9 | 10 | LPAREN = "(" _ ; 11 | RPAREN = ")" _ ; 12 | STAR = "*" _ ; 13 | SLASH = "/" _ ; 14 | PLUS = "+" _ ; 15 | MINUS = "-" _ ; 16 | 17 | float = ([+-]?[0-9]+"."[0-9]+("e"[+-]?[0-9]+)?)@$:n _ -> (string->double n) 18 | | ([+-]?[0-9]+ "e"[+-]?[0-9]+ )@$:n _ -> (string->double n) ; 19 | integer = ([+-]?[0-9]+)@$:n _ -> (string->long n) ; 20 | number = float | integer ; 21 | 22 | primary = number 23 | | LPAREN expression:e RPAREN -> e 24 | ; 25 | 26 | mulop = primary:l ( STAR primary:r -> (* l r):l 27 | | SLASH primary:r -> (/ l r):l 28 | )* -> l ; 29 | 30 | addop = mulop:l ( PLUS mulop:r -> (+ l r):l 31 | | MINUS mulop:r -> (- l r):l 32 | )* -> l ; 33 | 34 | expression = addop:e -> (println e) ; 35 | 36 | program = _ expression* _ (!. | error) ; 37 | -------------------------------------------------------------------------------- /maru-2.4/record-case.l: -------------------------------------------------------------------------------- 1 | (define-function make-record-case-getter (depth) 2 | (if (< 0 depth) 3 | (list 'cdr (make-record-case-getter (- depth 1))) 4 | '_exp_)) 5 | 6 | (define-function make-record-case-inits (vars depth) 7 | (cond 8 | ((pair? vars) 9 | (cons (list (car vars) (list 'car (make-record-case-getter depth))) 10 | (make-record-case-inits (cdr vars) (+ depth 1)))) 11 | ((symbol? vars) 12 | (list (list vars (make-record-case-getter depth)))))) 13 | 14 | (define-function make-record-cases (cases) 15 | (if (pair? cases) 16 | (let* ((case (car cases)) 17 | (tag (car case)) 18 | (vars (cadr case)) 19 | (body (cddr case))) 20 | (if (= 'else tag) 21 | (cdr case) 22 | `((if (= _tag_ ,(list 'quote tag)) 23 | (let ,(make-record-case-inits vars 1) ,@body) 24 | ,@(make-record-cases (cdr cases)))))))) 25 | 26 | (define-form record-case (exp . cases) 27 | `(let* ((_exp_ ,exp) 28 | (_tag_ (car _exp_))) 29 | ,@(make-record-cases cases))) 30 | 31 | (define-form get-record (exp vars . body) 32 | `(let ((_exp_ ,exp)) 33 | (let ,(make-record-case-inits vars 0) ,@body))) 34 | -------------------------------------------------------------------------------- /maru-2.4/test-peg.l: -------------------------------------------------------------------------------- 1 | ;; (require "parser.l") 2 | ;; (require "peg.l") 3 | ;; (require "peg-compile.l") 4 | 5 | (let* ((g (input-stream-up-to (input-stream (open "peg.g") "peg.g") *end*)) 6 | (s (string-stream g)) 7 | (p (new )) 8 | (r (array->list (parse-all p s)))) 9 | ;;(map println r) 10 | ;;(println "----------------------------------------------------------------") 11 | (parse-from p (list-stream r) $gen_cola) 12 | (map dumpln (-result p)) 13 | ($space p) 14 | (and (!= *end* (parser-stream-peek (-source p))) 15 | (println "ERROR NEAR: "(parser-stream-peek (-source p)))) 16 | ) 17 | 18 | ; (map println (array->list (parse-all (new ) (string-stream peg-grammar-string)))) 19 | 20 | ;(define peg-ir (array->list (parse-all (new ) (string-stream peg-grammar-string)))) 21 | 22 | ;(map println peg-ir) 23 | 24 | ;; (define-selector $repl) 25 | 26 | ;; (define-method $repl (source) 27 | ;; (set self.source source) 28 | ;; (while ($start self) 29 | ;; (println (eval self.result)))) 30 | 31 | ;; ($repl (parser-with-input (parser-with-input (input-stream *input*)))) 32 | -------------------------------------------------------------------------------- /maru-2.4/buffer.c: -------------------------------------------------------------------------------- 1 | struct buffer 2 | { 3 | wchar_t *buffer; 4 | int size; 5 | int position; 6 | }; 7 | 8 | #define BUFFER_INITIALISER { 0, 0, 0 } 9 | 10 | static void buffer_reset(struct buffer *b) { b->position= 0; } 11 | 12 | #if 0 13 | static int buffer_position(struct buffer *b) { return b->position; } 14 | #endif 15 | 16 | #if 0 17 | static int buffer_last(struct buffer *b) { return (b->position > 0) ? b->buffer[b->position - 1] : -1; } 18 | #endif 19 | 20 | #if 0 21 | static int buffer_read(struct buffer *b) 22 | { 23 | int c= b->buffer[b->position++]; 24 | if (!c) b->position--; 25 | return c; 26 | } 27 | #endif 28 | 29 | static void buffer_append(struct buffer *b, int c) 30 | { 31 | if (b->position == b->size) 32 | b->buffer= b->buffer 33 | ? realloc(b->buffer, sizeof(wchar_t) * (b->size *= 2)) 34 | : malloc(sizeof(wchar_t) * (b->size= 32)); 35 | b->buffer[b->position++]= c; 36 | } 37 | 38 | static void buffer_appendAll(struct buffer *b, const wchar_t *s) 39 | { 40 | while (*s) buffer_append(b, *s++); 41 | } 42 | 43 | #if 0 44 | static void buffer_seek(struct buffer *b, int off) 45 | { 46 | if (off < 0) { if ((b->position += off) < 0) b->position= 0; } 47 | else { while (off--) buffer_append(b, 0); } 48 | } 49 | #endif 50 | 51 | static wchar_t *buffer_contents(struct buffer *b) 52 | { 53 | buffer_append(b, 0); 54 | b->position--; 55 | return (wchar_t *)b->buffer; 56 | } 57 | -------------------------------------------------------------------------------- /maru-2.4/libgc.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | struct _header 4 | { 5 | GC_APP_HEADER 6 | int size; 7 | }; 8 | 9 | #define hdr2ptr(ptr) ((void *)((struct _header *)(ptr) + 1)) 10 | #define ptr2hdr(ptr) ( ((struct _header *)(ptr) - 1)) 11 | 12 | static inline void *GC_malloc_z(size_t size) 13 | { 14 | struct _header *hdr= GC_malloc(sizeof(struct _header) + size); 15 | memset(hdr, 0, sizeof(struct _header) + size); 16 | hdr->size= size; 17 | return hdr2ptr(hdr); 18 | } 19 | 20 | static inline void *GC_malloc_atomic_z(size_t size) 21 | { 22 | struct _header *hdr= GC_malloc(sizeof(struct _header) + size); 23 | memset(hdr, 0, sizeof(struct _header) + size); 24 | hdr->size= size; 25 | return hdr2ptr(hdr); 26 | } 27 | 28 | static inline void *GC_realloc_z(void *ptr, size_t size) 29 | { 30 | struct _header *hdr= GC_realloc(ptr2hdr(ptr), sizeof(struct _header) + size); 31 | return hdr2ptr(hdr); 32 | } 33 | 34 | #define FUDGE 0 35 | 36 | #define GC_malloc(size) GC_malloc_z(size) 37 | #define GC_malloc_atomic(size) GC_malloc_atomic_z(size) 38 | #define GC_realloc(ptr, size) GC_realloc_z(ptr, size) 39 | 40 | #define GC_size(ptr) (ptr2hdr(ptr)->size) 41 | #define GC_atomic(obj) (ptr2hdr(obj)->type == Long || ptr2hdr(obj)->type == Double || ptr2hdr(obj)->type == Symbol || ptr2hdr(obj)->type == Subr) 42 | 43 | #define GC_add_root(oopp) 44 | 45 | #define GC_PROTECT(obj) 46 | #define GC_UNPROTECT(obj) 47 | -------------------------------------------------------------------------------- /maru-2.4/port.l: -------------------------------------------------------------------------------- 1 | (define-method ->string () self) 2 | (define-method ->string () (symbol->string self)) 3 | (define-method ->string () (long->string self)) 4 | (define-method ->string () (double->string self)) 5 | 6 | (define-structure (buffer column)) 7 | 8 | (define-function port options (new (car options) 0)) 9 | 10 | (define-function string-port () (new (array) 0)) 11 | (define-function console-port () (new () 0)) 12 | 13 | (define-method do-print () (print "")) 14 | 15 | (define-function port-contents (p) 16 | (let ((buf (-buffer p))) 17 | (and buf (array->string buf)))) 18 | 19 | (define-method port-put (char) 20 | (if self.buffer 21 | (array-append self.buffer char) 22 | (print (format "%lc" char))) 23 | (set self.column 24 | (if (or (= char ?\n) (= char ?\r)) 25 | 0 26 | (+ self.column 1))) 27 | char) 28 | 29 | (define-method port-write-seq (seq) 30 | (for-each (->string seq) (lambda (x) (port-put self x)))) 31 | 32 | (define-method port-write seqs 33 | (list-do seq seqs (port-write-seq self seq))) 34 | 35 | (define-method port-newline () 36 | (and (> self.column 0) 37 | (port-put self ?\n))) 38 | 39 | (define-method port-indent (col) 40 | (for (i 0 col) (port-put self ? ))) 41 | 42 | (define-method port-newline-indent (col) 43 | (port-newline self) 44 | (port-indent self col)) 45 | -------------------------------------------------------------------------------- /maru-2.4/wcs.c: -------------------------------------------------------------------------------- 1 | #define _WIDEN(x) L ## x 2 | #define WIDEN(x) _WIDEN(x) 3 | 4 | #include 5 | 6 | static wchar_t *mbs2wcs(char *mbs) 7 | { 8 | static wchar_t *wcs= 0; 9 | static size_t bufSize= 0; 10 | size_t len= strlen(mbs) + 1; 11 | if (bufSize < len) 12 | { 13 | wcs= wcs ? (wchar_t *)realloc(wcs, sizeof(wchar_t) * len) : (wchar_t *)malloc(sizeof(wchar_t) * len); 14 | bufSize= len; 15 | } 16 | mbstowcs(wcs, mbs, bufSize); 17 | return wcs; 18 | } 19 | 20 | static char *wcs2mbs(wchar_t *wcs) 21 | { 22 | static char *mbs= 0; 23 | static size_t bufSize= 0; 24 | size_t len= 6 * wcslen(wcs) + 1; 25 | if (bufSize < len) { 26 | mbs= mbs ? (char *)realloc(mbs, len) : (char *)malloc(len); 27 | bufSize= len; 28 | } 29 | wcstombs(mbs, wcs, bufSize); 30 | return mbs; 31 | } 32 | 33 | 34 | #if defined(__MACH__) && !defined(__MAC_10_7) 35 | 36 | static wchar_t *wcsdup(wchar_t *s) 37 | { 38 | size_t len= wcslen(s) + 1; 39 | wchar_t *t= malloc(sizeof(wchar_t) * len); 40 | if (t) wcscpy(t, s); 41 | return t; 42 | } 43 | 44 | #endif 45 | 46 | 47 | #if 0 48 | 49 | static void wperror(wchar_t *s) 50 | { 51 | perror(wcs2mbs(s)); 52 | } 53 | 54 | static FILE *wfopen(wchar_t *wpath, wchar_t *wmode) 55 | { 56 | size_t pathlen= wcslen(wpath), modelen= wcslen(wmode); 57 | char *path= malloc(sizeof(wchar_t) * (pathlen + 1)); wcstombs(path, wpath, pathlen); 58 | char *mode= malloc(sizeof(wchar_t) * (modelen + 1)); wcstombs(mode, wmode, modelen); 59 | FILE *fp= fopen(path, mode); 60 | free(path); 61 | free(mode); 62 | return fp; 63 | } 64 | 65 | #endif 66 | -------------------------------------------------------------------------------- /maru-2.4/print-structure.l: -------------------------------------------------------------------------------- 1 | (define-function list-index-of (key list) 2 | (let ((i 0)) 3 | (while (and list (!= key (car list))) 4 | (incr i) 5 | (set list (cdr list))) 6 | (and list i))) 7 | 8 | (define-function indent (n . objs) 9 | (for (i 0 n) (print " ")) 10 | (and objs (apply print objs))) 11 | 12 | (define print-structure-fields) ;; forward 13 | 14 | (define-function default-print-structure (self n) 15 | (let ((t (type-of self))) 16 | (if (<= t ) 17 | (dumpln self) 18 | (print-structure-fields self (+ n 1) (array-at %structure-fields t))))) 19 | 20 | (define-selector print-structure (self n) ;; <--- this is the entry point, n = indentation level 21 | (default-print-structure self n)) 22 | 23 | (define-selector print-structure-simply? (self) ()) 24 | 25 | (define-method print-structure-simply? () 1) 26 | (define-method print-structure-simply? () 1) 27 | (define-method print-structure-simply? () 1) 28 | (define-method print-structure-simply? () 1) 29 | (define-method print-structure-simply? () 1) 30 | 31 | (define-function print-structure-fields (self n fields) 32 | (let* ((t (type-of self)) 33 | (m (array-at %structure-fields t)) 34 | (i ())) 35 | (println (array-at %type-names t) " {") 36 | (indent (- n 1)) 37 | (while (pair? fields) 38 | (let* ((field (car fields)) 39 | (value (oop-at self (list-index-of field m)))) 40 | (if (set i (print-structure-simply? value)) 41 | (print " "field"="value) 42 | (print " "field"=") 43 | (print-structure value n) 44 | (indent (- n 1)))) 45 | (set fields (cdr fields))) 46 | (and i (let () (println) (indent (- n 1)))) 47 | (println "}"))) 48 | 49 | (define-method print-structure (n) 50 | (print "( ") 51 | (print-structure self.head (+ n 1)) 52 | (while (pair? (set self (cdr self))) 53 | (indent (+ n 1)) 54 | (print-structure self.head (+ n 1))) 55 | (and self 56 | (let () 57 | (indent (+ n 1)) 58 | (print ". ") 59 | (print-structure self (+ n 1)))) 60 | (indent n ")\n")) 61 | -------------------------------------------------------------------------------- /maru-2.4/buffer.k: -------------------------------------------------------------------------------- 1 | (define-structure (size capacity data)) 2 | 3 | (define-function buffer-new (capacity) (new 0 capacity (data capacity))) 4 | 5 | (define-function buffer-grow (self) 6 | (with-instance-accessors 7 | (let* ((cap (* 2 (max self.size 16))) 8 | (big (data cap))) 9 | (for (i 0 self.size) 10 | (set (byte-at big i) (byte-at self.data i))) 11 | (set self.data big) 12 | (set self.capacity cap)))) 13 | 14 | (define-function buffer-write (self byte) 15 | (with-instance-accessors 16 | (or (< self.size self.capacity) (buffer-grow self)) 17 | (set (byte-at self.data self.size) byte) 18 | (incr self.size))) 19 | 20 | (define-function buffer-at (self offset) 21 | (with-instance-accessors 22 | (and (<= 0 offset) 23 | (< offset self.size) 24 | (byte-at self.data offset)))) 25 | 26 | (define-function buffer-set-byte-at (self offset value) 27 | (with-instance-accessors 28 | (and (<= 0 offset) 29 | (< offset self.size) 30 | (set-byte-at self.data offset value)))) 31 | 32 | (define-function buffer-set-long-at (self offset value) 33 | (buffer-set-byte-at self offset value ) 34 | (buffer-set-byte-at self (+ offset 1) (>> value 8 )) 35 | (buffer-set-byte-at self (+ offset 2) (>> value 16)) 36 | (buffer-set-byte-at self (+ offset 3) (>> value 24))) 37 | 38 | (define-function buffer-reset (self) (set (-size self) 0)) 39 | (define-function buffer-size (self) (-size self)) 40 | 41 | (define-function buffer-save (self path) 42 | (with-instance-accessors 43 | (let ((f (or (open path "w" -1) 44 | (error "cannot open for writing: "path)))) 45 | (for (i 0 self.size) (putb (byte-at self.data i) f)) 46 | (close f)))) 47 | 48 | (define-function buffer-address (self) 49 | (address-of (-data self))) 50 | 51 | (define-function buffer-call (self offset) 52 | (native-call (+ (address-of (-data self)) offset))) 53 | 54 | ;; (let ((b (buffer-new 4096))) 55 | ;; (buffer-write b 65) 56 | ;; (buffer-write b 66) 57 | ;; (buffer-write b 67) 58 | ;; (buffer-save b "a.out")) 59 | -------------------------------------------------------------------------------- /maru-2.4/data-stream.k: -------------------------------------------------------------------------------- 1 | (define-structure (data position limit)) 2 | 3 | (define-function data-stream rest 4 | (let* ((size (or (car rest) 32)) 5 | (coln (or (cadr rest) (data size)))) 6 | (new coln 0 size))) 7 | 8 | (with-instance-accessors 9 | 10 | (define-function data-stream-data (self) self.data) 11 | (define-function data-stream-position (self) self.position) 12 | (define-function data-stream-size (self) self.limit) 13 | (define-function data-stream-origin (self) (address-of self.data)) 14 | (define-function data-stream-address (self) (+ (address-of self.data) self.position)) 15 | 16 | (define-function data-stream-grow (self) (let* ((lim (max 8 (* self.limit 2))) 17 | (old self.data) 18 | (big (data lim))) 19 | (for (i 0 self.limit) (set-byte-at big i (byte-at old i))) 20 | (set self.data big) 21 | (set self.limit lim) 22 | self)) 23 | 24 | (define-function data-stream-at-end? (self) (>= self.position self.limit)) 25 | 26 | (define-function data-stream-truncate (self) (set self.limit self.position)) 27 | 28 | (define-function data-stream-rewind (self . rest) (set self.position (or (car rest) 0))) 29 | 30 | (define-function data-stream-byte-at (self n) (let ((i (+ self.position n))) 31 | (and (< i self.limit) 32 | (byte-at self.data i)))) 33 | 34 | (define-function data-stream-set-byte-at (self n b) (let ((i (+ self.position n))) 35 | (and (>= i self.limit) (data-stream-grow self)) 36 | (set-byte-at self.data i b))) 37 | 38 | (define-function data-stream-get-byte (self) (and (< self.position self.limit) 39 | (let ((b (byte-at self.data self.position))) 40 | (incr self.position) 41 | b))) 42 | 43 | (define-function data-stream-put-byte (self b) (while (>= self.position self.limit) (data-stream-grow self)) 44 | (set-byte-at self.data self.position b) 45 | (incr self.position) 46 | b) 47 | 48 | (define-function data-stream-contents (self) 49 | (let ((in self.data) 50 | (out (data self.position))) 51 | (for (i 0 self.position) (set-byte-at out i (byte-at in i))) 52 | out)) 53 | ) 54 | -------------------------------------------------------------------------------- /maru-2.4/repl.l: -------------------------------------------------------------------------------- 1 | (define-function array-append-all (arr . vals) 2 | (list-do val vals (array-append arr val))) 3 | 4 | (load "parser.l") 5 | (load "peg-compile.l") 6 | (load "peg.l") 7 | 8 | (define *parser-stream*) 9 | 10 | (define-form grammar-extend (name . rules) 11 | (println "GRAMMAR EXTEND" rules) 12 | (exit 0)) 13 | 14 | (define-form grammar-define (name parent fields . rules) 15 | (eval `(define-class ,name ,parent ,fields)) 16 | (peg-compile-rules name rules) 17 | ()) 18 | 19 | (define-class ()) 20 | 21 | ;;(load "port.l") 22 | (load "pretty-print.l") 23 | 24 | (define-form grammar-eval (rules expr) 25 | ;;(println "GRAMMAR EVAL ") (pretty-print (expand rules)) 26 | (peg-compile-rules ' rules) 27 | (and expr (peg-compile-rules ' (list (list 'start expr)))) 28 | ;;(println "GRAMMAR "*temp-grammar*) 29 | (and expr 30 | `(let ((_p (parser *parser-stream*))) 31 | ($start _p) 32 | (-result _p)))) 33 | 34 | ;;(define-eval (self) ($start self *parser-stream*)) 35 | 36 | (define-function repl-parser-stream (stream prompt) 37 | (let ((p (parser stream)) 38 | (s *parser-stream*) 39 | (v)) 40 | (set *parser-stream* stream) 41 | (while (let () 42 | (and prompt (print prompt)) 43 | ($sexpression p)) 44 | (set v (-result p)) 45 | ;;(println "*** " v) 46 | (set v (eval v)) 47 | ;;(println " => "v) 48 | ) 49 | ($sspace p) 50 | (or (parser-stream-at-end *parser-stream*) 51 | (let () 52 | (print "\nsyntax error in read-eval-print near: ") 53 | (while (not (parser-stream-at-end *parser-stream*)) 54 | (print (format "%c" (parser-stream-next *parser-stream*)))) 55 | (println "") 56 | (error "abort"))) 57 | (set *parser-stream* s) 58 | v)) 59 | 60 | (define-function repl-stream (stream prompt) (repl-parser-stream (parser-stream stream) prompt)) 61 | (define-function repl-file (file prompt path) (repl-stream (parser-input-stream (input-stream file path)) prompt)) 62 | (define-function repl-path (path prompt) (repl-file (or (open path) (error "cannot open: "path)) prompt path)) 63 | 64 | (while *arguments* (repl-path (next-argument) ())) 65 | 66 | (exit 0) 67 | -------------------------------------------------------------------------------- /maru-2.4/pretty-print.l: -------------------------------------------------------------------------------- 1 | (require "port.l") 2 | 3 | (define pretty-on) ;; forward 4 | 5 | (define-selector do-pretty (self p col) 6 | (let* ((t (type-of self)) 7 | (n (array-at %type-names t))) 8 | (if n 9 | (port-write p (symbol->string n)) 10 | (port-write p "string t)">")))) 11 | 12 | (define-method do-pretty (port col) (port-write port (symbol->string self))) 13 | (define-method do-pretty (port col) (port-write port "()")) 14 | (define-method do-pretty (port col) (port-write port (long->string self))) 15 | (define-method do-pretty (port col) (port-write port (double->string self))) 16 | (define-method do-pretty (port col) (port-write port "\""self"\"")) 17 | (define-method do-pretty (port col) (port-write port (symbol->string self))) 18 | 19 | (define-method do-pretty (port col) 20 | (port-newline-indent port col) 21 | (port-write port "(") 22 | (set col (+ col 2)) 23 | (while (pair? self) 24 | (pretty-on (car self) port col) 25 | (set self (cdr self))) 26 | (and self 27 | (let () 28 | (port-write port " .") 29 | (pretty-on self port col))) 30 | (port-write port ")")) 31 | 32 | (define-method do-pretty (port col) 33 | (port-newline-indent port col) 34 | (port-write port "[") 35 | (set col (+ col 2)) 36 | (array-do x self (pretty-on x port col)) 37 | (port-write port "]")) 38 | 39 | (define-method do-pretty (port col) (port-write port "")) 40 | (define-method do-pretty
(port col) (port-write port "")) 41 | (define-method do-pretty (port col) (port-write port "")) 42 | (define-method do-pretty (port col) (port-write port "")) 43 | (define-method do-pretty (port col) (port-write port "")) 44 | (define-method do-pretty (port col) (port-write port "")) 45 | (define-method do-pretty (port col) (port-write port "")) 46 | 47 | (define-function pretty-on (obj p col) 48 | (and (>= (-column p) col) (port-put p ? )) 49 | (do-pretty obj p col)) 50 | 51 | (define-function pretty-string (obj) 52 | (let ((p (string-port))) 53 | (pretty-on obj p 0) 54 | (array->string (-buffer p)))) 55 | 56 | (define-function pretty-print (obj) 57 | (println (pretty-string obj)) 58 | obj) 59 | 60 | ;;(pretty-print (read "pretty-print.l")) 61 | -------------------------------------------------------------------------------- /maru-2.4/test-recursion.l: -------------------------------------------------------------------------------- 1 | ;; From: Bryan Ford 2 | ;; Subject: [PEG] Fun with left recursion 3 | ;; 4 | ;; Left recursion in PEGs indeed seems like an interesting can of worms. For those 5 | ;; interested, I'm wondering how a few example grammars behave under your preferred 6 | ;; left-recursive parsing technique, and how you think they should behave. 7 | 8 | (peg-enable-recursion) 9 | 10 | (define-function input-between (a b) 11 | (list->string (list-from-to a b))) 12 | 13 | { 14 | sync = (!"." .)* "." ; 15 | 16 | beg = -> (-position self.source) ; 17 | end = .:beg -> (println "input matched: \""(input-between beg (-position self.source))"\"") sync ; 18 | fail = -> (println "could not match input") sync ; 19 | 20 | space = [ \t] ; 21 | eol = [\n\r] ; 22 | blank = space | eol ; 23 | comment = "//" (!eol .)* ; 24 | _ = (blank | comment)* ; 25 | } 26 | 27 | ;; First, a trivially evil left-recursive grammar: 28 | ;; 29 | ;; S <- S 30 | ;; 31 | ;; For example, does your parser detect and reject this somehow, or does it behave the same 32 | ;; as 'S <- f'? (I hope it doesn't result in an infinite loop at runtime anyway. :) ) 33 | 34 | { 35 | S = S ; 36 | _ beg:b S {end b} | fail 37 | } 38 | 39 | hello. 40 | 41 | ;; Now a grammar that's weird, not necessarily evil, in a slightly more subtle way: 42 | ;; 43 | ;; S <- S / a 44 | ;; 45 | ;; Does this behave the same as 'S <- a', or do something else? How should it behave? 46 | 47 | { 48 | S = S | "a" ; 49 | _ beg:b S {end b} | fail 50 | } 51 | 52 | aaaa. 53 | 54 | ;; Cranking up the evilness factor one notch with a mutually left-recursive grammar... 55 | ;; 56 | ;; S <- T / a 57 | ;; T <- S / &a 58 | ;; 59 | ;; Given the input string "a", does this behave the same as 'S <- a' (succeeding 60 | ;; and consuming) or the same as 'S <- &a' (succeeding but consuming no input)? 61 | 62 | { 63 | S = T | "a" ; 64 | T = S | &"a" ; 65 | _ beg:b S {end b} | fail 66 | } 67 | 68 | aaaa. 69 | 70 | ;; Do S and T behave the same way or differently? Should they? 71 | 72 | { _ beg:b T {end b} | fail } 73 | 74 | aaaa. 75 | 76 | ;; Now, another grammar that's not necessarily evil but strange in a slightly different way: 77 | ;; 78 | ;; S <- Saa / a / 79 | ;; 80 | ;; Given the input string 'aaaa', for example, does/should this grammar consume just 3 or 81 | ;; all 4 a's, or does it do something else? What should it do? 82 | 83 | { 84 | S = S "a" "a" | "a" | -> () ; 85 | x = _ beg:b S {end b} | fail ; 86 | x x 87 | } 88 | 89 | aaaa. 90 | aaaaaaaaaaaaa. 91 | 92 | ;; ---------------- OUTPUT FROM THIS PROGRAM ---------------- 93 | ;; 94 | ;; could not match input 95 | ;; input matched: "a" 96 | ;; input matched: "" 97 | ;; input matched: "aaaa" 98 | ;; input matched: "aaaaaaaaaaaaa" 99 | 100 | { 101 | digit = [0-9]:d -> (- d ?0) ; 102 | 103 | term = term:a "+" digit:b -> `(add ,a ,b) 104 | | digit 105 | ; 106 | 107 | (_ term)*:t -> (map dumpln t) 108 | } 109 | 110 | 0 111 | 1 112 | 1 113 | 1 114 | 0+1+2+3+4+5+6+7+8+9 115 | -------------------------------------------------------------------------------- /maru-2.4/dsm-x86.k: -------------------------------------------------------------------------------- 1 | (define r32 (list->array (list "%eax" "%ecx" "%edx" "%ebx" "%esp" "%ebp" "%esi" "%edi"))) 2 | 3 | (define-function between (a b c) (and (>= a b) (<= a c))) 4 | 5 | (define-function getMRM (d) 6 | (let* ((mrm (getB d)) 7 | (mod (>> mrm 6)) 8 | (src (& 7 mrm)) 9 | (sib) 10 | (dsp)) 11 | (and (= 4 src) (!= 3 mod) (set sib (getB d))) 12 | (and (= 1 mod) (set dsp (getB d))) 13 | (and (= 2 mod) (set dsp (getL d))) 14 | (values mrm sib dsp))) 15 | 16 | (define-function mrm-reg (mrm) (& 7 (>> mrm 3))) 17 | 18 | (define-function mrm-write (p mrm sib dsp) 19 | (let* ((mod (>> mrm 6)) 20 | (src (& 7 mrm)) 21 | (idx) 22 | (mul)) 23 | (and sib 24 | (let ((sr (& 7 (>> sib 3)))) 25 | (set src (& sib 7)) 26 | (and (!= 4 sr) (set idx sr)) 27 | (set mul (<< 1 (>> sib 6))))) 28 | (cond 29 | ((= 0 mod) (port-write p "("(array-at r32 src))) 30 | ((= 1 mod) (port-write p dsp"("(array-at r32 src))) 31 | ((= 2 mod) (port-write p dsp"("(array-at r32 src))) 32 | ((= 3 mod) (port-write p (array-at r32 src)))) 33 | (and idx (port-write p ","(array-at r32 idx)"*"mul)) 34 | (cond 35 | ((= 0 mod) (port-write p ")")) 36 | ((= 1 mod) (port-write p ")")) 37 | ((= 2 mod) (port-write p ")"))))) 38 | 39 | (define-function rm32-r32 (d p op) 40 | (let (mrm sib dsp) 41 | (receive (getMRM d) mrm sib dsp) 42 | (port-write p op"\t"(array-at r32 (mrm-reg mrm))",") 43 | (mrm-write p mrm sib dsp))) 44 | 45 | (define-function r32-rm32 (d p op) 46 | (let (mrm sib dsp) 47 | (receive (getMRM d) mrm sib dsp) 48 | (port-write p op"\t") 49 | (mrm-write p mrm sib dsp) 50 | (port-write p ","(array-at r32 (mrm-reg mrm))))) 51 | 52 | (define-function r32-imm32 (d p op) 53 | (let (mrm sib dsp) 54 | (receive (getMRM d) mrm sib dsp) 55 | (port-write p op"\t$"(getL d)",") 56 | (mrm-write p mrm sib dsp))) 57 | 58 | (define-function o-rm32-imm8 (d p ops) 59 | (let (mrm sib dsp) 60 | (receive (getMRM d) mrm sib dsp) 61 | (port-write p (nth (mrm-reg mrm) ops)"\t$"(getB d)",") 62 | (mrm-write p mrm sib dsp))) 63 | 64 | (define-function o-rm32-imm32 (d p ops) 65 | (let (mrm sib dsp) 66 | (receive (getMRM d) mrm sib dsp) 67 | (port-write p (nth (mrm-reg mrm) ops)"\t$"(getL d)",") 68 | (mrm-write p mrm sib dsp))) 69 | 70 | (define-function jb (d p op) (port-write p op"\t"(getD1 d))) 71 | (define-function jv (d p op) (port-write p op"\t"(getD4 d))) 72 | 73 | (define-function disassemble-on (d p) 74 | (let ((b0 (getB d))) 75 | (cond 76 | ((= b0 0x01 ) (rm32-r32 d p "addl")) 77 | ((= b0 0x03 ) (r32-rm32 d p "addl")) 78 | ((= b0 0x31 ) (rm32-r32 d p "xorl")) 79 | ((between b0 0x40 0x47) (port-write p "incl\t"(array-at r32 (& 0x7 b0)))) 80 | ((between b0 0x50 0x57) (port-write p "pushl\t"(array-at r32 (& 0x7 b0)))) 81 | ((= b0 0x75 ) (jb d p "jnz")) 82 | ((= b0 0x81 ) (o-rm32-imm32 d p '(addl orl adcl sbbl andl subl xorl cmpl))) 83 | ((= b0 0x83 ) (o-rm32-imm8 d p '(addl orl adcl sbbl andl subl xorl cmpl))) 84 | ((= b0 0x89 ) (rm32-r32 d p "movl")) 85 | ((= b0 0x8b ) (r32-rm32 d p "movl")) 86 | ((= b0 0x90 ) (port-write p "nop")) 87 | ((between b0 0x91 0x97) (port-write p "xchgl\t%eax,"(array-at r32 (& 0x7 b0)))) 88 | ((between b0 0xb8 0xbf) (port-write p "movl\t"(long->string (getL d))","(array-at r32 (& 0x7 b0)))) 89 | ((= b0 0xc3 ) (port-write p "ret")) 90 | ((= b0 0xc7 ) (r32-imm32 d p "movl")) 91 | ((= b0 0xc9 ) (port-write p "leave")) 92 | ((= b0 0xe8 ) (jv d p "call")) 93 | ((= b0 0xe9 ) (jv d p "jmp")) 94 | (else (port-write p NEGATIVE FG-RED" "(format "%02x" b0)" "RESET))))) 95 | -------------------------------------------------------------------------------- /maru-2.4/define-class.l: -------------------------------------------------------------------------------- 1 | (define-function make-class-printers (fields index) 2 | (and fields 3 | (cons `(let () (print " " ',(car fields) "=") (dump (oop-at self ,index))) 4 | (make-class-printers (cdr fields) (+ index 1))))) 5 | 6 | (define-function make-class-printer (tname fields) 7 | `(define-method do-print ,tname () 8 | (print "{" ',tname) 9 | ,@(make-class-printers fields 0) 10 | (print "}"))) 11 | 12 | (define-function make-class-method (name spec) 13 | `(define-method ,(car spec) ,name ,(cadr spec) ,@(cddr spec))) 14 | 15 | (define-function make-class-init (name field init) 16 | `(set (,(concat-symbol name (concat-symbol '- field)) self) ,init)) 17 | 18 | (define-function make-class-ctor (name ctor args body) 19 | `(define-function ,ctor ,args 20 | (let ((self (new ,name))) 21 | (with-instance-accessors ,name ,@body) 22 | self))) 23 | 24 | (define-function make-class-ctor-from (name vars ctor) 25 | (cond 26 | ((symbol? ctor) (make-class-ctor name ctor vars (with-map2 make-class-init name vars vars))) 27 | ((pair? ctor) (let ((cname (car ctor)) 28 | (cargs (cadr ctor)) 29 | (cbody (cddr ctor))) 30 | (if (pair? cbody) 31 | (make-class-ctor name cname cargs cbody) 32 | (make-class-ctor name cname cargs (with-map2 make-class-init name cargs cargs))))) 33 | (else (error "illegal method specification: "ctor)))) 34 | 35 | (define-function make-class-functions (name vars fields specs) 36 | (and (pair? specs) 37 | (let ((func (let ((spec (car specs))) 38 | (cond 39 | ((= spec '=) (set specs (cdr specs)) (make-class-ctor-from name vars (car specs))) 40 | ((= spec '-) (set specs (cdr specs)) (make-class-ctor-from name fields (car specs))) 41 | ((= spec '@) (make-class-printer name vars)) 42 | ((pair? spec) (make-class-method name spec)) 43 | (else (error "illegal method specification: "specs)))))) 44 | (cons func (make-class-functions name vars fields (cdr specs)))))) 45 | 46 | ;; (define-class name base (fields...) ctor methods...) 47 | ;; 48 | ;; defines as a subclass of with fields from + the given 'fields...' 49 | ;; 50 | ;; 'ctor' = 51 | ;; - name constructor 'name' takes 'fields...' as parameters 52 | ;; = name 'name' takes base fields + 'fields...' as parameters 53 | ;; (name (fields2...)) 'name' takes 'fields2...' as parameters, init each field2 with argument 54 | ;; (name (parms...) body...) 'name' takes 'parms...' as parameters, executes 'body' with self.fields bound 55 | ;; 56 | ;; 'method' = 57 | ;; @ define do-print to print 'field=value' for each field 58 | ;; (selector (args) body...) define method 'selector (args...) body...' 59 | 60 | (define-form define-class (name base fields . functions) 61 | (set base (eval base)) 62 | (let* ((type (%allocate-type name)) 63 | (vars (concat-list (array-at %structure-fields base) fields)) 64 | (size (list-length vars))) 65 | (sanity-check-structure-fields name vars) 66 | (set-array-at %structure-sizes type size) 67 | (set-array-at %structure-fields type vars) 68 | (set-array-at %structure-bases type base) 69 | (let ((derived (or (array-at %structure-derivatives base) 70 | (set-array-at %structure-derivatives base (array))))) 71 | (array-append derived type)) 72 | ( eval `(define ,name ,type)) 73 | (map eval (%make-accessors name vars)) 74 | (map eval (make-class-functions name vars fields functions)) 75 | type)) 76 | 77 | ;;; ---------------------------------------------------------------- 78 | 79 | ;; (define-structure (n)) 80 | 81 | ;; (define-class (x y z) = (foo (x y) (set self.x x) (set self.y (* 2 y)) (set self.z 3)) 82 | ;; (done-print () (print "foo:"self.n"."self.x","self.y","self.z)) 83 | ;; @) 84 | 85 | ;; (println (foo 101 202)) 86 | -------------------------------------------------------------------------------- /maru-2.4/test-elf.l: -------------------------------------------------------------------------------- 1 | (require "buffer.k") 2 | 3 | (define code (buffer-new 4096)) ;; binary 4 | (define phased 1) ;; non-nil if something changed this pass 5 | (define $% 0) ;; file offset 6 | (define $$ 0) ;; last .org address 7 | (define $ 0) ;; current address 8 | 9 | (define-selector _B (gen value) (buffer-write code value) (incr $)) 10 | (define-selector _W (gen value) (_B gen (& 255 value)) (_B gen (& 255 (>> value 8)))) 11 | (define-selector _L (gen value) (_W gen (& 65535 value)) (_W gen (& 65535 (>> value 16)))) 12 | (define-selector _D1 (gen value) (_B gen value)) 13 | (define-selector _D4 (gen value) (_L gen value)) 14 | 15 | (require "asm-x86.k") 16 | 17 | (define-function define-label (name value) 18 | (or (= (eval name) value) 19 | (let () 20 | (eval (list 'set name value)) 21 | (set phased 1)))) 22 | 23 | (define-function .org (addr) (set $$ (set $ (eval addr)))) 24 | (define-form .equ (name expr) (define-label name (eval expr)) ()) 25 | (define-function .byte bytes (list-do byte bytes (_B () (eval byte)))) 26 | (define-function .half halfs (list-do half halfs (_W () (eval half)))) 27 | (define-function .long longs (list-do long longs (_L () (eval long)))) 28 | (define-function .ascii strings (list-do string strings (string-do char string (_B () char)))) 29 | 30 | (define-function movlIR (src dst) (MOVLir () src dst)) 31 | (define-function inclR (dst) (INCLr () dst)) 32 | (define-function pushlI (src) (PUSHLi () src)) 33 | (define-function addlIR (src dst) (ADDLir () src dst)) 34 | (define-function sublIR (src dst) (SUBLir () src dst)) 35 | (define-function intI (src) (_B () 0xCD) (_B () src)) 36 | 37 | (define-function assemble (program) 38 | (list-do insn program 39 | (cond 40 | ((symbol? insn) (eval (list 'define insn 0))) 41 | ((= '.equ (car insn)) (eval (list 'define (cadr insn) 0))))) 42 | (set phased 1) 43 | (while phased 44 | (set phased ()) 45 | (buffer-reset code) 46 | (set $$ (set $ (buffer-address code))) 47 | (list-do insn program 48 | (cond 49 | ((symbol? insn) (define-label insn $)) 50 | ((pair? insn) (eval insn)) 51 | (else (error "huh? "insn))))) 52 | ;;(println "assembled "(buffer-size code)" bytes") 53 | ) 54 | 55 | (assemble '( 56 | (.org 0x08048000) 57 | ehdr (.byte 0x7f) ; ident 58 | (.ascii "ELF") 59 | (.byte 1 1 1 0) 60 | (.byte 0 0 0 0 0 0 0 0) 61 | (.half 2) ; type 62 | (.half 3) ; machine 63 | (.long 1) ; version 64 | (.long start) ; entry 65 | (.long (- phdr $$)) ; phoff 66 | (.long 0) ; shoff 67 | (.long 0) ; flags 68 | (.half ehdrsize) ; ehsize 69 | (.half phdrsize) ; phentsize 70 | (.half 1) ; phnum 71 | (.half 0) ; shentsize 72 | (.half 0) ; shnum 73 | (.half 0) ; shstrndx 74 | (.equ ehdrsize (- $ ehdr)) 75 | phdr (.long 1) ; type 76 | (.long 0) ; offset 77 | (.long $$) ; vaddr 78 | (.long $$) ; paddr 79 | (.long filesize) ; filesz 80 | (.long filesize) ; memsz 81 | (.long 5) ; flags 82 | (.long 0x1000) ; align 83 | (.equ phdrsize (- $ phdr)) 84 | start (movlIR 4 _EAX) 85 | (movlIR 1 _EBX) 86 | (movlIR msg _ECX) 87 | (movlIR msglen _EDX) 88 | (intI 0x80) 89 | (movlIR 1 _EAX) 90 | (movlIR 0 _EBX) 91 | (intI 0x80) 92 | msg (.ascii "Hello, world\n") 93 | (.equ msglen (- $ msg)) 94 | (.equ filesize (- $ $$)) 95 | end )) 96 | 97 | (buffer-save code "a.out") 98 | 99 | (assemble '( 100 | (movlIR 4 _EAX) ; write 101 | (movlIR 1 _EBX) ; stdout 102 | (movlIR msg _ECX) ; buffer 103 | (movlIR msglen _EDX) ; strlen(buffer) 104 | (intI 0x80) 105 | (movlIR 1 _EAX) ; exit 106 | (movlIR 0 _EBX) ; status 107 | (intI 0x80) 108 | msg (.ascii "Now run ./a.out for a friendly greeting\n") 109 | (.equ msglen (- $ msg)))) 110 | 111 | (buffer-call code 0) 112 | -------------------------------------------------------------------------------- /maru-2.4/test.l: -------------------------------------------------------------------------------- 1 | (println "TEST") 2 | 3 | (define *root* *globals*) 4 | 5 | (define ns1 (environment *globals*)) 6 | (define ns2 (environment *globals*)) 7 | 8 | (println *globals*) 9 | 10 | (set *globals* ns1) 11 | 12 | (println *globals*) 13 | 14 | (define a 41) 15 | (define b 42) 16 | (define c 43) 17 | 18 | (set *globals* ns2) 19 | 20 | (define a 101) 21 | (define b 102) 22 | (define c 103) 23 | 24 | (set *globals* ns1) 25 | 26 | (println a b c) 27 | 28 | (set *globals* ns2) 29 | 30 | (println a b c) 31 | 32 | (set *globals* *root*) 33 | 34 | (println (-bindings ns1)) 35 | (println (-bindings ns2)) 36 | 37 | (define-function fibs (n) 38 | (if (< n 2) 1 39 | (+ 1 (+ (fibs (- n 1)) (fibs (- n 2)))))) 40 | 41 | ;(println (fibs 5)) 42 | 43 | (let ((c)) 44 | (while (< 0 (set c (getc))) 45 | (print (format "%c" c))))This is a here-document. 46 | It shows how to embed arbitrary test in a file. 47 | (println "done") 48 | 49 | (define-structure ()) 50 | 51 | ;;(println " " (array-at %type-names )) 52 | ;;(println (array-at %structure-derivatives )) 53 | 54 | (define-class (x y)) 55 | 56 | ;;(println " " (array-at %type-names )) 57 | ;;(println (array-at %structure-sizes )) 58 | ;;(println (array-at %structure-fields )) 59 | ;;(println (array-at %structure-bases )) 60 | ;;(println (array-at %structure-derivatives )) 61 | 62 | (define-class (z)) 63 | 64 | ;;(println " " (array-at %type-names )) 65 | ;;(println (array-at %structure-sizes )) 66 | ;;(println (array-at %structure-fields )) 67 | ;;(println (array-at %structure-bases )) 68 | ;;(println (array-at %structure-derivatives )) 69 | ;;(println (array-at %structure-derivatives )) 70 | 71 | (define-class (z)) 72 | 73 | ;;(println " " (array-at %type-names )) 74 | ;;(println (array-at %structure-sizes )) 75 | ;;(println (array-at %structure-fields )) 76 | ;;(println (array-at %structure-bases )) 77 | ;;(println (array-at %structure-derivatives )) 78 | ;;(println (array-at %structure-derivatives )) 79 | 80 | (define-selector man) 81 | 82 | (define-method man () 83 | (+ (* (-x self) (-x self)) 84 | (* (-y self) (-y self)))) 85 | 86 | (let ((p2 (new )) 87 | (p3 (new ))) 88 | (set (-x p2) 3) 89 | (set (-y p2) 4) 90 | (set (-x p3) 5) 91 | (set (-y p3) 12) 92 | (set (-z p3) 13) 93 | (println (man p2)) 94 | (println (man p3))) 95 | 96 | (define-class ()) 97 | (define-class ()) 98 | 99 | (define-selector -value) 100 | (define-selector -<) 101 | (define-selector -+) 102 | (define-selector --) 103 | 104 | (define-class (value)) 105 | 106 | (define-function smallinteger (n) 107 | (let ((self (new ))) 108 | (set (-value self) n) 109 | self)) 110 | 111 | (define -1 (smallinteger 1)) 112 | (define -2 (smallinteger 2)) 113 | 114 | (define-method -value () (-value self)) 115 | (define-method -< (other) (< (-value self) (-value other))) 116 | (define-method -+ (other) (smallinteger (+ (-value self) (-value other)))) 117 | (define-method -- (other) (smallinteger (- (-value self) (-value other)))) 118 | 119 | (define-selector mfibs) 120 | 121 | (define-method mfibs () 122 | (if (-< self -2) 123 | -1 124 | (-+ -1 125 | (-+ (mfibs (-- self -1)) 126 | (mfibs (-- self -2)))))) 127 | 128 | (println (-value (mfibs (smallinteger 25)))) 129 | -------------------------------------------------------------------------------- /maru-2.4/TODO: -------------------------------------------------------------------------------- 1 | ---------------------------------------------------------------- 2 | 3 | node args should be array not list 4 | 5 | ---------------------------------------------------------------- 6 | 7 | ARGUMENTS SHOULD NOT BE CONSed 8 | 9 | push them in the caller's context 10 | refer to them as locals with negative offsets in callee 11 | need to store actual arg count somewhere? 12 | in the caller context is more flexible 13 | 14 | ---------------------------------------------------------------- 15 | 16 | debugging: 17 | read -> (cons value next location) 18 | 19 | (+ 3 4) -> (cons '+ '3 '4 ( "filename" 100 106)) 20 | 100 --^ 21 | 106---------^ 22 | 23 | (+ (+ 3 4) 1) -> (+ (+ 3 4 <"name" 3 9>) 1 <"name" 0 12>) 24 | 25 | ---------------------------------------------------------------- 26 | 27 | debugging: 28 | read -> (cons value next location) 29 | 30 | (+ 3 4) -> (cons '+ '3 '4 ( "filename" 100 106)) 31 | 100 --^ 32 | 106---------^ 33 | 34 | (+ (+ 3 4) 1) -> (+ (+ 3 4 <"name" 3 9>) 1 <"name" 0 12>) 35 | 36 | ---------------------------------------------------------------- 37 | 38 | optimise the PEG for 'select': 39 | (match-first 40 | (match-all (match-object .:a) .*:aa 41 | (match-all (match-object .:b) .*:bb 42 | (match-all (match-object .:c) .*:cc 43 | (match-all (match-object .)+:d -> (match-select (,a ,b ,c ,@d) (,aa ,bb ,cc ,@dd)) 44 | 45 | ---------------------------------------------------------------- 46 | 47 | char classes should support range syntax and not depend on order 48 | 49 | Simplify define() to avoid replicating the search loop of findVariable. 50 | 51 | Add source field to and use for error reporting. 52 | 53 | ---------------------------------------------------------------- 54 | 55 | Syntax for namespaces. 56 | 57 | reader: 58 | Foo.bar.baz -> (in (in Foo bar) baz) 59 | 60 | expand: 61 | (in x y) -> spc = findVariable(env, x)->value; 62 | var = findVariable(spc, y); 63 | 64 | ---------------------------------------------------------------- 65 | 66 | strings are arrays of ucs4 67 | symbols are ucs4 68 | read converts utf8 to ucs4 69 | write converts ucs4 to utf8 70 | 71 | tokens should contain the FILE name and the LINE number and maybe character COLUMNs for debugging 72 | 73 | put support only in peg.l, boot only in peg-boot.l 74 | 75 | make experimental/demo syntax for stdin 76 | m-expr like? 77 | Smalltalk like? 78 | make selectors be: 79 | .*: = keyword 80 | .* = binary 81 | anything else is unary 82 | 83 | put peg IR -> s-exp compiler in peg-boot and generate peg-compile.l (grammar in PEG -> compiled parser) 84 | add mechanism to instantiate in-place 85 | 86 | PEG grammar should look like structure: 87 | $> = output stream 88 | $< = input stream 89 | $* = current list result 90 | $@ = current result 91 | rules are methods defined on the structure, prefixed with $ 92 | structures inherit dynamically 93 | 94 | make eval.c eval.l use WIDE CHARACTERS 95 | 96 | propagate changes eval.c -> eval.l 97 | 98 | inheritance between structures 99 | 100 | active variables 101 | implement inst var access by name 102 | 103 | split emit.l into 104 | emit-common.l the stuff that does not depend on the target language 105 | emit-386.l static x86 code 106 | emit-c.l static C code 107 | 108 | make local variables store level delta not absolute level 109 | -> new object for each delta of free reference 110 | 111 | optimise eval.c for 112 | size check on invocation 113 | cached allocation behavior - dlist 114 | 115 | ---------------------------------------------------------------- 116 | 117 | make encode rewrite r-value variables as the value when value is subr 118 | 119 | ---------------------------------------------------------------- 120 | 121 | split type from . 122 | 123 | port streams. 124 | 125 | port PEG. 126 | 127 | ---------------------------------------------------------------- 128 | 129 | The crux of the biscuit is: If it entertains you, fine. Enjoy it. If 130 | it doesn't, then blow it out your ass. I do it to amuse myself. If I 131 | like it, I release it. If somebody else likes it, that's a bonus. 132 | -- Frank Zappa 133 | -------------------------------------------------------------------------------- /maru-2.4/test.irl: -------------------------------------------------------------------------------- 1 | // import type identifier ; 2 | // 3 | // imports a symbol from an external library. The 'identifier' contains alphanumeric 4 | // characters and '_' and must not start with a number. The 'type' is a scalar type name or a 5 | // structure name (desribed below) followed by one or more modifier suffixes. 6 | // 7 | // The scalar types are: 8 | // 9 | // int8, int16, int32, int64 = integer type with the specified number of bits 10 | // float32, float64 = floating point type with the specified number of bits 11 | // int, long, float, double = aliases for the "natural" size of each of those types 12 | // (where 'long' is guaranteed to be the same size as a 13 | // pointer) 14 | // void = no value, or unknown pointer referent type 15 | // 16 | // The modifier suffixes are: 17 | // 18 | // type * = pointer to type 19 | // type () = function of unspecified arguments that returns type 20 | // type (param-type, ...) = function of specified parameter types returning type 21 | 22 | import int() printf; // import 'printf' from an external library 23 | 24 | // type identifier := expression ; 25 | // 26 | // declares and defines the initial value of a variable. The 'expression' must yield a value 27 | // of the given 'type'. 28 | 29 | int()* fun := &printf; // declare pointer to function 'fun' and initialise with the address of 'printf' 30 | 31 | // fn-expression (arg-expression, ...) 32 | // 33 | // makes a function call to the value of 'fn-expression' with the given 'arg-expression's as 34 | // arguments. 'fn-expression' must yield a function or a pointer to a function. 35 | 36 | printf("hello, "); 37 | 38 | fun("world\n"); 39 | 40 | // type identifier(param-type, ...) statement ; 41 | // 42 | // declares a procedure or function called 'identifier' that returns 'type' and accepts 43 | // arguments of the given 'param-type's. When declaring a procedure 'type' will be "void". 44 | 45 | void doit() printf("hello again\n"); 46 | 47 | doit(); 48 | 49 | // When declaring a function, the 'statement' will be a 'return' statement whose value 50 | // corresponds to 'type'. 51 | 52 | int forty_two() return 42; 53 | 54 | printf("%i\n", forty_two()); 55 | 56 | // The usual arithmetic (~ + - * / % << >> & | ^), relational (< <= == != >= >) and logical 57 | // operators (! && ||) are provided. In the conditional expression 58 | // 59 | // condition-expression ? consequent-expression : alternative-expression 60 | // 61 | // the types of 'consequent-expression' and 'alternative-expression' must match and determine 62 | // the type of the overall expression. 63 | 64 | int nfibs1(int n) 65 | if n < 2 66 | then return 1; 67 | else return nfibs1(n - 1) + nfibs1(n - 2) + 1; 68 | 69 | printf("%i\n", nfibs1(5)); 70 | 71 | int nfibs2(int n) 72 | return 73 | n < 2 74 | ? 1 75 | : nfibs2(n - 1) + nfibs2(n - 2) + 1; 76 | 77 | printf("%i\n", nfibs2(5)); 78 | 79 | struct Point { int x, y; }; 80 | 81 | struct Point p := struct Point ( 1, 2 ); 82 | 83 | struct Point* pp := &p; 84 | 85 | printf("Point with x = %d and y = %d\n", &p.x, &p.y); 86 | 87 | void printPoint(struct Point* p) 88 | printf("Point with x = %d and y = %d\n", p.x, p.y); 89 | 90 | printPoint(&p); 91 | 92 | import char*(int) malloc; 93 | import void(char *) free; 94 | 95 | void sieve1(int n) { 96 | let char* flags := malloc(n + 1); 97 | let int i := 0; 98 | i := 2; while i <= n do { *(flags + i) := 1; i := i + 1; } 99 | i := 2; while i <= n do { 100 | if *(flags + i) then { 101 | printf("%4d", i); 102 | let int j := i; 103 | while j <= n do { 104 | *(flags + j) := 0; 105 | j := j + i; 106 | } 107 | } 108 | i := i + 1; 109 | } 110 | printf("\n"); 111 | free(flags); 112 | } 113 | 114 | sieve1(50); 115 | 116 | // the same again with some syntactic sugar 117 | 118 | void sieve2(int n) 119 | begin 120 | for i := 2 until n do flags[i] := true; 121 | for i := 2 until n do 122 | if flags[i] then begin 123 | printf("%4d", i); 124 | for j := i step i until n do flags[j] := false; 125 | end 126 | printf("\n"); 127 | free(flags); 128 | end 129 | where char* flags := malloc(n + 1); 130 | 131 | sieve2(100); 132 | -------------------------------------------------------------------------------- /maru-2.4/test-repl.l: -------------------------------------------------------------------------------- 1 | (define-selector twice) 2 | 3 | (define-method twice () (+ self self)) 4 | 5 | (println (twice 21)) 6 | 7 | { error = -> (error "parse error near: "(parser-stream-context self.source)) ; } 8 | 9 | { 10 | blank = [\t\n\r ] ; 11 | comment = "//"(![\n\r].)* ; 12 | _ = (blank | comment)* ; 13 | 14 | digit = [0123456789] ; 15 | 16 | number = digit+ $#:d _ -> d ; 17 | 18 | value = number ; 19 | 20 | factor = value:a ( "*" _ factor:b -> (* a b) 21 | | "/" _ factor:b -> (/ a b) 22 | | -> a 23 | ) 24 | ; 25 | term = factor:a ( "+" _ term:b _ -> (+ a b) 26 | | "-" _ term:b _ -> (- a b) 27 | | -> a 28 | ) 29 | ; 30 | } 31 | 32 | { _ (term:t -> (println t))* "." } 33 | 34 | 3 +4 35 | 3- 4 36 | 3*3 37 | 3* 3+4 *4 38 | . 39 | 40 | { 41 | letter = [ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz] ; 42 | 43 | name = ( letter (letter | digit)* ) @ $$ :id _ -> id ; 44 | 45 | value = number 46 | | name:n -> (eval n) 47 | ; 48 | 49 | vardefn = name:n "=" _ expression:e -> (eval `(define ,n ,e)) ; 50 | 51 | expression = vardefn | term ; 52 | 53 | statement = _ expression:e -> (println e) ; 54 | 55 | statement* "!" 56 | } 57 | 58 | foo = 21 59 | bar = 2 60 | foo * bar 61 | ! 62 | 63 | { 64 | arglist = "(" _ expression?:a ("," _ expression)*:b ")" _ -> `(,@a ,@b) ; 65 | 66 | funcall = name:f arglist:a -> `(,f ,@a) ; 67 | 68 | string = "\"" (!"\"" .)* @$:s "\"" _ -> s ; 69 | 70 | value = funcall | number | name | string ; 71 | 72 | factor = value:a ( "*" _ factor:b -> `(* ,a ,b) 73 | | "/" _ factor:b -> `(/ ,a ,b) 74 | | "%" _ factor:b -> `(% ,a ,b) 75 | | -> a 76 | ) 77 | ; 78 | term = factor:a ( "+" _ term:b _ -> `(+ ,a ,b) 79 | | "-" _ term:b _ -> `(- ,a ,b) 80 | | -> a 81 | ) 82 | ; 83 | 84 | imperative = expression:e -> `(println ,e) ; 85 | 86 | vardefn = name:n "=" _ expression:e -> `(define ,n ,e) ; 87 | 88 | paramlist = "(" _ name?:a ("," _ name)*:b ")" _ -> `(,@a ,@b) ; 89 | 90 | fundefn = name:f paramlist:a "=" _ expression:e -> (println "FUNCTION DEFINITION FROM "(cadr (-position self)) 91 | " TO " (car (-position self))) 92 | -> (let () 93 | (eval (list 'define f)) 94 | `(set ,f (lambda ,a ,e))) ; 95 | 96 | imperative = expression:e ( ";" _ -> e 97 | | -> `(println ,e) 98 | ) 99 | ; 100 | 101 | expression = _ ( fundefn | vardefn | term ) ; 102 | 103 | statement = _ expression:e (";" _)* -> e ; 104 | 105 | program = statement*:s -> (map eval s) ; 106 | 107 | program "." 108 | } 109 | 110 | println("here comes a program"); 111 | 112 | println("foo + bar = ", foo + bar); 113 | 114 | double(x) = 2 * x; 115 | 116 | double(21) 117 | 118 | . 119 | 120 | { 121 | relation = term:a ( "<" _ term:b -> `(< ,a ,b) 122 | | -> a 123 | ) 124 | ; 125 | compound = "{" _ statement*:s "}" _ -> `(let () ,@s) ; 126 | let = "let" _ name:n "=" _ expression:i "in" _ expression:e -> `(let ((,n ,i)) ,e) ; 127 | if = "if" _ expression:a "then" _ expression:b "else" _ expression:c -> `(if ,a ,b ,c) ; 128 | subexpr = "(" _ expression:e ")" _ -> e ; 129 | expression = _ ( compound | subexpr | let | if 130 | | fundefn | vardefn | relation 131 | ) 132 | ; 133 | program _ "." 134 | } 135 | 136 | let x = 10 in { 137 | println(x + 2); 138 | println(x * 2); 139 | } 140 | 141 | factorial(n) = { 142 | if n < 2 143 | then n 144 | else n * factorial(n - 1) 145 | } 146 | 147 | println(factorial(5)) 148 | 149 | . 150 | 151 | 152 | { 153 | for = "for" _ name:n "=" _ expression:a "to" _ expression:b "do" statement:c -> `(let ((,n ,a)) 154 | (while (<= ,n ,b) 155 | ,c 156 | (set ,n (+ ,n 1)))) ; 157 | expression = _ ( compound | subexpr | let | if | for 158 | | fundefn | vardefn | relation 159 | ) 160 | ; 161 | program 162 | } 163 | 164 | for i = 1 to 10 do { 165 | for j = 1 to 10 do 166 | print(i * j, " ") 167 | println() 168 | } 169 | 170 | nfibs(n) = 171 | if n < 2 172 | then 1 173 | else nfibs(n - 1) + nfibs(n - 2) + 1 174 | 175 | println("nfibs(15) is ", nfibs(15)) 176 | 177 | 178 | 179 | // Local Variables: 180 | // mode: outline-minor 181 | // outline-regexp: ";;;----------------------------------------------------------------" 182 | // End: 183 | -------------------------------------------------------------------------------- /maru-2.4/test-mach-o.l: -------------------------------------------------------------------------------- 1 | (require "buffer.k") 2 | 3 | (define code (buffer-new 4096)) ;; binary 4 | (define phased 1) ;; non-nil if something changed this pass 5 | (define $% 0) ;; file offset 6 | (define $$ 0) ;; last .org address 7 | (define $ 0) ;; current address 8 | 9 | (define-selector _B (gen value) (buffer-write code value) (incr $)) 10 | (define-selector _W (gen value) (_B gen (& 255 value)) (_B gen (& 255 (>> value 8)))) 11 | (define-selector _L (gen value) (_W gen (& 65535 value)) (_W gen (& 65535 (>> value 16)))) 12 | (define-selector _D1 (gen value) (_B gen value)) 13 | (define-selector _D4 (gen value) (_L gen value)) 14 | 15 | (require "asm-x86.k") 16 | 17 | (define-function define-label (name value) 18 | (or (= (eval name) value) 19 | (let () 20 | (eval (list 'set name value)) 21 | (set phased 1)))) 22 | 23 | (define-function .org (addr) (set $$ (set $ (eval addr)))) 24 | (define-form .equ (name expr) (define-label name (eval expr)) ()) 25 | (define-function .byte bytes (list-do byte bytes (_B () (eval byte)))) 26 | (define-function .long longs (list-do long longs (_L () (eval long)))) 27 | (define-function .ascii strings (list-do string strings (string-do char string (_B () char)))) 28 | 29 | (define-function movlIR (src dst) (MOVLir () src dst)) 30 | (define-function inclR (dst) (INCLr () dst)) 31 | (define-function pushlI (src) (PUSHLi () src)) 32 | (define-function addlIR (src dst) (ADDLir () src dst)) 33 | (define-function sublIR (src dst) (SUBLir () src dst)) 34 | (define-function intI (src) (_B () 0xCD) (_B () src)) 35 | 36 | (define-function assemble (program) 37 | ;; (let ((asm (assembler-new))) 38 | (list-do insn program 39 | (cond 40 | ((symbol? insn) (eval (list 'define insn 0))) 41 | ((= '.equ (car insn)) (eval (list 'define (cadr insn) 0))))) 42 | (set phased 1) 43 | (while phased 44 | (set phased ()) 45 | (buffer-reset code) 46 | (set $$ (set $ (buffer-address code))) 47 | (list-do insn program 48 | (cond 49 | ((symbol? insn) (define-label insn $)) 50 | ((pair? insn) (eval insn)) 51 | (else (error "huh? "insn))))) 52 | ;;(println "assembled "(buffer-size code)" bytes") 53 | ;; ) 54 | ) 55 | 56 | (assemble '( 57 | (.org 0x1000) 58 | (.long 0xFeedFace) ; magic 59 | (.long 7) ; CPU_TYPE_X86 60 | (.long 3) ; CPU_SUBTYPE_I386_ALL 61 | (.long 2) ; MH_EXECUTE 62 | (.long 2) ; ncmds 63 | (.long (- start cmd0)) ; cmdsize 64 | (.long 0) ; flags 65 | cmd0 (.long 1) ; LC_SEGMENT 66 | (.long (- cmd1 cmd0)) ; cmdsize 67 | (.ascii "__TEXT") ; segname 68 | (.byte 0 0 0 0 0 0 0 0 0 0) ; segname 69 | (.long 0x1000) ; vmaddr 70 | (.long 0x1000) ; vmsize 71 | (.long 0) ; fileoff 72 | (.long filesize) ; filesize 73 | (.long 7) ; maxprot 74 | (.long 5) ; initprot 75 | (.long 1) ; nsects 76 | (.long 0) ; flags 77 | (.ascii "__text") ; sectname 78 | (.byte 0 0 0 0 0 0 0 0 0 0) ; sectname 79 | (.ascii "__TEXT") ; segname 80 | (.byte 0 0 0 0 0 0 0 0 0 0) ; segname 81 | (.long start) ; addr 82 | (.long (- end start)) ; size 83 | (.long (- start 0x1000)) ; offset 84 | (.long 2) ; align 85 | (.long 0) ; reloff 86 | (.long 0) ; nreloc 87 | (.long 0) ; flags 88 | (.long 0) ; reserved1 89 | (.long 0) ; reserved2 90 | cmd1 (.long 5) ; LC_UNIXTHREAD 91 | (.long (- start cmd1)) ; cmdsize 92 | (.long 1) ; i386_THREAD_STATE 93 | (.long 16) ; i386_THREAD_STATE_COUNT 94 | (.long 0 0 0 0 0 0 0 0) ; state 95 | (.long 0 0 start 0 0 0 0 0) ; state 96 | start (pushlI msglen) ; strlen(buffer) 97 | (pushlI msg) ; buffer 98 | (pushlI 1) ; stdout 99 | (movlIR 4 _EAX) ; write 100 | (sublIR 4 _ESP) ; syscall 101 | (intI 0x80) 102 | (addlIR 16 _ESP) ; pop args 103 | (pushlI 0) ; status 104 | (movlIR 1 _EAX) ; exit 105 | (sublIR 4 _ESP) ; syscall 106 | (intI 0x80) 107 | msg (.ascii "Hello, world\n\0") 108 | (.equ msglen (- $ msg)) 109 | (.equ filesize (- $ $$)) 110 | end )) 111 | 112 | (buffer-save code "a.out") 113 | 114 | (assemble '( 115 | (pushlI msglen) ; strlen(buffer) 116 | (pushlI msg) ; buffer 117 | (pushlI 1) ; stdout 118 | (movlIR 4 _EAX) ; write 119 | (sublIR 4 _ESP) ; syscall 120 | (intI 0x80) 121 | (addlIR 16 _ESP) ; pop args 122 | (pushlI 0) ; status 123 | (movlIR 1 _EAX) ; exit 124 | (sublIR 4 _ESP) ; syscall 125 | (intI 0x80) 126 | msg (.ascii "Now run ./a.out for a friendly greeting\n\0") 127 | (.equ msglen (- $ msg)))) 128 | 129 | (buffer-call code 0) 130 | -------------------------------------------------------------------------------- /maru-2.4/model.l: -------------------------------------------------------------------------------- 1 | (define-generic foo) 2 | 3 | (let ((arg1 (array 32))) 4 | (set (array-at arg1 ) 5 | (let ((arg2 (array 32))) 6 | (set (array-at arg2 ) 7 | (lambda (self arg) (println "foo on long.long: "self arg))) 8 | arg2)) 9 | (set (-methods foo) arg1)) 10 | 11 | (foo 1 2) 12 | 13 | (define-multimethod foo ((self ) (arg )) (println "ANOTHER foo on long.long: " self " " arg)) 14 | (define-multimethod foo ((self ) (arg )) (println "ANOTHER foo on long.long: " self " " arg)) 15 | (define-multimethod foo ((self ) (arg )) (println "ANOTHER foo on string.long: " self " " arg)) 16 | (define-multimethod foo ((self ) (arg )) (println "ANOTHER foo on long.string: " self " " arg)) 17 | (define-multimethod foo ((self ) (arg )) (println "ANOTHER foo on string.string: " self " " arg)) 18 | (define-multimethod foo ((self )) (println "ANOTHER foo on symbol: " self)) 19 | 20 | (foo 3 4) 21 | (foo "five" 6) 22 | (foo 7 "eight") 23 | (foo "nine" "ten") 24 | (foo 'foo) 25 | 26 | (define-function fnfibs (n) 27 | (if (< n 2) 28 | 1 29 | (+ 1 (+ (fnfibs (- n 1)) (fnfibs (- n 2)))))) 30 | 31 | (define-generic nfibs) 32 | (define-generic add) 33 | (define-generic sub) 34 | (define-generic less) 35 | 36 | (define-multimethod add ((self ) (arg )) (+ self arg)) 37 | (define-multimethod sub ((self ) (arg )) (- self arg)) 38 | (define-multimethod less ((self ) (arg )) (< self arg)) 39 | 40 | (define-multimethod nfibs ((self )) 41 | (if (less self 2) 42 | 1 43 | (add 1 (add (nfibs (sub self 1)) (nfibs (sub self 2)))))) 44 | 45 | ;(println (fnfibs 28)) 46 | ;(println (nfibs 28)) 47 | 48 | (define-structure PTR (value)) 49 | 50 | (define-structure I32 (value)) 51 | 52 | (define-structure M32 (base index)) 53 | 54 | (define-generic plus) 55 | 56 | (define-multimethod plus ((base PTR) (index I32)) 57 | (new M32)) 58 | 59 | (println (new PTR)) 60 | (println (new I32)) 61 | (println (new M32)) 62 | 63 | (println (plus (new PTR) (new I32))) 64 | 65 | (exit 0) 66 | 67 | 68 | 69 | (define (%allocate-type ')) 70 | 71 | (set-array-at *applicators* 72 | (lambda (stage arg) 73 | (println "you just applied " stage" with "arg))) 74 | 75 | (set-array-at (-methods print) 76 | (lambda args 77 | (print ""))) 78 | 79 | (define s (allocate 0)) 80 | 81 | (println s) 82 | 83 | (s 42) 84 | 85 | (define (%allocate-type ')) 86 | (define foo (allocate 0)) 87 | (set-array-at (-methods print) (lambda args (error "trying to print a : " args))) 88 | 89 | (error foo) 90 | 91 | (exit 0) 92 | 93 | 94 | (define-function do-stage (stage expr env) 95 | (println "DO-STAGE "stage" "expr" "env) 96 | (let ((fn (array-at stage (type-of expr)))) 97 | (or fn (error "no stage rule to deal with "expr)) 98 | (fn stage expr env))) 99 | 100 | (define-function do-stage-list (stage expr env) 101 | (println "DO-STAGE-LIST "stage" "expr" "env) 102 | (and (pair? expr) 103 | (cons (do-stage stage (car expr) env) (do-stage-list stage (cdr expr) env)))) 104 | 105 | (define stage-encode (array 8)) 106 | 107 | (define-function exec-apply (args env) 108 | (apply (car args) (cdr args) env)) 109 | 110 | (define-function exec-lookup (arg env) 111 | (or (cdr (assq args env)) 112 | (error "undefined: "arg))) 113 | 114 | (set-array-at stage-encode 115 | (lambda (stage expr env) 116 | (println "STAGE-ENCODE:LONG "stage" "expr" "env) 117 | expr)) 118 | 119 | (set-array-at stage-encode 120 | (lambda (stage expr env) 121 | (println "STAGE-ENCODE:PAIR "stage" "expr" "env) 122 | (let ((arguments (do-stage-list stage expr env))) 123 | (cons exec-apply arguments)))) 124 | 125 | (set-array-at stage-encode 126 | (lambda (stage expr env) 127 | (println "STAGE-ENCODE:SYMBOL "stage" "expr" "env) 128 | (cons exec-lookup expr))) 129 | 130 | (println (do-stage stage-encode '+) ()) 131 | (println (do-stage stage-encode '3) ()) 132 | (println (do-stage stage-encode '4) ()) 133 | (println (do-stage stage-encode '(+ 3 4) ())) 134 | 135 | (exit 0) 136 | 137 | (define stage-exec (array 8)) 138 | 139 | (set-array-at stage-exec 140 | (lambda (stage expr env) 141 | (println "STAGE-EXEC:PAIR "expr) 142 | (let ((head (car expr)) 143 | (tail (do-stage-list stage (cdr expr) env))) 144 | (if (pair? head) 145 | (set head (do-stage stage expr head env))) 146 | (apply head tail env)))) 147 | 148 | ;; (do-stage stage-exec x ()) 149 | -------------------------------------------------------------------------------- /maru-2.4/gc.h: -------------------------------------------------------------------------------- 1 | #ifndef _GC_H_ 2 | #define _GC_H_ 3 | 4 | struct GC_StackRoot 5 | { 6 | void **root; 7 | struct GC_StackRoot *next; 8 | #if !defined(NDEBUG) 9 | int live; 10 | const char *name; 11 | const char *file; 12 | long line; 13 | #endif 14 | }; 15 | 16 | #if defined(NDEBUG) 17 | # define GC_PROTECT(V) struct GC_StackRoot _sr_##V; _sr_##V.root= (void *)&V; GC_push_root(&_sr_##V) 18 | # define GC_UNPROTECT(V) GC_pop_root(&_sr_##V) 19 | #else 20 | # define GC_PROTECT(V) struct GC_StackRoot _sr_##V; _sr_##V.root= (void *)&V; GC_push_root(&_sr_##V, #V, __FILE__, __LINE__) 21 | # define GC_UNPROTECT(V) GC_pop_root(&_sr_##V, #V, __FILE__, __LINE__) 22 | #endif 23 | 24 | 25 | #define GC_INIT() 26 | #define GC_init() 27 | 28 | #if !defined(GC_API) 29 | # define GC_API 30 | #endif 31 | 32 | GC_API void *GC_malloc(size_t nbytes); 33 | GC_API void *GC_malloc_atomic(size_t nbytes); 34 | GC_API void *GC_realloc(void *ptr, size_t lbs); 35 | GC_API void GC_free(void *ptr); 36 | GC_API size_t GC_size(void *ptr); 37 | GC_API void GC_add_root(void *root); 38 | GC_API void GC_delete_root(void *root); 39 | GC_API void GC_mark(void *ptr); 40 | GC_API void GC_mark_leaf(void *ptr); 41 | GC_API void GC_sweep(void); 42 | GC_API void GC_gcollect(void); 43 | GC_API size_t GC_count_objects(void); 44 | GC_API size_t GC_count_bytes(void); 45 | GC_API double GC_count_fragments(void); 46 | 47 | GC_API void *GC_first_object(void); 48 | GC_API void *GC_next_object(void *prev); 49 | 50 | GC_API int GC_atomic(void *ptr); 51 | 52 | #ifndef NDEBUG 53 | GC_API void *GC_check(void *ptr); 54 | GC_API void *GC_stamp(void *ptr, const char *file, long line, const char *func); 55 | GC_API const char *GC_file(void *ptr); 56 | GC_API long GC_line(void *ptr); 57 | GC_API const char *GC_function(void *ptr); 58 | #else 59 | # define GC_check(PTR) (PTR) 60 | # define GC_stamp(PTR, FILE, LINE, FUNC) (PTR) 61 | # define GC_file(PTR) "?" 62 | # define GC_line(PTR) 0 63 | # define GC_function(PTR) "?" 64 | #endif 65 | 66 | typedef void (*GC_finaliser_t)(void *ptr, void *data); 67 | 68 | GC_API void GC_register_finaliser(void *ptr, GC_finaliser_t finaliser, void *data); 69 | 70 | extern struct GC_StackRoot *GC_stack_roots; 71 | 72 | #if defined(NDEBUG) 73 | 74 | GC_API inline void GC_push_root(struct GC_StackRoot *sr) 75 | { 76 | sr->next= GC_stack_roots; 77 | GC_stack_roots= sr; 78 | } 79 | 80 | GC_API inline void GC_pop_root(struct GC_StackRoot *sr) 81 | { 82 | # if 0 83 | GC_stack_roots= sr->next; 84 | # else /* paranoid version for broken code warns of mismatched pops with a SEGV */ 85 | struct GC_StackRoot *nr= sr->next; 86 | while (nr != GC_stack_roots) GC_stack_roots= GC_stack_roots->next; 87 | # endif 88 | } 89 | 90 | #else 91 | 92 | GC_API inline void GC_push_root(struct GC_StackRoot *sr, const char *name, const char *file, int line) 93 | { 94 | sr->next= GC_stack_roots; 95 | sr->name= name; 96 | sr->file= file; 97 | sr->line= line; 98 | sr->live= 1; 99 | GC_stack_roots= sr; 100 | } 101 | 102 | static int GC_roots_include(struct GC_StackRoot *roots, struct GC_StackRoot *root) 103 | { 104 | while (roots) { 105 | if (roots == root) return 1; 106 | roots= roots->next; 107 | } 108 | return 0; 109 | } 110 | 111 | GC_API inline void GC_pop_root(struct GC_StackRoot *sr, const char *name, const char *file, int line) 112 | { 113 | struct GC_StackRoot *nr= sr->next; 114 | struct GC_StackRoot *gr= GC_stack_roots; 115 | if (!sr->live) { fprintf(stderr, "*** %s %d %s: STALE POP IN GC_pop_root\n", file, line, name); goto die; } 116 | sr->live= 0; 117 | if (GC_roots_include(nr, sr)) { fprintf(stderr, "*** %s %d %s: CYCLE IN GC_pop_root\n", file, line, name); goto die; } 118 | int n= 0; 119 | while (nr != gr) { 120 | if (n++ > 10) { fprintf(stderr, "*** %s %d %s: LOOP IN GC_pop_root\n", file, line, name); goto die; } 121 | gr= gr->next; 122 | } 123 | GC_stack_roots= gr; 124 | return; 125 | die: 126 | fprintf(stderr, "* gc stack roots = %p %s %ld %s\n", gr, gr->file, gr->line, gr->name); 127 | fprintf(stderr, "* popped root = %p %s %ld %s\n", sr, sr->file, sr->line, sr->name); 128 | while (nr) { 129 | fprintf(stderr, "* next root = %p %s %ld %s\n", nr, nr ? nr->file : 0, nr ? nr->line : 0, nr ? nr->name : 0); 130 | nr= nr->next; 131 | } 132 | abort(); 133 | } 134 | 135 | #endif 136 | 137 | typedef void (*GC_pre_mark_function_t)(void); 138 | extern GC_pre_mark_function_t GC_pre_mark_function; 139 | 140 | typedef void (*GC_mark_function_t)(void *ptr); 141 | extern GC_mark_function_t GC_mark_function; 142 | 143 | typedef void (*GC_free_function_t)(void *ptr); 144 | extern GC_free_function_t GC_free_function; 145 | 146 | #endif /* _GC_H_ */ 147 | -------------------------------------------------------------------------------- /maru-2.4/tpeg.g: -------------------------------------------------------------------------------- 1 | # -*- coke -*- 2 | 3 | : () 4 | 5 | equals = "=" space ; 6 | blank = [\t ] ; 7 | eol = ("\n" "\r"*) | ("\r" "\n"*) ; 8 | comment = "#" (!eol .)* ; 9 | space = (blank | eol | comment)* ; 10 | bar = "|" space ; 11 | pling = "!" space ; 12 | ampersand = "&" space ; 13 | colon = ":" space ; 14 | arrow = "->" space ; 15 | quotesgl = "\'" space ; 16 | backquote = "`" space ; 17 | commaat = ",@" space ; 18 | comma = "," space ; 19 | dollarhash = "$#" space ; 20 | dollardbl = "$$" space ; 21 | dollar = "$" space ; 22 | at = "@" space ; 23 | query = "?" space ; 24 | minus = "-" space ; 25 | plus = "+" space ; 26 | star = "*" space ; 27 | lparen = "(" space ; 28 | rparen = ")" space ; 29 | lbrace = "{" space ; 30 | rbrace = "}" space ; 31 | dot = "." space ; 32 | tilde = "~" space ; 33 | digit = [0-9] ; 34 | higit = [0-9A-Fa-f] ; 35 | number = ("-"? digit+) @$#:n space -> n ; 36 | letter = [A-Z_a-z] ; 37 | idpart = (letter (letter | digit)*) @$$ ; 38 | identifier = idpart:id space -> id ; 39 | 40 | char = "\\" ( "t" -> 9 41 | | "n" -> 10 42 | | "r" -> 13 43 | | "x" (higit higit) @$#16 44 | | "u" (higit higit higit higit) @$#16 45 | | . 46 | ) 47 | | . ; 48 | string = "\"" (!"\"" char)* $:s "\"" space -> s ; 49 | class = "[" (!"]" char)* $:s "]" space -> s ; 50 | 51 | grammar = symbol:name space plus 52 | definition*:rules space -> `(grammar-extend ,name ,@rules) 53 | | symbol:name space colon symbol:parent space 54 | (lparen identifier*:fields rparen)? 55 | definition*:rules space -> `(grammar-define ,name ,parent ,fields ,@rules) 56 | | definition*:d space expression?:e -> `(grammar-eval ,d ,(car e)) 57 | ; 58 | 59 | symfirst = [-!#$%&*+/:<=>@A-Z^_a-z|~] ; 60 | symrest = [-!#$%&*+./:0-9<=>?@A-Z^_a-z|~] ; 61 | symbol = (symfirst symrest*) @$$ ; 62 | sexpr = ("-"? digit+) @$# 63 | | symbol 64 | | "?". 65 | | "\"" (!"\"" char)* $:e "\"" -> e 66 | | "(" sexpression*:e (space dot sexpression:f)? sspace ")" -> (set-list-source `(,@e ,@f) e) 67 | | "[" sexpression*:e (space dot sexpression:f)? sspace "]" -> (set-list-source `(bracket ,@e ,@f) e) 68 | | "'" sexpression:e -> (list 'quote e) 69 | | "`" sexpression:e -> (list 'quasiquote e) 70 | | ",@" sexpression:e -> (list 'unquote-splicing e) 71 | | "," sexpression:e -> (list 'unquote e) 72 | | "{" space grammar:e ( "}" -> e 73 | | -> (error "error in grammar near: "(parser-context self)) 74 | ) 75 | | ";" (![\n\r] .)* 76 | ; 77 | scomment = ";" (!eol .)* ; 78 | sspace = (blank | eol | scomment)* ; 79 | sexpression = sspace sexpr ; 80 | 81 | llist = lparen expression:e rparen -> e ; 82 | atom = lparen expression:e rparen -> e 83 | | quotesgl sexpression:e space -> `(match-object ,e) 84 | | string:e -> `(match-string ,e) 85 | | class:e -> `(match-class ,e) 86 | | idpart:p "-" identifier:e -> `(match-rule-in ,p ,e) 87 | | identifier:e -> `(match-rule ,e) 88 | | lbrace sexpression*:e space rbrace -> `(match-rule ,@e) 89 | | dot -> `(match-any) 90 | | arrow sexpression:e space -> `(result-expr ,e) 91 | | backquote llist:e -> `(match-list ,e) 92 | ; 93 | repetition = atom :e ( query -> `(match-zero-one ,e) :e 94 | | star -> `(match-zero-more ,e) :e 95 | | plus -> `(match-one-more ,e) :e 96 | )? -> e ; 97 | conversion = repetition :e ( at -> `(make-span ,e) :e 98 | | dollarhash ( number:n -> `(make-number ,n ,e) :e 99 | | -> `(make-number 10 ,e) :e 100 | ) 101 | | dollardbl -> `(make-symbol ,e ) :e 102 | | dollar -> `(make-string ,e ) :e 103 | | colon identifier :i -> `(assign-result ,i ,e ) :e 104 | )* -> e ; 105 | predicate = pling conversion:e -> `(peek-not ,e) 106 | | ampersand ( arrow sexpression:e space -> `(peek-expr ,e) 107 | | conversion:e -> `(peek-for ,e) 108 | ) 109 | | conversion ; 110 | 111 | require = predicate:p ( tilde string:e -> `(match-require ,p ,e) 112 | | -> p 113 | ) ; 114 | 115 | sequence = require:p ( require+:q -> `(match-all ,p ,@q) 116 | | -> p 117 | ) ; 118 | 119 | expression = sequence:s ( (bar sequence)+:t -> `(match-first ,s ,@t) 120 | | -> s 121 | ) ; 122 | 123 | parameters = (colon identifier)* ; 124 | 125 | definition = space identifier:id parameters:p 126 | equals expression:e ";" -> `(,id ,e ,p) ; 127 | 128 | definitions = definition* ; 129 | 130 | varname = symbol:s space -> s ; 131 | 132 | parser_decl = space varname:name colon varname:parent lparen (varname*):vars rparen -> `(,name ,parent ,vars) ; 133 | 134 | parser_spec = parser_decl?:decl definition*:defns -> `(,decl ,@defns) ; 135 | -------------------------------------------------------------------------------- /maru-2.4/test-call.k: -------------------------------------------------------------------------------- 1 | (load "define-class.l") 2 | (load "port.l") 3 | (load "data-stream.k") 4 | (load "ansiterm.l") 5 | 6 | (define-function nth (n list) 7 | (while (and (pair? list) (>= (incr n -1) 0)) 8 | (set list (cdr list))) 9 | (car list)) 10 | 11 | (define-function %receive (vars) 12 | (and (pair? vars) 13 | (cons `(set ,(car vars) (car _)) 14 | (cons '(set _ (cdr _)) 15 | (%receive (cdr vars)))))) 16 | 17 | (define-form receive (expr . vars) 18 | `(let ((_ ,expr)) 19 | ,@(%receive vars))) 20 | 21 | (define values list) 22 | 23 | ;;; ---------------- 24 | 25 | (define-structure