[pure-lang-svn] SF.net SVN: pure-lang: [311] pure/trunk
Status: Beta
Brought to you by:
agraef
From: <ag...@us...> - 2008-06-25 23:00:44
|
Revision: 311 http://pure-lang.svn.sourceforge.net/pure-lang/?rev=311&view=rev Author: agraef Date: 2008-06-25 16:00:24 -0700 (Wed, 25 Jun 2008) Log Message: ----------- Implement constant definitions. Modified Paths: -------------- pure/trunk/ChangeLog pure/trunk/etc/pure-mode.el.in pure/trunk/etc/pure.lang pure/trunk/etc/pure.vim pure/trunk/etc/pure.xml pure/trunk/expr.cc pure/trunk/expr.hh pure/trunk/interpreter.cc pure/trunk/interpreter.hh pure/trunk/lexer.ll pure/trunk/parser.yy pure/trunk/printer.cc pure/trunk/pure.cc pure/trunk/test/test004.log Modified: pure/trunk/ChangeLog =================================================================== --- pure/trunk/ChangeLog 2008-06-25 07:39:52 UTC (rev 310) +++ pure/trunk/ChangeLog 2008-06-25 23:00:24 UTC (rev 311) @@ -1,3 +1,13 @@ +2008-06-26 Albert Graef <Dr....@t-...> + + * interpreter.cc et al: Implement constant definitions, as + discussed on the mailing list. These work like variable + definitions (using the new 'def' keyword in lieu of 'let'), but + constants cannot be redefined (unless you first clear an existing + definition), and constant values are directly substituted into the + right-hand sides of equations rather than being evaluated at + runtime. + 2008-06-25 Albert Graef <Dr....@t-...> * examples/sort.c: Add another example for the runtime API. Modified: pure/trunk/etc/pure-mode.el.in =================================================================== --- pure/trunk/etc/pure-mode.el.in 2008-06-25 07:39:52 UTC (rev 310) +++ pure/trunk/etc/pure-mode.el.in 2008-06-25 23:00:24 UTC (rev 311) @@ -164,8 +164,8 @@ (list "\\<\\(catch\\|throw\\)\\>" 0 'font-lock-builtin-face) (list (concat "\\<\\(" - "case\\|e\\(lse\\|nd\\|xtern\\)\\|i\\(f\\|nfix[lr]?\\)\\|let\\|" - "nullary\\|o\\(f\\|therwise\\)\\|p\\(refix\\|ostfix\\)\\|" + "case\\|def\\|e\\(lse\\|nd\\|xtern\\)\\|i\\(f\\|nfix[lr]?\\)\\|" + "let\\|nullary\\|o\\(f\\|therwise\\)\\|p\\(refix\\|ostfix\\)\\|" "then\\|using\\|w\\(hen\\|ith\\)" "\\)\\>") 0 'font-lock-keyword-face)) @@ -178,8 +178,8 @@ (list "\\<\\(catch\\|throw\\)\\>" 0 'font-lock-builtin-face) (list (concat "\\<\\(" - "case\\|e\\(lse\\|nd\\|xtern\\)\\|i\\(f\\|nfix[lr]?\\)\\|let\\|" - "nullary\\|o\\(f\\|therwise\\)\\|p\\(refix\\|ostfix\\)\\|" + "case\\|def\\|e\\(lse\\|nd\\|xtern\\)\\|i\\(f\\|nfix[lr]?\\)\\|" + "let\\|nullary\\|o\\(f\\|therwise\\)\\|p\\(refix\\|ostfix\\)\\|" "then\\|using\\|w\\(hen\\|ith\\)" "\\)\\>") 0 'font-lock-keyword-face)) Modified: pure/trunk/etc/pure.lang =================================================================== --- pure/trunk/etc/pure.lang 2008-06-25 07:39:52 UTC (rev 310) +++ pure/trunk/etc/pure.lang 2008-06-25 23:00:24 UTC (rev 311) @@ -4,8 +4,8 @@ $DESCRIPTION=Pure # Pure keywords. -$KW_LIST(kwa)=infix infixl infixr prefix postfix nullary case else end extern -if let of otherwise then using when with +$KW_LIST(kwa)=infix infixl infixr prefix postfix nullary case def else end +extern if let of otherwise then using when with # These aren't really keywords but we want them to stick out anyway. $KW_LIST(kwb)=catch throw Modified: pure/trunk/etc/pure.vim =================================================================== --- pure/trunk/etc/pure.vim 2008-06-25 07:39:52 UTC (rev 310) +++ pure/trunk/etc/pure.vim 2008-06-25 23:00:24 UTC (rev 311) @@ -33,7 +33,7 @@ " keywords syn keyword pureKeyword infix infixl infixr prefix postfix nullary -syn keyword pureKeyword case else end extern if let of otherwise then +syn keyword pureKeyword case def else end extern if let of otherwise then syn keyword pureKeyword using when with syn keyword pureSpecial catch throw syn keyword pureType bigint bool char short int long double Modified: pure/trunk/etc/pure.xml =================================================================== --- pure/trunk/etc/pure.xml 2008-06-25 07:39:52 UTC (rev 310) +++ pure/trunk/etc/pure.xml 2008-06-25 23:00:24 UTC (rev 311) @@ -4,6 +4,7 @@ <highlighting> <list name="keywords"> <item> case </item> + <item> def </item> <item> else </item> <item> end </item> <item> extern </item> Modified: pure/trunk/expr.cc =================================================================== --- pure/trunk/expr.cc 2008-06-25 07:39:52 UTC (rev 310) +++ pure/trunk/expr.cc 2008-06-25 23:00:24 UTC (rev 311) @@ -234,6 +234,10 @@ ttag = e.ttag; p = new path(*e.p); break; + case cvar: + cval = new expr; + *cval = *e.cval; + break; case fvar: val = e.val; break; @@ -256,6 +260,9 @@ case lvar: delete p; break; + case cvar: + delete cval; + break; case fvar: break; case fun: @@ -272,6 +279,10 @@ ttag = e.ttag; p = new path(*e.p); break; + case cvar: + cval = new expr; + *cval = *e.cval; + break; case fvar: val = e.val; break; @@ -294,6 +305,9 @@ case lvar: delete p; break; + case cvar: + delete cval; + break; case fvar: break; case fun: Modified: pure/trunk/expr.hh =================================================================== --- pure/trunk/expr.hh 2008-06-25 07:39:52 UTC (rev 310) +++ pure/trunk/expr.hh 2008-06-25 23:00:24 UTC (rev 311) @@ -485,7 +485,7 @@ /* Environment entries. */ struct env_info { - enum { none, lvar, fvar, fun } t; + enum { none, lvar, cvar, fvar, fun } t; uint8_t temp; union { // local variable binding (lvar): @@ -493,6 +493,8 @@ int8_t ttag; path *p; }; + // constant definition (cvar): + expr *cval; // free variable definition (fvar): void *val; // pointer to memory location holding a runtime expression // function definition (fun): @@ -505,6 +507,8 @@ env_info() : t(none) { } env_info(int8_t _ttag, path _p, uint8_t _temp = 0) : t(lvar), temp(_temp), ttag(_ttag), p(new path(_p)) { } + env_info(expr x, uint8_t _temp = 0) + : t(cvar), temp(_temp), cval(new expr) { *cval = x; } env_info(void *v, uint8_t _temp = 0) : t(fvar), temp(_temp), val(v) { } env_info(uint32_t c, rulel r, uint8_t _temp = 0) Modified: pure/trunk/interpreter.cc =================================================================== --- pure/trunk/interpreter.cc 2008-06-25 07:39:52 UTC (rev 310) +++ pure/trunk/interpreter.cc 2008-06-25 23:00:24 UTC (rev 311) @@ -537,8 +537,11 @@ int32_t f = it->first; const symbol& sym = symtab.sym(f); env::const_iterator jt = globenv.find(f); - if (jt != globenv.end() && jt->second.t == env_info::fun) { + if (jt != globenv.end() && jt->second.t == env_info::cvar) { restore_globals(g); + throw err("symbol '"+sym.s+"' is already defined as a constant"); + } else if (jt != globenv.end() && jt->second.t == env_info::fun) { + restore_globals(g); throw err("symbol '"+sym.s+"' is already defined as a function"); } else if (externals.find(f) != externals.end()) { restore_globals(g); @@ -559,6 +562,139 @@ return res; } +// Define global constants (macro definitions). + +pure_expr *interpreter::const_defn(expr pat, expr x) +{ + globals g; + save_globals(g); + pure_expr *e, *res = const_defn(pat, x, e); + if (!res && e) pure_free(e); + restore_globals(g); + return res; +} + +static expr pure_expr_to_expr(pure_expr *x) +{ + // FIXME: We might want to do stack checks here. + switch (x->tag) { + case EXPR::APP: + return expr(pure_expr_to_expr(x->data.x[0]), + pure_expr_to_expr(x->data.x[1])); + case EXPR::INT: + return expr(EXPR::INT, x->data.i); + case EXPR::BIGINT: { + // The expr constructor globbers its mpz_t argument, so take a copy. + mpz_t z; + mpz_init_set(z, x->data.z); + return expr(EXPR::BIGINT, z); + } + case EXPR::DBL: + return expr(EXPR::DBL, x->data.d); + case EXPR::STR: + return expr(EXPR::STR, x->data.s); + case EXPR::PTR: + if (x->data.p != 0) + // Only null pointer constants permitted right now. + throw err("pointer must be null in constant definition"); + return expr(EXPR::PTR, x->data.p); + default: + assert(x->tag > 0); + if (x->data.clos && x->data.clos->local) + // There's no way we can capture a local function in a compile time + // expression right now, so we have to forbid this, too. + throw err("anonymous closure not permitted in constant definition"); + return expr(x->tag); + } +} + +static expr subterm(expr x, const path& p) +{ + for (size_t i = 0, n = p.len(); i < n; i++) { + assert(x.tag() == EXPR::APP); + x = p[i]?x.xval2():x.xval1(); + } + return x; +} + +pure_expr *interpreter::const_defn(expr pat, expr x, pure_expr*& e) +{ + globals g; + save_globals(g); + compile(); + env vars; + expr lhs = bind(vars, pat), rhs = x; + build_env(vars, lhs); + for (env::const_iterator it = vars.begin(); it != vars.end(); ++it) { + int32_t f = it->first; + const symbol& sym = symtab.sym(f); + env::const_iterator jt = globenv.find(f); + if (jt != globenv.end() && jt->second.t == env_info::cvar) { + restore_globals(g); + throw err("symbol '"+sym.s+"' is already defined as a constant"); + } else if (jt != globenv.end() && jt->second.t == env_info::fvar) { + restore_globals(g); + throw err("symbol '"+sym.s+"' is already defined as a variable"); + } else if (jt != globenv.end() && jt->second.t == env_info::fun) { + restore_globals(g); + throw err("symbol '"+sym.s+"' is already defined as a function"); + } else if (externals.find(f) != externals.end()) { + restore_globals(g); + throw err("symbol '"+sym.s+ + "' is already declared as an extern function"); + } + } + compile(rhs); + pure_expr *res = doeval(rhs, e); + if (!res) return 0; + // convert the result back to a compile time expression + expr u = pure_expr_to_expr(res); + // match against the left-hand side + matcher m(rule(lhs, rhs)); + if (m.match(u)) { + // bind variables accordingly + for (env::const_iterator it = vars.begin(); it != vars.end(); ++it) { + assert(it->second.t == env_info::lvar && it->second.p); + int32_t f = it->first; + expr v = subterm(u, *it->second.p); + globenv[f] = env_info(v, temp); + } + } else { + pure_freenew(res); + res = 0; + } + restore_globals(g); + return res; +} + +void interpreter::const_defn(int32_t tag, pure_expr *x) +{ + assert(tag > 0 && x); + globals g; + save_globals(g); + symbol& sym = symtab.sym(tag); + env::const_iterator jt = globenv.find(tag); + if (jt != globenv.end() && jt->second.t == env_info::cvar) { + restore_globals(g); + throw err("symbol '"+sym.s+"' is already defined as a constant"); + } else if (jt != globenv.end() && jt->second.t == env_info::fvar) { + restore_globals(g); + throw err("symbol '"+sym.s+"' is already defined as a variable"); + } else if (jt != globenv.end() && jt->second.t == env_info::fun) { + restore_globals(g); + throw err("symbol '"+sym.s+"' is already defined as a function"); + } else if (externals.find(tag) != externals.end()) { + restore_globals(g); + throw err("symbol '"+sym.s+ + "' is already declared as an extern function"); + } + // convert the value to a compile time expression + expr u = pure_expr_to_expr(x); + // bind the variable + globenv[tag] = env_info(u, temp); + restore_globals(g); +} + // Process pending fundefs. void interpreter::mark_dirty(int32_t f) @@ -844,6 +980,29 @@ cout << ((double)clocks)/(double)CLOCKS_PER_SEC << "s\n"; } +void interpreter::define_const(rule *r) +{ + last.clear(); + pure_expr *e, *res = const_defn(r->lhs, r->rhs, e); + if ((verbose&verbosity::defs) != 0) + cout << "def " << r->lhs << " = " << r->rhs << ";\n"; + if (!res) { + ostringstream msg; + if (e) { + msg << "unhandled exception '" << e << "' while evaluating '" + << "def " << r->lhs << " = " << r->rhs << "'"; + pure_free(e); + } else + msg << "failed match while evaluating '" + << "def " << r->lhs << " = " << r->rhs << "'"; + throw err(msg.str()); + } + delete r; + pure_freenew(res); + if (interactive && stats) + cout << ((double)clocks)/(double)CLOCKS_PER_SEC << "s\n"; +} + void interpreter::clearsym(int32_t f) { // Check whether this symbol was already compiled; in that case @@ -962,7 +1121,9 @@ env::iterator it = e.find(f); const symbol& sym = symtab.sym(f); if (it != e.end()) { - if (it->second.t == env_info::fvar) + if (it->second.t == env_info::cvar) + throw err("symbol '"+sym.s+"' is already defined as a constant"); + else if (it->second.t == env_info::fvar) throw err("symbol '"+sym.s+"' is already defined as a variable"); else if (it->second.argc != argc) { ostringstream msg; @@ -1288,7 +1449,12 @@ // not a bound variable if (x.ttag() != 0) throw err("error in expression (misplaced type tag)"); - return x; + it = globenv.find(sym.f); + if (it != globenv.end() && it->second.t == env_info::cvar) + // substitute constant value + return *it->second.cval; + else + return x; } const env_info& info = it->second; return expr(EXPR::VAR, sym.f, idx, info.ttag, *info.p); @@ -1677,8 +1843,11 @@ save_globals(g); symbol& sym = symtab.sym(tag); env::const_iterator jt = globenv.find(tag); - if (jt != globenv.end() && jt->second.t == env_info::fun) { + if (jt != globenv.end() && jt->second.t == env_info::cvar) { restore_globals(g); + throw err("symbol '"+sym.s+"' is already defined as a constant"); + } else if (jt != globenv.end() && jt->second.t == env_info::fun) { + restore_globals(g); throw err("symbol '"+sym.s+"' is already defined as a function"); } else if (externals.find(tag) != externals.end()) { restore_globals(g); @@ -3427,7 +3596,9 @@ case EXPR::STR: return sbox(x.sval()); case EXPR::PTR: - assert(0 && "not implemented"); + // FIXME: Only null pointers are supported right now. + assert(x.pval() == 0); + return pbox(x.pval()); // application: case EXPR::APP: if (x.ttag() != 0) { @@ -3764,6 +3935,11 @@ return call("pure_string_dup", s); } +Value *interpreter::pbox(void *p) +{ + return call("pure_pointer", p); +} + // Variable access. static uint32_t argno(uint32_t n, path &p) @@ -3987,6 +4163,12 @@ return call(name, p); } +Value *interpreter::call(string name, void *p) +{ + assert(p==0); + return call(name, ConstantPointerNull::get(VoidPtrTy)); +} + Value *interpreter::call(string name, Value *x, const char *s) { Env& e = act_env(); Modified: pure/trunk/interpreter.hh =================================================================== --- pure/trunk/interpreter.hh 2008-06-25 07:39:52 UTC (rev 310) +++ pure/trunk/interpreter.hh 2008-06-25 23:00:24 UTC (rev 311) @@ -310,24 +310,39 @@ /* Evaluate an expression and define global variables. This works like eval() above, but also binds the variables in pat to the corresponding values. Also, these routines throw a C++ exception of the err type if any - of the variable symbols to be defined is already bound to a function. - Otherwise the result is the evaluated expression to be matched. Returns a - null pointer if an exception occurred during the evaluation or if the - pattern failed to match. Both the result and the exception value (if any) - are to be freed by the caller. */ + of the variable symbols to be defined is already bound to a different + kind of symbol. Otherwise the result is the evaluated expression to be + matched. Returns a null pointer if an exception occurred during the + evaluation or if the pattern failed to match. Both the result and the + exception value (if any) are to be freed by the caller. */ pure_expr *defn(expr pat, expr x); pure_expr *defn(expr pat, expr x, pure_expr*& e); /* Bind a global variable to a given value. This binds the given variable symbol directly to the given value, without matching and evaluating - anything. It is still checked whether the variable symbol is already - bound to a function, in which case an err exception is thrown. */ + anything. It is still checked that the variable symbol is not already + bound to a different kind of symbol, otherwise an err exception is + thrown. */ void defn(int32_t tag, pure_expr *x); void defn(const char *varname, pure_expr *x) { defn(symtab.sym(varname).f, x); } + /* Constant definitions. These work like the variable definition methods + above, but define constant symbols which are directly substituted into + the right-hand sides of equations rather than being evaluated at + runtime. The right-hand side expression is evaluated and matched against + the left-hand side pattern as usual. Unlike variables, existing constant + symbols cannot be redefined, so they have to be cleared before you can + give them new values. */ + + pure_expr *const_defn(expr pat, expr x); + pure_expr *const_defn(expr pat, expr x, pure_expr*& e); + void const_defn(int32_t tag, pure_expr *x); + void const_defn(const char *varname, pure_expr *x) + { const_defn(symtab.sym(varname).f, x); } + /* Process pending compilations of function definitions. This is also done - automatically when eval() or defn() is invoked. */ + automatically when eval() or defn()/const_defn() is invoked. */ void compile(); /* Errors and warnings. These are for various types of messages from the @@ -352,6 +367,7 @@ void compile(expr x); void declare(prec_t prec, fix_t fix, list<string> *ids); void define(rule *r); + void define_const(rule *r); void exec(expr *x); void clear(int32_t f = 0); void clearsym(int32_t f); @@ -466,6 +482,7 @@ llvm::Value *call(string name, const mpz_t& z); llvm::Value *call(string name, double d); llvm::Value *call(string name, const char *s); + llvm::Value *call(string name, void *p); llvm::Value *call(string name, llvm::Value *x, const mpz_t& z); llvm::Value *call(string name, llvm::Value *x, const char *s); void make_bigint(const mpz_t& z, llvm::Value*& sz, llvm::Value*& ptr); Modified: pure/trunk/lexer.ll =================================================================== --- pure/trunk/lexer.ll 2008-06-25 07:39:52 UTC (rev 310) +++ pure/trunk/lexer.ll 2008-06-25 23:00:24 UTC (rev 311) @@ -131,9 +131,9 @@ now. */ static const char *commands[] = { - "cd", "clear", "extern", "help", "infix", "infixl", "infixr", "let", "list", - "ls", "nullary", "override", "postfix", "prefix", "pwd", "quit", "run", - "save", "stats", "underride", "using", 0 + "cd", "clear", "def", "extern", "help", "infix", "infixl", "infixr", "let", + "list", "ls", "nullary", "override", "postfix", "prefix", "pwd", "quit", + "run", "save", "stats", "underride", "using", 0 }; static char * @@ -399,7 +399,7 @@ int32_t f = it->first; const env_info& e = it->second; const symbol& sym = interp.symtab.sym(f); - if (!((e.t == env_info::fvar)?vflag:fflag)) continue; + if (!((e.t == env_info::fun)?fflag:vflag)) continue; bool matches = e.temp >= tflag; if (!matches && !sflag && args.l.empty() && e.t == env_info::fun && fflag) { @@ -486,6 +486,17 @@ } else sout << "let " << sym.s << " = " << *(pure_expr**)jt->second.val << ";\n"; + } else if (jt->second.t == env_info::cvar) { + nvars++; + if (sflag) { + sout << sym.s << string(maxsize-sym.s.size(), ' ') + << " cst"; + if (lflag) sout << " " << sym.s << " = " + << *jt->second.cval << ";"; + sout << endl; + } else + sout << "def " << sym.s << " = " << *jt->second.cval + << ";\n"; } else { if (xt != interp.externals.end()) { const ExternInfo& info = xt->second; @@ -743,6 +754,7 @@ prefix yylval->fix = prefix; return token::FIX; postfix yylval->fix = postfix; return token::FIX; nullary return token::NULLARY; +def return token::DEF; let return token::LET; case return token::CASE; of return token::OF; Modified: pure/trunk/parser.yy =================================================================== --- pure/trunk/parser.yy 2008-06-25 07:39:52 UTC (rev 310) +++ pure/trunk/parser.yy 2008-06-25 23:00:24 UTC (rev 311) @@ -98,6 +98,7 @@ %token NULLARY "nullary" %token <fix> FIX "fixity" +%token DEF "def" %token LET "let" %token CASE "case" %token OF "of" @@ -274,6 +275,8 @@ { action(interp.exec($1), delete $1); } | LET simple_rule { action(interp.define($2), delete $2); } +| DEF simple_rule +{ action(interp.define_const($2), delete $2); } | rule { rulel *rl = 0; action(interp.add_rules(interp.globenv, Modified: pure/trunk/printer.cc =================================================================== --- pure/trunk/printer.cc 2008-06-25 07:39:52 UTC (rev 310) +++ pure/trunk/printer.cc 2008-06-25 23:00:24 UTC (rev 311) @@ -421,6 +421,9 @@ } break; } + case env_info::cvar: + os << "def " << sym.s << " = " << *info.cval; + break; case env_info::fvar: os << "let " << sym.s << " = " << *(pure_expr**)info.val; break; @@ -628,8 +631,6 @@ assert(x); //os << "{" << x->refc << "}"; switch (x->tag) { - case 0: - return os << "<<anonymous closure " << (void*)x << ">>"; case EXPR::INT: return os << x->data.i; case EXPR::BIGINT: { @@ -744,8 +745,11 @@ return os << pure_paren(95, u) << " " << pure_paren(100, v); } default: { - assert(x->tag > 0); + if (x->tag == 0) + return os << "<<closure " << (void*)x << ">>"; const symbol& sym = interpreter::g_interp->symtab.sym(x->tag); + if (x->data.clos && x->data.clos->local) + return os << "<<closure " << sym.s << ">>"; if (sym.prec < 10) return os << '(' << sym.s << ')'; else Modified: pure/trunk/pure.cc =================================================================== --- pure/trunk/pure.cc 2008-06-25 07:39:52 UTC (rev 310) +++ pure/trunk/pure.cc 2008-06-25 23:00:24 UTC (rev 311) @@ -47,9 +47,9 @@ #define LICENSE "This program is free software distributed under the GNU Public License\n(GPL V3 or later). Please see the COPYING file for details.\n" static const char *commands[] = { - "cd", "clear", "extern", "help", "infix", "infixl", "infixr", "let", "list", - "ls", "nullary", "override", "postfix", "prefix", "pwd", "quit", "run", - "save", "stats", "underride", "using", 0 + "cd", "clear", "def", "extern", "help", "infix", "infixl", "infixr", "let", + "list", "ls", "nullary", "override", "postfix", "prefix", "pwd", "quit", + "run", "save", "stats", "underride", "using", 0 }; /* Generator functions for command completion. */ Modified: pure/trunk/test/test004.log =================================================================== --- pure/trunk/test/test004.log 2008-06-25 07:39:52 UTC (rev 310) +++ pure/trunk/test/test004.log 2008-06-25 23:00:24 UTC (rev 311) @@ -35,15 +35,15 @@ foo 99; 99 foo2 99; -bar 100 +<<closure bar>> 100 foo2 98; -bar 98 +<<closure bar>> 98 foo3 99; -bar +<<closure bar>> foo3 99 98; -bar 98 +<<closure bar>> 98 foo3 99 99; -bar 100 +<<closure bar>> 100 loop = loop; count n/*0:1*/ = ct/*0*/ n/*0:1*/ with ct n/*0:1*/::int = n/*0:1*/ if n/*0:1*/<=0; ct n/*0:1*/::int = ct/*1*/ (n/*0:1*/-1) { rule #0: ct n::int = n if n<=0 This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |