From edb8fc7e412114455fadd43c638dc131c0a95538 Mon Sep 17 00:00:00 2001 From: Stefano Dissegna Date: Sat, 5 Jun 2010 14:07:25 +0200 Subject: [PATCH] various bug fixes --- arc.pir | 8 ++- arc/lib.arc | 12 +++++ arc/qq.arc | 4 +- arcall.pir | 1 + benchmarks/fib.arc | 4 +- build/src/ops/Makefile.in | 4 +- builtins.pir | 103 +++++++++++++++++++++++--------------- compiler/boot.arc | 2 +- compiler/comp.arc | 85 ++++++++++++++++++++++--------- read.pir | 2 +- src/ops/primitivearc.ops | 2 +- src/pmc/arcchar.pmc | 1 + src/pmc/arccons.pmc | 1 + src/pmc/arcfn.pmc | 1 + src/pmc/arcint.pmc | 1 + src/pmc/arcnum.pmc | 1 + src/pmc/arcstr.pmc | 1 + src/pmc/arcsym.pmc | 1 + t/00-types.t | 4 +- t/04-functions.t | 3 +- t/07-builtins.t | 2 +- types.pir | 42 +++++++++++++--- 22 files changed, 196 insertions(+), 89 deletions(-) create mode 100644 arc/lib.arc diff --git a/arc.pir b/arc.pir index 5fae17c..ae9f7a3 100644 --- a/arc.pir +++ b/arc.pir @@ -47,7 +47,8 @@ loop: unless iter goto end $S0 = shift iter if $S0 == '-e' goto eval_mode # enter evaluation mode - unless $S0 == '-pir' goto go_on + if $S0 == '-a' goto is_arc + unless $S0 == '-pir' goto go_on $S0 = shift iter is_pir = 1 go_on: @@ -57,6 +58,9 @@ go_on: $P0 = $P0($S0) $P0() goto loop +is_arc: + is_pir = 0 + goto loop compile_arc: $P0 = 'load'($S0)#_compile_and_eval($S0) goto loop @@ -88,7 +92,7 @@ error_loop: $P3 = shift $P2 $P3 = $P3['sub'] if_null $P3, error_loop - $S0 = $P3.'to_string'() + $S0 = $P3#.'to_string'() say $S0 goto error_loop the_end: diff --git a/arc/lib.arc b/arc/lib.arc new file mode 100644 index 0000000..1191612 --- /dev/null +++ b/arc/lib.arc @@ -0,0 +1,12 @@ +(def newstring (n (o c #\space)) + (tostring + (repeat n + (disp c)))) + +(def read ((o p (stdin)) (o eof nil)) + (let r (_read p) + (if (is r "#") + eof + r))) + +(= sread read) diff --git a/arc/qq.arc b/arc/qq.arc index 626d998..8050174 100644 --- a/arc/qq.arc +++ b/arc/qq.arc @@ -41,5 +41,5 @@ (qq-expand (cdr x)))) (list 'quote (list x))))) -;(assign quasiquote -; (annotate 'mac qq-expand)) +(assign quasiquote + (annotate 'mac qq-expand)) diff --git a/arcall.pir b/arcall.pir index 62a064d..cfa17ff 100644 --- a/arcall.pir +++ b/arcall.pir @@ -120,6 +120,7 @@ tostring: go: $P0 = table[$S0] if_null $P0, ret_nil # not found + $P0 = $P0[1] # 0 -> key, 1 -> val .return ($P0) ret_nil: $P0 = get_hll_global 'nil' diff --git a/benchmarks/fib.arc b/benchmarks/fib.arc index 729c6b8..363f6da 100644 --- a/benchmarks/fib.arc +++ b/benchmarks/fib.arc @@ -1,7 +1,7 @@ -(set fib +(assign fib (fn (n) (if (< n 2) 1 (+ (fib (- n 1)) (fib (- n 2)))))) -(fib 28) +(fib 32) diff --git a/build/src/ops/Makefile.in b/build/src/ops/Makefile.in index a1f8fc7..5c6bd47 100644 --- a/build/src/ops/Makefile.in +++ b/build/src/ops/Makefile.in @@ -53,13 +53,13 @@ generate: $(OPS_FILE) compile: generate $(CC) $(CC_OUT)primitivearc_ops$(O) $(INCLUDES) $(CFLAGS) primitivearc_ops.c - $(CC) $(CC_OUT)primitivearc_ops_switch$(O) $(INCLUDES) $(CFLAGS) primitivearc_ops_switch.c +# $(CC) $(CC_OUT)primitivearc_ops_switch$(O) $(INCLUDES) $(CFLAGS) primitivearc_ops_switch.c #IF(cg_flag): $(CC) $(CC_OUT)primitivearc_ops_cg$(O) $(INCLUDES) $(CFLAGS) primitivearc_ops_cg.c #IF(cg_flag): $(CC) $(CC_OUT)primitivearc_ops_cgp$(O) $(INCLUDES) $(CFLAGS) primitivearc_ops_cgp.c linklibs: compile $(LD) $(LD_OUT)primitivearc_ops$(LOAD_EXT) primitivearc_ops$(O) $(LINKARGS) - $(LD) $(LD_OUT)primitivearc_ops_switch$(LOAD_EXT) primitivearc_ops_switch$(O) $(LINKARGS) +# $(LD) $(LD_OUT)primitivearc_ops_switch$(LOAD_EXT) primitivearc_ops_switch$(O) $(LINKARGS) #IF(cg_flag): $(LD) $(LD_OUT)primitivearc_ops_cg$(LOAD_EXT) primitivearc_ops_cg$(O) $(LINKARGS) #IF(cg_flag): $(LD) $(LD_OUT)primitivearc_ops_cgp$(LOAD_EXT) primitivearc_ops_cgp$(O) $(LINKARGS) diff --git a/builtins.pir b/builtins.pir index 6534ed2..13c1811 100644 --- a/builtins.pir +++ b/builtins.pir @@ -39,9 +39,9 @@ loop: .param pmc after push_eh error - $P0 = 'arcall'(during) + 'arcall'(during) pop_eh - .return ($P0) + .tailcall 'arcall'(after) error: .local pmc ex .get_results(ex) @@ -94,7 +94,7 @@ end: ## arithmethic -.macro defmathop(name, op) +.macro defmathop(name, op, base_value) ## default sub called if the others fail to match .sub .name :multi() @@ -111,7 +111,7 @@ loop: end: .return ($P0) zero_args: - .return (0) + .return (.base_value) .end .sub .name :multi(ArcInt, ArcInt) @@ -156,10 +156,10 @@ zero_args: .endm -.defmathop('+', +) -.defmathop('-', -) -.defmathop('*', *) -.defmathop('/', /) +.defmathop('+', +, 0) +.defmathop('-', -, 0) +.defmathop('*', *, 1) +.defmathop('/', /, 1) .sub 'mod' .param int a @@ -313,6 +313,16 @@ no: .defcmp(.name, .op, ArcInt, ArcNum, num) .defcmp(.name, .op, ArcNum, ArcInt, num) .defcmp(.name, .op, ArcNum, ArcNum, num) + + .sub .name :multi(ArcSym, ArcSym) + .param pmc a1 + .param pmc a2 + + $P0 = 'string'(a1) + $P1 = 'string'(a2) + + .tailcall .name($P0, $P1) + .end .sub .name :multi(_, _) .param pmc a1 @@ -395,18 +405,26 @@ end: scdr($P1, $P2) .return ($P0) .end - -.sub '+' :multi(ArcStr, ArcStr) + +.sub '+' :multi(ArcStr, ArcNil) .param pmc s1 .param pmc s2 - $S0 = s1 - $S1 = s2 - $S0 .= $S1 + .return (s1) +.end - $P0 = new 'ArcStr' - $P0 = $S0 - .return ($P0) +.sub '+' :multi(ArcStr, _) + .param pmc s1 + .param pmc s2 + + .tailcall 'string'(s1, s2) +# $S0 = s1 + # $S1 = s2 + # $S0 .= $S1 + + #$P0 = new 'ArcStr' + #$P0 = $S0 + #.return ($P0) .end .sub 'rand' @@ -504,7 +522,7 @@ end: $P0(what) set_hll_global 'stdout*', $P1 $P1 = compreg 'PIR' - $P0 = 'inside'(out) + $P0 = 'inside'(out) if_null send_pir_to_stdout, execute 'prn'($P0) execute: @@ -689,6 +707,7 @@ do: $P0 = new 'ArcChar' $S0 = inport.'get1'() $P0 = $S0 + $P0 = 'char->int'($P0) .return ($P0) .end @@ -707,6 +726,7 @@ do: .sub 'read' .param pmc inport :optional .param int has_in :opt_flag + if has_in goto do inport = get_hll_global 'stdin*' do: @@ -734,7 +754,8 @@ do: if has_out goto do outport = get_hll_global 'stdout*' do: - .tailcall 'writec'(c, outport) + $P0 = 'int->char'(c) + .tailcall 'writec'($P0, outport) .end .sub 'write' @@ -877,12 +898,14 @@ false: .local pmc iter - iter = table + iter = new 'HashIterator', table loop: unless iter goto end $P0 = shift iter - $P1 = table[$P0] - arcall2(fn, $P0, $P1) + $P0 = table[$P0] + $P1 = $P0[1] + $P2 = $P0[0] + arcall2(fn, $P2, $P1) goto loop end: .return (table) @@ -940,26 +963,6 @@ false: .return ($P0) .end -.sub 'newstring' - .param int n - .param string c :optional - .param int has_c :opt_flag - - if has_c goto go_on - c = " " -go_on: - $S0 = "" -loop: - if n >= 0 goto end - $S0 .= c - n = n - 1 - goto loop -end: - $P0 = new 'ArcStr' - $P0 = $S0 - .return ($P0) -.end - .sub 'string' .param pmc args :slurpy @@ -996,6 +999,24 @@ handle_err: .return ($S0) .end +.sub 'timedate' + .param pmc secs + $I0 = secs + $P0 = decodetime $I0 + $I2 = $P0 # get length + $I2 = $I2 - 1 + $P1 = get_hll_global 'nil' +loop: + if $I2 == -1 goto end + $I3 = $P0[$I2] + $P2 = new 'ArcInt', $I3 + $P1 = 'cons'($P2, $P1) + $I2 = $I2 - 1 + goto loop +end: + .return ($P1) +.end + ## only stubs .sub 'msec' diff --git a/compiler/boot.arc b/compiler/boot.arc index b4e2ee5..eb4186c 100644 --- a/compiler/boot.arc +++ b/compiler/boot.arc @@ -73,7 +73,7 @@ (inside o)]) (dcoerce 'nil 'string (fn (it) "")) -(dcoerce 'symbol 'string string) +(dcoerce 'sym 'string string) (def str>lst (s pos) (if (< pos (len s)) diff --git a/compiler/comp.arc b/compiler/comp.arc index da7b9b3..73bd894 100644 --- a/compiler/comp.arc +++ b/compiler/comp.arc @@ -40,14 +40,17 @@ (def top (cs) cs!reg) -(def find-loc-aux (s args) +(def find-loc-aux (s args depth) (if args (if (is (arg-name (car args)) s) (car args) - (find-loc-aux s (cdr args))))) + (if (and (is depth 0) (is (arg-type (car args)) 'dest)) + (or (find-loc-aux s (arg-expr (car args)) 1) + (find-loc-aux s (cdr args) 0)) + (find-loc-aux s (cdr args) depth))))) (def find-loc (cs s) - (find-loc-aux s cs!loc)) + (find-loc-aux s cs!loc 0)) (def alex (cs s) (mem s cs!lex)) @@ -147,16 +150,18 @@ vals (cdr e)) ((afn (args vals) (if args - (if (is (arg-type (car args)) 'rest) - (emit-local-init cs (car args) vals vals) - (do - (emit-local-init cs (car args) (car vals) vals) - (self (cdr args) (cdr vals)))))) + (do + (= cs!loc (cons (car args) cs!loc)) + (if (is (arg-type (car args)) 'rest) + (emit-local-init cs (car args) vals vals) + (do + (emit-local-init cs (car args) (car vals) vals) + (self (cdr args) (cdr vals))))))) args vals) (with (old-lex cs!lex old-loc cs!loc) - (= cs!lex (join (arg-names ((car e) 1)) cs!lex)) - (= cs!loc (join args cs!loc)) + ;(= cs!lex (join (arg-names ((car e) 1)) cs!lex)) + ;(= cs!loc (join args cs!loc)) (compile-seq cs body is-tail) (= cs!loc old-loc) (= cs!lex old-lex)) @@ -245,13 +250,14 @@ (unless (isa name 'sym) (err:string "not a symbol: " name)) (emit-fn-head cs name f!dbg-name f!outer) - (emit-args args) - ; emit the body - (reset-reg cs) (with (old-lex cs!lex old-loc cs!loc) (= cs!lex f!lex) (= cs!loc args) + ; emit args declaration & initialization + (emit-args cs args) + ; emit the body + (reset-reg cs) (compile-seq cs body t) (= cs!loc old-loc) (= cs!lex old-lex)) @@ -355,12 +361,38 @@ (aquote e) e (a-fn e) (withs (args (arg-names (cadr e)) - new-args (map [uniq] args) - transf (join (map cons args new-args) transf)) - (map [a-conv _ transf] e)) + ;new-args (map [uniq] args) + ;new-transf (join (map cons args new-args) transf) + (a-converted-args new-transf) (a-conv-args (cadr e) nil transf));args new-args transf)) + (cons 'fn (cons a-converted-args (map [a-conv _ new-transf] (cddr e))))) ; else (map1-imp [a-conv _ transf] e))) +(def a-conv-args (args new-args transf) + (if (no args) (list (rev new-args) transf) + (acons args) (withs (names (arg-names (list (car args))) + new-transf (join (map [cons _ (uniq)] names) transf) + converted-arg (if (is-opt (car args)) ; don't convert first o in case (o o ...) + (cons 'o (a-conv (cdr (car args)) new-transf)) + (a-conv (car args) new-transf))) + (a-conv-args (cdr args) (cons converted-arg new-args) new-transf)) + ; rest arg + (let new-transf (cons (cons args (uniq)) transf) + (list (join (rev new-args) (a-conv args new-transf)) new-transf)))) + +; TODO: doesn't work with destructoring: args may have less elements than +; arg-names, e.g.: ((x y)) vs. (x y) +; treat optional arg (o ...) to avoid converting all o in (o o ...) +; add a new conversion to transf incrementally for each arg +(def a-conv-args-2 (args arg-names new-args transf) + (let new-transf (cons (cons (car arg-names) (car new-args)) transf) + (if (acons args) + (cons (if (is-opt (car args)) + (cons 'o (a-conv (cdr (car args)) new-transf)) + (a-conv (car args) new-transf)) + (a-conv-args (cdr args) (cdr arg-names) (cdr new-args) new-transf)) + (a-conv args new-transf)))) + (def collect-fns-and-consts (expr lex outer is-main is-seq consts (o have-name nil)) ; (ero (string "collect: " expr)) (if @@ -387,7 +419,7 @@ (let (fns consts expr) (collect-fns-and-consts body new-lex name nil t consts) (list (cons (mk-fn (cons '$fn (cons name (cons args expr))) - outer new-lex have-name) + outer lex have-name) ; pass old-lex, args taken from cs!loc fns) consts (list (if is-main '$function '$closure) name)))) (and (no is-seq) (a-let expr)) @@ -416,8 +448,8 @@ (cons 'fn (cons (cadr e) (map mac-ex (cddr e)))) (is op 'quote) e - (is op 'quasiquote) - (qq-expand (cadr e)) + ;(is op 'quasiquote) + ; (qq-expand (cadr e)) (and (isa op 'sym) (bound op) (isa (eval op) 'mac)) @@ -486,11 +518,10 @@ (prn (arg-p-name loc) " = " (arg-expr loc)))) ; emit initialization code for arg -(def emit-arg-init (a) +(def emit-arg-init (cs a) (case (arg-type a) simple (pr-lex (arg-name a) (arg-p-name a)) - opt (with (next (label) - cs (empty-state)) + opt (let next (label) (pr-lex (arg-name a) (arg-p-name a)) (prn "if has_" (arg-p-name a) " goto " next) (compile-expr cs (arg-expr a) nil) @@ -551,8 +582,12 @@ (collect-args (cdr args)))) (err:string "Unknow arg type:" args))) -(def emit-args (args) +(def emit-args (cs args) (each arg args (emit-arg-dec arg)) - (each arg args - (emit-arg-init arg))) + (let old-loc cs!loc + (= cs!loc nil) + (each arg args + (= cs!loc (cons arg cs!loc)) + (emit-arg-init cs arg)) + (= cs!loc old-loc))) diff --git a/read.pir b/read.pir index e886bed..1a558c9 100644 --- a/read.pir +++ b/read.pir @@ -202,7 +202,7 @@ end: .sub '_skip_separators' .param pmc rs -loop: +loop: $S0 = rs.'peek1'() $I0 = index separators, $S0 if $I0 == -1 goto end diff --git a/src/ops/primitivearc.ops b/src/ops/primitivearc.ops index 9210ff7..73d1abe 100644 --- a/src/ops/primitivearc.ops +++ b/src/ops/primitivearc.ops @@ -4,7 +4,7 @@ */ #include "parrot/dynext.h" -VERSION = PARROT_VERSION; +/*VERSION = PARROT_VERSION;*/ /* Op to get the address of a PMC. */ inline op primitivearc_pmc_addr(out INT, invar PMC) :base_core { diff --git a/src/pmc/arcchar.pmc b/src/pmc/arcchar.pmc index 9f1bb40..c74d997 100644 --- a/src/pmc/arcchar.pmc +++ b/src/pmc/arcchar.pmc @@ -1,6 +1,7 @@ pmclass ArcChar extends ArcT extends String + auto_attrs dynpmc group primitivearc_group hll Arc { diff --git a/src/pmc/arccons.pmc b/src/pmc/arccons.pmc index 1b1fa92..1a93cac 100644 --- a/src/pmc/arccons.pmc +++ b/src/pmc/arccons.pmc @@ -13,6 +13,7 @@ static STRING* as_string(PARROT_INTERP, PMC *pmc) { */ pmclass ArcCons extends ArcT + auto_attrs dynpmc group primitivearc_group hll Arc { diff --git a/src/pmc/arcfn.pmc b/src/pmc/arcfn.pmc index c0df943..977a483 100644 --- a/src/pmc/arcfn.pmc +++ b/src/pmc/arcfn.pmc @@ -1,6 +1,7 @@ pmclass ArcFn extends ArcT extends Sub + auto_attrs dynpmc group primitivearc_group hll Arc diff --git a/src/pmc/arcint.pmc b/src/pmc/arcint.pmc index 0e90140..d60fbe8 100644 --- a/src/pmc/arcint.pmc +++ b/src/pmc/arcint.pmc @@ -2,6 +2,7 @@ pmclass ArcInt extends ArcT extends Integer dynpmc + auto_attrs group primitivearc_group hll Arc maps Integer { diff --git a/src/pmc/arcnum.pmc b/src/pmc/arcnum.pmc index 1a2cc96..38d53d1 100644 --- a/src/pmc/arcnum.pmc +++ b/src/pmc/arcnum.pmc @@ -1,6 +1,7 @@ pmclass ArcNum extends ArcT extends Float + auto_attrs dynpmc group primitivearc_group hll Arc diff --git a/src/pmc/arcstr.pmc b/src/pmc/arcstr.pmc index 682c119..50eacb1 100644 --- a/src/pmc/arcstr.pmc +++ b/src/pmc/arcstr.pmc @@ -1,6 +1,7 @@ pmclass ArcStr extends ArcT extends String + auto_attrs dynpmc group primitivearc_group hll Arc diff --git a/src/pmc/arcsym.pmc b/src/pmc/arcsym.pmc index 16bc45a..53a6edd 100644 --- a/src/pmc/arcsym.pmc +++ b/src/pmc/arcsym.pmc @@ -1,5 +1,6 @@ pmclass ArcSym extends ArcT + auto_attrs need_ext dynpmc group primitivearc_group diff --git a/t/00-types.t b/t/00-types.t index c899226..20c2b75 100644 --- a/t/00-types.t +++ b/t/00-types.t @@ -58,8 +58,8 @@ language_output_is('Arc', '(assign h (table)) (sref h 1 1) (sref h 2 1) (sref h ## type -language_output_is('Arc', "(type nil)", "nil\n", 'type nil'); -language_output_is('Arc', "(type t)", "t\n", 'type t'); +language_output_is('Arc', "(type nil)", "sym\n", 'type nil'); +language_output_is('Arc', "(type t)", "sym\n", 'type t'); language_output_is('Arc', "(type (cons 1 2))", "cons\n", 'type cons'); language_output_is('Arc', "(type 'k)", "sym\n", 'type sym'); language_output_is('Arc', '(type "12")', "string\n", 'type string'); diff --git a/t/04-functions.t b/t/04-functions.t index 6b5e6e9..cc16a1f 100644 --- a/t/04-functions.t +++ b/t/04-functions.t @@ -6,7 +6,7 @@ use utf8; use lib qw( . lib ../lib ../../lib ); -use Test::More tests => 25; +use Test::More tests => 26; use Parrot::Test; language_output_is('Arc', '(fn ())', "#\n", "simple fn"); @@ -74,6 +74,7 @@ language_output_is('Arc', '((fn (x (o y)) (cons x y)) 4)', "(4)\n", "opt arg"); language_output_is('Arc', '((fn (x (o y)) (cons x y)) 4 5)', "(4 . 5)\n", "opt arg"); language_output_is('Arc', '((fn ((o x 1) (o y 2)) (+ x y)))', "3\n", "opt arg"); language_output_is('Arc', '(assign o 9) ((fn ((y . u) (o x 1)) (cons y o)) \'(1 . 2))', "(1 . 9)\n", "'o isn't an arg list name"); +language_output_is('Arc', '((fn ((o o 1)) o))', "1\n", "opt arg named o"); ## destructuring language_output_is('Arc', "((fn ((x y) z) (list x y z)) '(1 2) 4)", "(1 2 4)\n", "destructuring"); diff --git a/t/07-builtins.t b/t/07-builtins.t index 5cec9eb..d4fbafc 100644 --- a/t/07-builtins.t +++ b/t/07-builtins.t @@ -35,7 +35,7 @@ language_output_is('Arc', << 'CODE', << 'RES', 'infile & readb'); (write c1) c2 CODE -#\O#\K +7975 RES language_output_is('Arc', << 'CODE', << 'RES', 'infile & peekc'); diff --git a/types.pir b/types.pir index d4e4e03..5c1abb6 100644 --- a/types.pir +++ b/types.pir @@ -64,7 +64,7 @@ .namespace ['ArcHash'] .sub 'name' :vtable - .return ("hash") + .return ("table") .end .sub 'get_bool' :vtable :method @@ -264,8 +264,13 @@ end: .sub 'scar' .param pmc cell .param pmc val - cell.'scar'(val) + + $S0 = typeof cell + if $S0 == 'string' goto is_string + cell.'scar'(val) .return (val) +is_string: + .tailcall 'sref'(cell, val, 0) .end .sub 'cdr' @@ -354,7 +359,13 @@ end: .end .sub 'table' - $P0 = new 'ArcHash' + .param pmc fn :optional + .param int has_fn :opt_flag + + $P0 = new 'ArcHash' + unless has_fn goto end + 'arcall1'(fn, $P0) +end: .return ($P0) .end @@ -372,9 +383,20 @@ end: goto go tostring: $S0 = key.'to_string'() -go: - h[$S0] = val - +go: + .local pmc nil + nil = get_hll_global 'nil' + $I0 = issame nil, val + if $I0 goto delete_key + $P0 = new 'FixedPMCArray' + $P0 = 2 + $P0[0] = key + $P0[1] = val + h[$S0] = $P0 + goto end +delete_key: + delete h[$S0] +end: .return (val) .end @@ -440,14 +462,18 @@ type_err: .param pmc what $S0 = typeof what if $S0 == 'Tagged' goto tagged - if $S0 == 'Sub' goto fn - if $S0 == 'MultiSub' goto fn + if $S0 == 'Sub' goto fn + if $S0 == 'MultiSub' goto fn + if $S0 == 't' goto nil_t + if $S0 == 'nil' goto nil_t .tailcall 'intern'($S0) tagged: $P0 = what[0] .return ($P0) fn: .tailcall 'intern'("fn") +nil_t: + .tailcall 'intern'("sym") .end ## coercion