├── LICENSE ├── Makefile ├── README ├── cl.cc ├── cl.h ├── fftest.cc ├── primops.cc ├── reader.cc ├── reader.h ├── rlstream.cc ├── rlstream.h ├── stopwatch.cc ├── stopwatch.h └── testdata /LICENSE: -------------------------------------------------------------------------------- 1 | Ciel - a Lisp-like language implemented in C++. 2 | 3 | Copyright (C) 2010 by Ron Garret, all rights reserved. 4 | 5 | This program is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 2 of the License, or 8 | (at your option) any later version. 9 | 10 | This program is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . 17 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | 2 | # Makefile for Ciel 3 | # 4 | # NOTE: The -O2 optimized version of cl (called clo) dumps core on OS X. 5 | # Not sure why. 6 | # 7 | 8 | OS = $(shell sh -c 'uname') 9 | 10 | ifeq ($(OS), Linux) 11 | SHARED_LIBRARY_FLAGS = -shared -fPIC 12 | else ifeq ($(OS), Darwin) 13 | SHARED_LIBRARY_FLAGS = -bundle -undefined dynamic_lookup # go figure 14 | endif 15 | 16 | CC = g++ -m64 -Wall -rdynamic 17 | LIBS= -lcln -lgc -ldl -lreadline -ltermcap # or -lncurses, dealer choice 18 | OBJS = rlstream.o stopwatch.o reader.o primops.o 19 | 20 | cl: cl.cc cl.h ${OBJS} 21 | ${CC} cl.cc ${OBJS} -g -o cl ${LIBS} 22 | 23 | clo: cl.cc cl.h ${OBJS} 24 | ${CC} -O2 cl.cc ${OBJS} -o clo ${LIBS} 25 | 26 | primops.o: primops.cc cl.h 27 | ${CC} -O2 -c primops.cc 28 | 29 | reader.o: reader.cc reader.h cl.h rlstream.h 30 | ${CC} -O2 -c reader.cc 31 | 32 | rlstream.o: rlstream.cc rlstream.h 33 | ${CC} -O2 -c rlstream.cc -DUSE_GNU_READLINE 34 | 35 | stopwatch.o: stopwatch.cc stopwatch.h 36 | ${CC} -O2 -c stopwatch.cc 37 | 38 | fftest: fftest.cc cl.h 39 | ${CC} $(SHARED_LIBRARY_FLAGS) -o fftest fftest.cc 40 | 41 | test: 42 | time ./cl const string clString::name = "String"; 25 | 26 | template<> 27 | void clString::print(ostream &os) { os << '"' << theThing << '"'; } 28 | 29 | /////////////////////// 30 | /// 31 | /// Characters 32 | /// 33 | 34 | template<> const string clChar::name = "Character"; 35 | 36 | template<> 37 | void clChar::print(ostream &os) { os << "'" << theThing << "'"; } 38 | 39 | /////////////////////// 40 | /// 41 | /// Dictionaries 42 | /// 43 | 44 | template<> 45 | clObject& dictionary::ref(clObject& i) { 46 | gc_hash_map::iterator r = this->theMap.find(&i); 47 | if (r == this->theMap.end()) return nil; 48 | return *r->second; 49 | } 50 | 51 | template<> 52 | void dictionary::del(clObject& i) { 53 | gc_hash_map::iterator r = this->theMap.find(&i); 54 | if (r == this->theMap.end()) return; 55 | this->theMap.erase(r); 56 | } 57 | 58 | template<> 59 | void dictionary::setref(clObject &i, clObject &v) { 60 | this->theMap[&i] = &v; 61 | } 62 | 63 | template<> 64 | clObject& dictionary::size() { 65 | return *new clNumber(this->theMap.size()); 66 | } 67 | 68 | 69 | ///////////////////////////////////// 70 | // 71 | // Numbers 72 | // 73 | 74 | string type_of(cl_N n) { 75 | if (instanceof(n, cl_I_ring)) return "integer"; 76 | else if (instanceof(n, cl_RA_ring)) return "rational"; 77 | else if (instanceof(n, cl_R_ring)) return "float"; 78 | else if (instanceof(n, cl_C_ring)) return "complex"; 79 | else return "unknown"; 80 | } 81 | 82 | ////////////////////////////// 83 | /// 84 | /// Vectors 85 | /// 86 | 87 | int position(gcVector& v, clObject& o) { 88 | for (unsigned int i=0; itheVector.begin(); 97 | gcVector::iterator end = this->theVector.end(); 98 | if (i!=end) { 99 | s << **i; 100 | for (i++; i!=end; i++) s << ' ' << **i; 101 | } 102 | s << ']'; 103 | } 104 | 105 | 106 | ////////////////////////// 107 | /// 108 | /// Cons Cells 109 | /// 110 | 111 | consCell& cons(clObject &car, clObject &cdr) { 112 | consCell *c = new consCell(); 113 | c->theCar = &car; 114 | c->theCdr = &cdr; 115 | return *c; 116 | } 117 | 118 | consCell& vec2list(gcVector& v, unsigned int n=0) { 119 | if (n==v.size()) return nil; 120 | else return cons(*v[n], vec2list(v,n+1)); 121 | } 122 | 123 | void consCell::print(ostream &s) { 124 | s << '(' << car(this); 125 | clObject *o = this->theCdr; 126 | consCell *p; 127 | while((p = theCons(o)) && !null(p)) { 128 | s << ' ' << car(p); 129 | o = p->theCdr; 130 | } 131 | if (!null(o)) s << " . " << *o; 132 | s << ')'; 133 | } 134 | 135 | clObject& consCell::operator[](int n) { 136 | return (n<=0) ? car(this) : theCons(cdr(this))[n-1]; 137 | } 138 | 139 | 140 | int length(consCell& c) { 141 | return null(c) ? 0 : length(theCons(cdr(c)))+1; 142 | } 143 | 144 | int position(clObject& o, consCell& c, int i=0) { 145 | if (null(c)) return -1; 146 | return (&o == &(car(c)) ? i : position(o, theCons(cdr(c)), i+1)); 147 | } 148 | 149 | gcVector& list2vec(consCell& c, gcVector& v = *new gcVector()) { 150 | // gcVector& v = *new gcVector(); 151 | clObject* cp = &c; 152 | while (cp->typeOf()=="cons") { 153 | v.push_back(&car(cp)); 154 | cp = &cdr(cp); 155 | } 156 | return v; 157 | } 158 | 159 | 160 | //////////////////////////// 161 | /// 162 | /// Error 163 | /// 164 | void error(string msg, clObject& arg) { 165 | throw &cons(*new clString(msg), arg); 166 | } 167 | 168 | clSymbol& intern(string s) { 169 | clSymbol* smb = symbolTable[s]; 170 | if (smb == NULL) { 171 | smb = new clSymbol(s); 172 | symbolTable[s] = smb; 173 | } 174 | return *smb; 175 | } 176 | 177 | //////////////////////// 178 | /// 179 | /// Dynamic environments 180 | /// 181 | 182 | void dEnv::print (ostream& s) { 183 | for (gc_map::iterator i = m.begin(); i != m.end(); i++ ) { 184 | if (i->second == this) continue; 185 | s << *i->first << " : "; 186 | if (i->second) s << *i->second; 187 | else s << ""; 188 | s << '\n'; 189 | } 190 | } 191 | 192 | clObject& dEnv::lkup(clSymbol& s) { 193 | gc_map::iterator i = m.find(&s); 194 | if (i != m.end()) return *(i->second); 195 | if (!parent) { error("Unbound symbol", s); } 196 | return parent->lkup(s); 197 | } 198 | 199 | 200 | //////////////////////// 201 | /// 202 | /// Lexical environments 203 | /// 204 | class Env : public gc { 205 | public: 206 | gcVector& paramv; 207 | gcVector valuev; 208 | Env *parent; 209 | 210 | Env(clObject& params, gcVector& _paramv, gcVector& values, Env* _parent=0) 211 | : paramv(_paramv), valuev(values), parent(_parent) 212 | { 213 | if (valuev.size() != paramv.size()) 214 | error("Wrong number of arguments", nil); 215 | } 216 | 217 | clObject& lkup(clSymbol& s) { 218 | int i = position(paramv, s); 219 | if (i>=0) return *valuev[i]; 220 | if (parent) return parent->lkup(s); 221 | return TLE.lkup(s); 222 | } 223 | 224 | void set(clSymbol& s, clObject& o) { 225 | int i = position(paramv, s); 226 | if (i>=0) { valuev[i] = &o; return; } 227 | if (parent) { parent->set(s, o); return; } 228 | else TLE.set(s,o); 229 | } 230 | }; 231 | 232 | // This really need to go somewhere else. There are other static 233 | // initializers in other files (e.g. primops) so we're playing Russion 234 | // roullette here. 235 | // 236 | GC_initter dummy; // Force GC init before other static initializers 237 | Env NLE(nil, *new gcVector(), *new gcVector()); // Null lexical environment 238 | 239 | 240 | /////////////////////// 241 | // 242 | // Closures 243 | // 244 | 245 | class clClosure : public clObject { 246 | public: 247 | virtual clObject& apply(clVector& args) =0; 248 | }; 249 | 250 | class vecClosure : public clClosure { 251 | Env& env; 252 | gcVector& params; 253 | gcVector& body; 254 | 255 | vecClosure(gcVector& _params, gcVector& _body, Env& _env) 256 | : env(_env), params(_params), body(_body) {} 257 | 258 | virtual clObject& apply(clVector& args) { 259 | Env& e = *new Env(nil, params, args.theVector, &env); 260 | gcVector::iterator start = body.begin()+1; 261 | gcVector::iterator end = body.end(); 262 | clObject* result = &nil; 263 | for (gcVector::iterator i = start; i != end; i++) { 264 | result = &((**i).eval(e)); 265 | } 266 | return *result; 267 | } 268 | }; 269 | 270 | class consClosure : public clClosure { 271 | public: 272 | Env* env; 273 | clObject* params; // The original formal parameters as specified by the user 274 | gcVector paramv; // The formal parameters converted to a vector 275 | int restarg; // Non-zero means the last formal is a restarg 276 | consCell* body; 277 | 278 | consClosure(clObject& _params, clObject& _body, Env& _env) { 279 | // Check for legal arglist 280 | try { 281 | paramv = dynamic_cast(_params).theVector; 282 | } catch(bad_cast) { 283 | clObject* p = &_params; 284 | consCell *p1; 285 | while ((p1 = theCons(p)) && !null(p1)) { 286 | if (!the(&car(p1))) error("Illegal argument", car(p1)); 287 | paramv.push_back(&car(p1)); 288 | p = &cdr(p1); 289 | } 290 | if (!null(p)) { 291 | p = the(p); 292 | if (!p) error("Illegal restarg", _params); 293 | paramv.push_back(p); 294 | restarg = (p ? 1 : 0); 295 | } 296 | } 297 | 298 | // Check for legal body 299 | clObject* p = &_body; 300 | consCell *p1; 301 | while ((p1 = theCons(p)) && !null(p1)) p = &cdr(p1); 302 | if (!null(p)) error("Illegal function body form", *p); 303 | 304 | params = &_params; 305 | body = theCons(&_body); 306 | env = &_env; 307 | } 308 | 309 | 310 | void print(ostream &os) { os << "cfn-" << *params << *body; } 311 | string typeOf() { return "consClosure"; } 312 | 313 | clObject& apply(clVector& args) { 314 | // Create a frame for the function arguments 315 | if (restarg) { 316 | int nargs = paramv.size(); 317 | gcVector& restval = *new gcVector(); 318 | for (Uint i = nargs-1; i'; } 357 | string typeOf() { return "Special form"; } 358 | 359 | clObject& apply(argsT& args, Env& e) { return (*applier)(args, e); } 360 | }; 361 | 362 | clObject& quote_apply(argsT& args, Env& e) { return args[0]; } 363 | 364 | clObject& fn_apply(argsT& args, Env& e) { 365 | return *new consClosure(args[0], cdr(vec2list(args.theVector)), e); 366 | } 367 | 368 | clObject& set_apply(argsT& args, Env& e) { 369 | clSymbol& target = the(args[0]); 370 | clObject& value = args[1].eval(e); 371 | e.set(target, value); 372 | return value; 373 | } 374 | 375 | clObject& if_apply(argsT& args, Env& e) { 376 | clObject& condition = args[0].eval(e); 377 | if (!null(condition)) return args[1].eval(e); 378 | return args[2].eval(e); 379 | } 380 | 381 | clObject& try_apply(argsT& args, Env& e) { 382 | try { 383 | return args[0].eval(e); 384 | } catch (clObject* o) { 385 | // Not quite right -- should evalute to a continuation and 386 | // pass *o as an arg. 387 | return args[1].eval(e); 388 | } 389 | } 390 | 391 | clObject& dotimes_apply(argsT& args, Env& e) { 392 | cl_I n = theInteger(args[0].eval(e)); 393 | clObject& form = args[1]; 394 | for (int i=0; ieval(*e); } 418 | 419 | private: 420 | unwindFrame(); 421 | unwindFrame(const unwindFrame&); 422 | }; 423 | 424 | clObject& unwind_apply(argsT& args, Env& e) { 425 | unwindFrame f(args[1], e); 426 | return args[0].eval(e); 427 | } 428 | 429 | //////////////////// 430 | /// 431 | /// Ctrl-C handler 432 | /// 433 | #include 434 | int stopeval = 0; 435 | void ctrl_c_handler(int signum) { stopeval=1; } 436 | 437 | ////////////// 438 | // 439 | // Stack guard 440 | // 441 | #define STACK_LIMIT 1000000 442 | void* stackbottom = 0; 443 | 444 | 445 | //////////////////////// 446 | /// 447 | /// Eval 448 | 449 | clObject& eval(clObject& o) { 450 | return o.eval(NLE); 451 | } 452 | 453 | clObject& clSymbol::eval(Env& e) { return e.lkup(*this); } 454 | 455 | clVector& evalArgs(argsT& args, Env &e) { 456 | clVector& result = *new clVector(); 457 | for (gcVector::iterator i = args.theVector.begin(); 458 | i != args.theVector.end(); 459 | i++) 460 | vpe(result, (*i)->eval(e)); 461 | return result; 462 | } 463 | 464 | clVector& evalArgs(consCell& args, Env &e) { 465 | clVector& result = *new clVector(); 466 | clObject* p = &args; 467 | consCell *p1; 468 | while ((p1 = theCons(p)) && !null(p1)) { 469 | vpe(result, car(p1).eval(e)); 470 | p = &cdr(p1); 471 | } 472 | return result; 473 | } 474 | 475 | void inline evalPrep() { 476 | // Check for ctrl-c 477 | if (stopeval) { 478 | stopeval=0; 479 | // insert debugger here some day 480 | throw &intern("Interrupt"); 481 | } 482 | // Check for possible stack overflow 483 | int dummy; 484 | // Amazing that this doesn't generate a warning 485 | if (abs((long)stackbottom-(long)(&dummy)) > STACK_LIMIT) { 486 | throw &intern("Stack overflow"); 487 | } 488 | } 489 | 490 | clObject& clVector::eval(Env& e) { 491 | evalPrep(); 492 | argsT args; 493 | 494 | // Evaluate the operator 495 | clObject& op = (*this)[0].eval(e); 496 | 497 | // Special forms get unevaled arguments 498 | specialForm* sp = the(&op); 499 | if (sp) { 500 | for (Uint i=1; i < this->theVector.size(); i++) 501 | vpe(args, *(this->theVector[i])); 502 | return sp->apply(args, e); 503 | } 504 | 505 | // Primops and closures get evaluated arguments 506 | for (Uint i=1; itheVector.size(); i++) 507 | vpe(args, (this->theVector[i])->eval(e)); 508 | primop* p = the(&op); 509 | if (p) return p->apply(args); 510 | clClosure* c = dynamic_cast(&op); 511 | if (c) return c->apply(args); 512 | // The operator was not callable 513 | throw &cons(intern("Not a function object"), op); 514 | return nil; 515 | } 516 | 517 | clObject& consCell::eval(Env& e) { 518 | evalPrep(); 519 | // Evaluate the CAR 520 | clObject& op = car(this).eval(e); 521 | // Special forms get unevaled arguments 522 | specialForm* sp = the(&op); 523 | if (sp) { 524 | argsT args(list2vec(theCons(cdr(this)))); 525 | return sp->apply(args, e); 526 | } 527 | // Primops and closures get evaluated arguments 528 | argsT& args = evalArgs(theCons(cdr(this)), e); 529 | primop* p = the(&op); 530 | if (p) return p->apply(args); 531 | clClosure* c = dynamic_cast(&op); 532 | if (c) return c->apply(args); 533 | // The CAR was not callable 534 | throw &cons(intern("Not a function object"), op); 535 | return nil; 536 | } 537 | 538 | void CL_init() { GC_init(); } 539 | 540 | int main(int argc, const char* argv[]) { 541 | GC_INIT(); 542 | new specialForm("quote", "e_apply); 543 | new specialForm("set", &set_apply); 544 | new specialForm("fn", &fn_apply); 545 | new specialForm("if", &if_apply); 546 | new specialForm("try", &try_apply); 547 | new specialForm("dotimes", &dotimes_apply); 548 | new specialForm("time", &time_apply); 549 | new specialForm("unwind-protect", &unwind_apply); 550 | 551 | clSymbol& lastResult = intern("_"); 552 | 553 | signal(SIGINT, &ctrl_c_handler); 554 | int dummy; 555 | stackbottom=&dummy; 556 | TLE.set(intern("tle"), TLE); 557 | 558 | while(1) { 559 | clObject& o = readObject(); 560 | stopeval=0; // Clear latent interrupts 561 | try { 562 | clObject& result = eval(o); 563 | TLE.set(lastResult, result); 564 | cout << "--> " << result << '\n'; 565 | } catch (clObject *o) { 566 | cout << "*** Uncaught exception: " << *o << '\n'; 567 | } catch (bad_cast) { 568 | cout << "*** Wrong type argument\n"; 569 | } catch (bad_alloc) { 570 | cout << "*** Out of memory\n"; 571 | exit(-1); 572 | } catch (out_of_range) { 573 | cout << "*** Vector reference out of range\n"; 574 | } catch (...) { 575 | cout << "*** Zowie! Weird exception thrown!\n"; 576 | } 577 | } 578 | return 0; 579 | } 580 | -------------------------------------------------------------------------------- /cl.h: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include // For bad_cast exception type 7 | #include 8 | #include 9 | #include 10 | // #include 11 | #include "stopwatch.h" 12 | 13 | using namespace cln; 14 | using namespace std; 15 | using namespace __gnu_cxx; 16 | 17 | string type_of(cl_N n); 18 | 19 | //////////////////////// 20 | // 21 | // Objects 22 | // 23 | 24 | class Env; // Forward declaration needed so we can declare eval 25 | 26 | class clObject : public gc { 27 | public: 28 | virtual void print(ostream &s)=0; 29 | virtual string typeOf()=0; 30 | virtual clObject& eval(Env& e) { return *this; } 31 | virtual ~clObject() {} // Do we need this? Yes. Why? I don't know. 32 | 33 | inline operator int(); 34 | }; 35 | 36 | class clNumber : public clObject { 37 | public: 38 | cl_N n; 39 | 40 | template inline clNumber(T s) { n = cl_N(s); } 41 | // clNumber(int _n) { n = _n; } 42 | inline void print(ostream &s) { s << n; } 43 | inline string typeOf() { return type_of(n); } 44 | }; 45 | 46 | ostream& operator<<(ostream &s, clObject &o); 47 | 48 | ////////////////////// 49 | /// 50 | /// Type conversions 51 | /// 52 | template 53 | inline T* the(clObject *x) { return dynamic_cast(x); } 54 | template 55 | inline T& the(clObject &x) { return dynamic_cast(x); } 56 | 57 | inline cl_N theNumber(clObject& o) { return the(o).n; } 58 | inline cl_R theReal(clObject& o) { return As(cl_R)(the(o).n); } 59 | inline cl_I theInteger(clObject& o) { return As(cl_I)(the(o).n); } 60 | 61 | inline clObject::operator int() { return cl_I_to_int(theInteger(*this)); } 62 | 63 | ///////////////////// 64 | /// 65 | /// Sequences 66 | /// 67 | class clSequence : public clObject { 68 | virtual clObject& ref(int i)=0; 69 | virtual void refSet(int i, clObject* o)=0; 70 | virtual clSequence& slice(int i, int j)=0; 71 | }; 72 | 73 | 74 | /////////////////////////////// 75 | // 76 | // Wrappers for native types (string and characters) 77 | // 78 | template 79 | class clWrapper : public clObject { 80 | const static string name; 81 | public: 82 | T& theThing; 83 | clWrapper() : theThing(*new T()) {} 84 | clWrapper(T& x) : theThing(*new T(x)) {} 85 | clWrapper(const T& x) : theThing(*new T(x)) {} 86 | string typeOf() { return name; } 87 | void print(ostream &os); 88 | virtual clObject& eval(Env& e) { return *this; } 89 | }; 90 | 91 | // Strings 92 | typedef clWrapper clString; 93 | 94 | // Characters 95 | typedef clWrapper clChar; 96 | 97 | ///////////////////////////// 98 | /// 99 | /// Dictionaries 100 | /// 101 | 102 | // Provide a hash implementation for pointers 103 | namespace std { 104 | template<> struct hash { 105 | inline int operator()(void* const &x) const { return (long)x; } 106 | }; 107 | } 108 | 109 | typedef gc_allocator gc_alloc; 110 | 111 | typedef 112 | unordered_map, equal_to, 113 | gc_allocator > > 114 | gc_hash_map; 115 | 116 | namespace std { 117 | template<> struct less { 118 | int operator()(const cl_R& x, const cl_R& y) const { 119 | return x > 126 | gc_map; 127 | 128 | class clMap : public clObject { 129 | public: 130 | string typeOf() { return ""; } 131 | virtual clObject& ref(clObject&) = 0; 132 | virtual void setref(clObject&, clObject&) = 0; 133 | virtual clObject& size() = 0; 134 | virtual void del(clObject&) = 0; 135 | }; 136 | 137 | template 138 | class clMapImpl : public clMap { 139 | public: 140 | T theMap; 141 | virtual void print(ostream&); 142 | virtual clObject& ref(clObject&); 143 | virtual void setref(clObject&, clObject&); 144 | virtual clObject& size(); 145 | virtual void del(clObject&); 146 | }; 147 | 148 | template 149 | void clMapImpl::print(ostream &s) { 150 | // Needs a circularity check 151 | s << '{'; 152 | // T& m = theMap; 153 | typename T::iterator i = theMap.begin(); 154 | if (i != theMap.end()) { 155 | s << *i->first << " : " << *i->second; 156 | for (i++; i != theMap.end(); i++) { 157 | s << ", " << *i->first << " : "; 158 | if (i->second) s << *i->second; 159 | else s << ""; 160 | } 161 | } 162 | s << '}'; 163 | } 164 | 165 | typedef clMapImpl dictionary; 166 | 167 | 168 | /////////////////////////// 169 | // 170 | // Vectors 171 | // 172 | typedef vector gcVector; 173 | 174 | extern out_of_range range_exception; 175 | 176 | inline clObject& at(gcVector& v, int i) { 177 | if ((i<0) || (i>=(int)v.size())) throw(range_exception); 178 | return *(v[i]); 179 | } 180 | 181 | class clVector : public clObject { 182 | public: 183 | gcVector theVector; 184 | 185 | clVector() {} 186 | clVector(int n) : theVector(*new gcVector(n)) {} 187 | clVector(gcVector v) : theVector(v) {} 188 | 189 | string typeOf() { return "Vector"; } 190 | 191 | void print(ostream &s); 192 | clObject& eval(Env&); 193 | inline clObject& operator[](int); 194 | inline clObject& operator[](clObject&); 195 | }; 196 | 197 | inline clObject& clVector::operator[](int n) { 198 | return at(this->theVector, n); 199 | } 200 | 201 | inline clObject& clVector::operator[](clObject& n) { 202 | return at(this->theVector, cl_I_to_int(theInteger(n))); 203 | } 204 | 205 | inline void vpe(clVector& v, clObject& o) { 206 | v.theVector.push_back(&o); 207 | } 208 | 209 | inline void vset(clVector& v, int i, clObject& o) { 210 | v.theVector[i] = &o; 211 | } 212 | 213 | inline int size(clVector& v) { 214 | return v.theVector.size(); 215 | } 216 | 217 | // Function arguments are passed as clVectors 218 | typedef clVector argsT; 219 | 220 | ////////////////////////////// 221 | // 222 | // Cons cells 223 | // 224 | class consCell : public clObject { 225 | public: 226 | clObject *theCar; 227 | clObject *theCdr; 228 | 229 | void inline setCar(clObject& o) { theCar = &o; } 230 | void inline setCdr(clObject& o) { theCdr = &o; } 231 | 232 | string typeOf() { return "cons"; } 233 | void print(ostream &s); 234 | clObject& eval(Env&); 235 | clObject& operator[](int); 236 | }; 237 | 238 | consCell& cons(clObject &car, clObject &cdr); 239 | 240 | inline clObject& car(consCell& c) { return *(c.theCar); } 241 | inline clObject& cdr(consCell& c) { return *(c.theCdr); } 242 | inline clObject& car(consCell* c) { return *(c->theCar); } 243 | inline clObject& cdr(consCell* c) { return *(c->theCdr); } 244 | 245 | inline consCell* theCons(clObject *x) { return the(x); } 246 | inline consCell& theCons(clObject &x) { return the(x); } 247 | 248 | inline clObject& car(clObject& c) { return *(theCons(c).theCar); } 249 | inline clObject& cdr(clObject& c) { return *(theCons(c).theCdr); } 250 | inline clObject& car(clObject* c) { return *(theCons(c)->theCar); } 251 | inline clObject& cdr(clObject* c) { return *(theCons(c)->theCdr); } 252 | 253 | // NIL 254 | class clNull : public consCell { 255 | public: 256 | void print(ostream &s) { s << "Nil"; } 257 | string typeOf() { return "null"; } 258 | 259 | clNull() { theCar = this; theCdr = this; } 260 | clObject& eval(Env& e) { return *this; } 261 | }; 262 | 263 | extern clNull nil; 264 | extern clNull& NIL; 265 | 266 | inline int null(clObject &o) { return &o==&nil; } 267 | inline int null(clObject *o) { return o==&nil; } 268 | 269 | /////////////////////////////////// 270 | // 271 | // Symbols 272 | // 273 | 274 | class clSymbol : public clObject { 275 | public: 276 | string name; 277 | 278 | clSymbol(string s) : name(s) {} 279 | 280 | void print(ostream &os) { os << name; } 281 | inline string typeOf() { return "Symbol"; } 282 | inline int operator==(clSymbol& s) { return this==&s; } 283 | clObject& eval(Env&); 284 | ~clSymbol() { cerr << "*** Destroying symbol " << name << '\n'; } 285 | 286 | private: 287 | clSymbol& operator=(const clSymbol&); 288 | clSymbol(const clSymbol&); 289 | }; 290 | 291 | clSymbol& intern(string s); 292 | extern clSymbol& QUOTE; 293 | 294 | typedef 295 | unordered_map, equal_to, 296 | gc_allocator > > 297 | gc_symbol_hash_map; 298 | 299 | extern gc_symbol_hash_map symbolTable; 300 | 301 | 302 | ///////////////// 303 | /// 304 | /// Dynamic environments 305 | /// 306 | class dEnv : public clObject { 307 | public: 308 | gc_map m; 309 | dEnv* parent; 310 | 311 | dEnv() : parent(NULL) {} 312 | 313 | void print (ostream& s); 314 | clObject& lkup(clSymbol& s); 315 | 316 | inline string typeOf() { return "environment"; } 317 | inline void set(clSymbol& s, clObject& o) { m[&s]=&o; } 318 | }; 319 | 320 | extern dEnv TLE; // Top level environment 321 | 322 | 323 | //////////////// 324 | /// 325 | /// Primops 326 | /// 327 | class primop : public clObject { 328 | public: 329 | string name; 330 | clObject& (*applier)(argsT&); 331 | int argcnt; 332 | 333 | primop(const char* n, clObject& (*a)(argsT&), int i=0); 334 | 335 | void print(ostream &os); 336 | inline string typeOf() { return "Primop"; } 337 | 338 | clObject& apply(argsT& args); 339 | }; 340 | 341 | 342 | /// Misc. hoohas 343 | inline int length(clVector& v) { return v.theVector.size(); } 344 | int length(consCell& c); 345 | void error(string msg, clObject& arg); 346 | typedef unsigned int Uint; 347 | 348 | // Hack to force a call to GC_init before other static initializers 349 | class GC_initter { 350 | public: 351 | GC_initter() { printf("Initializing GC\n"); GC_init(); } 352 | }; 353 | -------------------------------------------------------------------------------- /fftest.cc: -------------------------------------------------------------------------------- 1 | #include "cl.h" 2 | 3 | extern "C" clObject& vec(argsT& args) { 4 | // cout << "foo\n"; 5 | return args; 6 | } 7 | 8 | extern "C" clObject& baz(argsT& args) { 9 | for (int i=0; i'; } 14 | 15 | clObject& primop::apply(argsT& args) { 16 | if (argcnt && argcnt != length(args)) 17 | error("Wrong number of arguments", *this); 18 | return (*applier)(args); 19 | } 20 | 21 | #define PRIMOP(name, nargs) \ 22 | clObject& primop_ ## name ## _apply(argsT& args); \ 23 | primop _ ## name(#name, &primop_ ## name ## _apply, nargs); \ 24 | clObject& primop_ ## name ## _apply(argsT& args) 25 | 26 | 27 | ////////////////////////////////////////////////////////////////////// 28 | 29 | PRIMOP(cons, 2) { return cons(args[0], args[1]); } 30 | PRIMOP(car, 1) { return car(args[0]); } 31 | PRIMOP(cdr, 1) { return cdr(args[0]); } 32 | 33 | PRIMOP(plus, 0) { 34 | cl_N sum(0); 35 | gcVector::iterator start = args.theVector.begin(); 36 | gcVector::iterator end = args.theVector.end(); 37 | for (gcVector::iterator i = start; i!=end; i++) 38 | sum = sum + theNumber(**i); 39 | return *new clNumber(sum); 40 | } 41 | 42 | PRIMOP(times, 0) { 43 | cl_N product(1); 44 | gcVector::iterator start = args.theVector.begin(); 45 | gcVector::iterator end = args.theVector.end(); 46 | for (gcVector::iterator i = start; i!=end; i++) 47 | product = product * theNumber(**i); 48 | return *new clNumber(product); 49 | } 50 | 51 | PRIMOP(minus, 2) { 52 | return *new clNumber(theNumber(args[0]) - theNumber(args[1])); 53 | } 54 | 55 | PRIMOP(div, 2) { 56 | return *new clNumber(theNumber(args[0]) / theNumber(args[1])); 57 | } 58 | 59 | PRIMOP(lte, 2) { 60 | if (theReal(args[0]) <= theReal(args[1])) return clTrue; 61 | else return nil; 62 | } 63 | 64 | PRIMOP(gte, 2) { 65 | if (theReal(args[0]) >= theReal(args[1])) return clTrue; 66 | else return nil; 67 | } 68 | 69 | PRIMOP(lt, 2) { 70 | if (theReal(args[0]) < theReal(args[1])) return clTrue; 71 | else return nil; 72 | } 73 | 74 | PRIMOP(gt, 2) { 75 | if (theReal(args[0]) > theReal(args[1])) return clTrue; 76 | else return nil; 77 | } 78 | 79 | PRIMOP(eql, 2) { 80 | try { 81 | if (theNumber(args[0]) == theNumber(args[1])) 82 | return clTrue; 83 | } catch (bad_cast) { 84 | if (&args[0] == &args[1]) return clTrue; 85 | } 86 | return nil; 87 | } 88 | 89 | PRIMOP(sqrt, 1) { return *new clNumber(sqrt(theNumber(args[0]))); } 90 | PRIMOP(log, 1) { return *new clNumber(log(theNumber(args[0]))); } 91 | 92 | PRIMOP(log2, 2) { 93 | return *new clNumber(log(theNumber(args[0]), theNumber(args[1]))); 94 | } 95 | 96 | PRIMOP(expt, 2) { 97 | return *new clNumber(expt(theNumber(args[0]), theNumber(args[1]))); 98 | } 99 | 100 | PRIMOP(throw, 1) { throw(&args[0]); } 101 | 102 | PRIMOP(print, 1) { 103 | cout << args[0] << '\n'; 104 | return args[0]; 105 | } 106 | 107 | PRIMOP(typeof, 1) { return *new clString(args[0].typeOf()); } 108 | 109 | PRIMOP(system, 1) { 110 | return *new clNumber(system(the(args[0]).theThing.c_str())); 111 | } 112 | 113 | PRIMOP(vpe, 2) { 114 | vpe(the(args[0]), args[1]); 115 | return args[0]; 116 | } 117 | 118 | PRIMOP(vec, 0) { 119 | clVector& r = *new clVector(); 120 | for (int i=0; i(args[0])[args[1]]; 127 | } catch (bad_cast) { 128 | try { 129 | return *new clChar(the(args[0]).theThing[args[1]]); 130 | } catch(bad_cast) { // This is getting ugly -- we need an object system 131 | return the(args[0]).ref(args[1]); 132 | } 133 | } 134 | } 135 | 136 | PRIMOP(setref, 3) { 137 | try { 138 | vset(the(args[0]), args[1], args[2]); 139 | } catch (bad_cast) { 140 | the(args[0]).setref(args[1], args[2]); 141 | } 142 | return args[2]; 143 | } 144 | 145 | PRIMOP(del, 2) { 146 | the(args[0]).del(args[1]); 147 | return nil; 148 | } 149 | 150 | PRIMOP(make_dictionary, 0) { 151 | cout << args; 152 | return *new dictionary; 153 | } 154 | 155 | PRIMOP(len, 1) { 156 | try { 157 | clVector& v = dynamic_cast(args[0]); 158 | return *new clNumber(length(v)); 159 | } catch (bad_cast) { 160 | consCell& c = dynamic_cast(args[0]); 161 | return *new clNumber(length(c)); 162 | } 163 | } 164 | 165 | 166 | #include 167 | PRIMOP(dynload, 1) { 168 | const char* filename = the(args[0]).theThing.c_str(); 169 | void* handle = dlopen(filename, RTLD_NOW); 170 | if (handle == NULL) { 171 | cout << dlerror() << '\n'; 172 | return nil; 173 | } 174 | return args[0]; 175 | } 176 | 177 | PRIMOP(gc, 0) { 178 | GC_gcollect(); 179 | return *new clNumber(0); 180 | } 181 | -------------------------------------------------------------------------------- /reader.cc: -------------------------------------------------------------------------------- 1 | #include "cl.h" 2 | #include "rlstream.h" 3 | 4 | ////////////////////////// 5 | // 6 | // Reader 7 | // 8 | 9 | rlstream clin; 10 | 11 | string readToken(string terminators = "()[]{}',") { 12 | char c; 13 | string s = ""; 14 | clin >> c; // Skip whitespace 15 | if (clin.eof()) { 16 | cout << "\nSee ya!\n"; 17 | exit(0); 18 | } 19 | 20 | // Terminators are tokens 21 | if (terminators.find_first_of(c) != string::npos) return s+c; 22 | 23 | // Read strings - there's a horrible hack here. Strings get returned 24 | // with the leading double quote but not the trailing double quote. 25 | // the code that turns the string into a clString then strips off 26 | // the leading quote. Surrounding quotes then get added again by 27 | // the print method for clString. There has to be a better way. 28 | if (c=='"') { 29 | clin.prompt="\"... "; 30 | do { 31 | s += c; 32 | clin.get(c); 33 | if (clin.eof()) exit(0); 34 | } while (c != '"'); 35 | return s; 36 | } 37 | 38 | // Read symbols and numbers (which one we're reading gets sorted out later) 39 | // BUG: 123"foo"456 reads as a symbol. (Or is this a feature?) 40 | while(1) { 41 | s += c; 42 | c = clin.peek(); 43 | if (clin.eof()) exit(0); 44 | if (isspace(c) || terminators.find_first_of(c) != string::npos) return s; 45 | clin.get(c); 46 | } 47 | } 48 | 49 | 50 | 51 | clObject& readObject(string parenStack = "... ") { 52 | clin.prompt = (parenStack[0] == '.' ? "Ciel: " : parenStack.c_str()); 53 | string s; 54 | start: 55 | s = readToken(); 56 | 57 | if (s==")") { 58 | if (parenStack[0]=='(') return nil; 59 | cout << "Ignored extra right paren\n"; 60 | goto start; 61 | } 62 | 63 | // Handle dotted pair notation 64 | if (s==".") { 65 | if (parenStack[0] != '(') { 66 | cout << "Dot context error\n"; 67 | goto start; 68 | } 69 | clObject &o = readObject(); 70 | s = readToken(); 71 | if (s != ")") { 72 | cout << "Syntax error reading dotted pair. Expected close paren, got " 73 | << s << '\n'; 74 | goto start; 75 | } 76 | return o; 77 | } 78 | 79 | clObject *o; 80 | if (s=="(") { 81 | o = &readObject('(' + parenStack); 82 | } else if (s=="[") { 83 | string p = '[' + parenStack; 84 | clVector* v = new clVector(); 85 | clObject* o1 = &readObject(p); 86 | while (o1 != &intern("]")) { 87 | vpe(*v, *o1); 88 | o1 = &readObject(p); 89 | } 90 | o = v; 91 | } else if (s=="{") { 92 | string p = '{' + parenStack; 93 | clObject* o1 = &readObject(p); 94 | while (o1 != &intern("}")) { 95 | // vpe(*v, *o1); 96 | o1 = &readObject(p); 97 | } 98 | o = new dictionary; 99 | } else if (s=="+" || s=="-" || s == "i") { 100 | // CLN incorrectly parses "+", "-" and "i" as numbers (as 0 actually) 101 | // So we have to handle these as special cases before we invoke the 102 | // CLN number parser. 103 | o = &intern(s); 104 | } else if (s=="'") { 105 | o = &cons(intern("quote"), cons(readObject(), nil)); 106 | } else if (s[0]=='"') { 107 | o = new clString(s.substr(1)); 108 | } else try { 109 | o = new clNumber(s.c_str()); 110 | } catch(...) { 111 | o = &intern(s); 112 | } 113 | 114 | return parenStack[0] == '(' ? cons(*o, readObject(parenStack)) : *o; 115 | } 116 | -------------------------------------------------------------------------------- /reader.h: -------------------------------------------------------------------------------- 1 | 2 | clObject& readObject(string parenStack="... "); 3 | -------------------------------------------------------------------------------- /rlstream.cc: -------------------------------------------------------------------------------- 1 | ///////////////////////////////// 2 | /// 3 | /// A minimal C++ stream-like interface to readline. This really ought 4 | /// to be done with a basic_streambuf (I think) but that doesn't 5 | /// seem to work in g++ 2.96. :-( 6 | /// 7 | /// Update 8/2010: g++ is now up to version 4 so it might be worthwhile 8 | /// trying basic_streambuf again. On the other hand, what's here does 9 | /// seem to work. 10 | /// 11 | 12 | #include // For isatty() 13 | 14 | #ifdef USE_GNU_READLINE 15 | 16 | #include 17 | #include 18 | #include 19 | #include 20 | 21 | #else 22 | 23 | // Provide a minimalist alternative in case the user doesn't have 24 | // readline installed. 25 | 26 | #include 27 | #include 28 | 29 | using namespace std; 30 | 31 | char *readline(const char* prompt) { 32 | string s; 33 | if (isatty(0)) { // 0=stdin 34 | cout << prompt; 35 | cout.flush(); 36 | } 37 | getline(cin, s); 38 | if (cin.eof()) return 0; 39 | char *b = (char *)malloc(strlen(s.c_str())); // Hm, need to heck for leaks 40 | strcpy(b, s.c_str()); 41 | return b; 42 | } 43 | 44 | void add_history(char *) {} 45 | 46 | #endif 47 | 48 | ////////////////////////////////// 49 | // 50 | // Actual rlstream code starts here 51 | // 52 | 53 | #include 54 | #include // For isspace 55 | #include "rlstream.h" 56 | 57 | rlstream::rlstream(char * _prompt) { 58 | ptr = buffer = 0; 59 | prompt = _prompt; 60 | } 61 | 62 | int rlstream::eof() { return !ptr; } 63 | 64 | rlstream& rlstream::operator>>(char& c) { 65 | do get(c); while (isspace(c) && !eof()); 66 | return *this; 67 | } 68 | 69 | rlstream& rlstream::get(char& c) { 70 | c = peek(); 71 | if (c) ptr++; 72 | return *this; 73 | } 74 | 75 | int rlstream::peek() { 76 | loop: 77 | if (buffer && ptr && *ptr) return *ptr; 78 | if (buffer) { 79 | free(buffer); 80 | buffer = 0; 81 | return '\n'; 82 | } 83 | if (!isatty(0)) prompt=""; 84 | ptr = buffer = readline(prompt); 85 | if (ptr && *ptr) add_history(ptr); 86 | if (ptr) goto loop; 87 | return 0; 88 | } 89 | -------------------------------------------------------------------------------- /rlstream.h: -------------------------------------------------------------------------------- 1 | 2 | #ifndef __RLSTREAM__ 3 | #define __RLSTREAM__ 4 | 5 | // Stub to use when libreadline is not available 6 | 7 | class rlstream { 8 | public: 9 | char * buffer; 10 | char * ptr; 11 | const char * prompt; 12 | 13 | rlstream(char * = (char *)""); 14 | int eof(); 15 | int peek(); 16 | rlstream& get(char&); 17 | rlstream& operator>>(char&); 18 | }; 19 | 20 | #endif 21 | -------------------------------------------------------------------------------- /stopwatch.cc: -------------------------------------------------------------------------------- 1 | 2 | #include 3 | #include "stopwatch.h" 4 | 5 | double inline now() { 6 | return (float)clock()/CLOCKS_PER_SEC; 7 | } 8 | 9 | stopwatch::stopwatch() { startTime = cumTime = 0.0; } 10 | 11 | void stopwatch::reset() { startTime = cumTime = 0.0; } 12 | 13 | void stopwatch::start() { 14 | if (startTime == 0.0) startTime = now(); 15 | } 16 | 17 | double stopwatch::stop() { 18 | if (startTime != 0.0) { 19 | cumTime += now() - startTime; 20 | startTime = 0.0; 21 | } 22 | return cumTime; 23 | } 24 | 25 | double stopwatch::split() { 26 | if (startTime != 0.0) { 27 | double t0 = now(); 28 | cumTime += t0 - startTime; 29 | startTime = t0; 30 | } 31 | return cumTime; 32 | } 33 | -------------------------------------------------------------------------------- /stopwatch.h: -------------------------------------------------------------------------------- 1 | 2 | class stopwatch { 3 | public: 4 | 5 | stopwatch(); 6 | 7 | double startTime, cumTime; 8 | void start(); 9 | double split(); 10 | double stop(); 11 | void reset(); 12 | }; 13 | -------------------------------------------------------------------------------- /testdata: -------------------------------------------------------------------------------- 1 | 2 | (set <= lte) 3 | (set + plus) 4 | (set - minus) 5 | (set * times) 6 | (set / div) 7 | (set fib (fn (n) (if (<= n 1) 1 (+ (fib (- n 1)) (fib (- n 2)))))) 8 | (fib 10) 9 | (time (fib 20)) 10 | 11 | (set fact (fn (n) (if (<= n 1) 1 (* n (fact (- n 1)))))) 12 | (fact 10) 13 | (fact 100) 14 | (fact 1000) 15 | (sqrt -1) 16 | (expt (sqrt -1) (sqrt -1)) 17 | (sqrt 2.00000000000000000000000000000000000000000000000000000000000) 18 | (* _ _) 19 | 20 | (ref [1 2 3 4 5 6] 3) 21 | 22 | (throw 'err) 23 | (try (throw 'err) 'recovery) 24 | (fibo 10) 25 | (dynload "fftest") 26 | (fibo 10) 27 | --------------------------------------------------------------------------------