/* The storage required by this interpreter is 8 * 4 = 32 bytes times the symbolic constant SIZE, which is 32 * 1,000,000 = 32 megabytes. To run this interpreter in small machines, reduce the #define SIZE 1000000 below.
To compile, type cc -O -olisp lisp.c To run interactively, type lisp To run with output on screen, type lisp <test.l To run with output in file, type lisp <test.l >test.r
Reference: Kernighan & Ritchie, The C Programming Language, Second Edition, Prentice-Hall, 1988. */
#include <stdio.h> #include <time.h>
#define SIZE 1000000 /* numbers of nodes of tree storage */ #define nil 0 /* end of list marker */
long car[SIZE], cdr[SIZE]; /* tree storage */ short atom[SIZE]; /* is it an atom? */ short numb[SIZE]; /* is it a number? */ /* The following is only used for atoms */ long vlst[SIZE]; /* bindings of each atom */ long pname[SIZE]; /* print name of each atom = list of characters in reverse */ /* The following is only used for atoms that are the names of primitive functions */ short pf_numb[SIZE]; /* primitive function number (for interpreter switch) */ short pf_args[SIZE]; /* number of arguments + 1 (for input parser) */
long obj_lst; /* list of all atoms (& every other token read except numbers) */
/* locations of atoms in tree storage */ long wrd_nil, wrd_true, wrd_false, wrd_define, wrd_let, wrd_lambda, wrd_quote, wrd_if; long wrd_car, wrd_cdr, wrd_cadr, wrd_caddr, wrd_eval, wrd_try; long wrd_no_time_limit, wrd_out_of_time, wrd_out_of_data, wrd_success, wrd_failure; long left_bracket, right_bracket, left_paren, right_paren, double_quote; long wrd_zero, wrd_one;
long next = 0; /* next free node */ long col = 0; /* column in each 50 character chunk of output (preceeded by 12 char prefix) */ time_t time1; /* clock at start of execution */ time_t time2; /* clock at end of execution */ long turing_machine_tapes; /* stack of binary data for try's */ long display_enabled; /* stack of flags whether to capture displays or not */ long captured_displays; /* stack of stubs to collect captured displays on */ long q; /* for converting s-expressions into lists of bits */ long buffer2; /* buffer for converting lists of bits into s-expressions */ /* contains list of all the words in an input record */
void initialize_atoms(void); /* initialize atoms */ long mk_atom(long number, char *name, long args); /* make an atom */ long mk_numb(long value); /* make an number */ long mk_string(char *p); /* make list of characters */ long eq_wrd(long x, long y); /* are two lists of characters equal ? */ long lookup_word(long x); /* look up word in object list ? */ long cons(long x, long y); /* get free node & stuff x & y in it */ long out(char *x, long y); /* output expression */ void out_lst(long x); /* output list */ void out_atm(long x); /* output atom */ void out_chr(long x); /* output character */ long in_word2(void); /* read word */ long in_word(void); /* read word - skip comments */ long in(long mexp, long rparenokay); /* input m-exp */ long only_digits(long x); /* check if list of characters are exclusively digits */ long ev(long e); /* initialize and evaluate expression */ long eval(long e, long d); /* evaluate expression */ long evalst(long e, long d); /* evaluate list of expressions */ void clean_env(void); /* clean environment */ void restore_env(void); /* restore unclean environment */ /* bind values of arguments to formal parameters */ void bind(long vars, long args); long append(long x, long y); /* append two lists */ long eq(long x, long y); /* equal predicate */ long length(long x); /* number of elements in list */ long compare(long x, long y); /* compare two decimal numbers */ long add1(long x); /* add 1 to decimal number */ long sub1(long x); /* subtract 1 from decimal number */ long nmb(long x); /* pick-up decimal number from atom & convert non-number to zero */ long remove_leading_zeros(long x); /* from reversed list of digits of decimal number */ long addition(long x, long y, long carry_in); /* add two decimal numbers */ long multiplication(long x, long y); /* multiply two decimal numbers */ long exponentiation(long base, long exponent); /* base raised to the power exponent */ long subtraction(long x, long y, long borrow_in); /* x - y assumes x >= y */ long base2_to_10(long x); /* convert bit string to decimal number */ long halve(long x); /* used to convert decimal number to bit string */ long base10_to_2(long x); /* convert decimal number to bit string */ long size(long x); /* number of characters in print representation */ long read_bit(void); /* read one square of Turing machine tape */ void write_chr(long x); /* convert character into 8 bits */ void write_atm(long x); /* convert atom into 8 bits per character */ void write_lst(long x); /* convert s-exp into list of bits */ long read_record(void); /* read record from Turing machine tape */ long read_char(void); /* read one character from Turing machine tape */ long read_word(void); /* read word from Turing machine tape */ long read_expr(long rparenokay); /* read s-exp from Turing machine tape */
main() /* lisp main program */ { time1 = time(NULL); /* start timer */ printf("LISP Interpreter Run\n"); initialize_atoms();
while (1) { long e, f, name, def; printf("\n"); /* read lisp meta-expression, ) not okay */ e = in(1,0); printf("\n"); f = car[e]; name = car[cdr[e]]; def = car[cdr[cdr[e]]]; if (f == wrd_define) { /* definition */ if (atom[name]) { /* variable definition, e.g., define x (a b c) */ } /* end of variable definition */ else { /* function definition, e.g., define (F x y) cons x cons y nil */ long var_list = cdr[name]; name = car[name]; def = cons(wrd_lambda,cons(var_list,cons(def,nil))); } /* end of function definition */ out("define",name); out("value",def); /* new binding replaces old */ car[vlst[name]] = def; continue; } /* end of definition */ /* write corresponding s-expression */ e = out("expression",e); /* evaluate expression */ e = out("value",ev(e)); } }
void initialize_atoms(void) /* initialize atoms */ { long i; if ( nil != mk_atom(0,"()",0) ) { printf("nil != 0\n"); exit(0); /* terminate execution */ } wrd_nil = mk_atom(0,"nil",0); car[vlst[wrd_nil]] = nil; /* so that value of nil is () */ wrd_true = mk_atom(0,"true",0); wrd_false = mk_atom(0,"false",0); wrd_no_time_limit = mk_atom(0,"no-time-limit",0); wrd_out_of_time = mk_atom(0,"out-of-time",0); wrd_out_of_data = mk_atom(0,"out-of-data",0); wrd_success = mk_atom(0,"success",0); wrd_failure = mk_atom(0,"failure",0); wrd_define = mk_atom(0,"define",3); wrd_let = mk_atom(0,"let",4); wrd_lambda = mk_atom(0,"lambda",3); wrd_cadr = mk_atom(0,"cadr",2); wrd_caddr = mk_atom(0,"caddr",2); wrd_quote = mk_atom(0,"'",2); wrd_if = mk_atom(0,"if",4); wrd_car = mk_atom(1,"car",2); wrd_cdr = mk_atom(2,"cdr",2); i = mk_atom(3,"cons",3); i = mk_atom(4,"atom",2); i = mk_atom(5,"=",3); i = mk_atom(6,"display",2); i = mk_atom(7,"debug",2); i = mk_atom(8,"append",3); i = mk_atom(9,"length",2); i = mk_atom(10,"<",3); i = mk_atom(11,">",3); i = mk_atom(12,"<=",3); i = mk_atom(13,">=",3); i = mk_atom(14,"+",3); i = mk_atom(15,"*",3); i = mk_atom(16,"^",3); i = mk_atom(17,"-",3); i = mk_atom(18,"base2-to-10",2); i = mk_atom(19,"base10-to-2",2); i = mk_atom(20,"size",2); i = mk_atom(21,"read-bit",1); i = mk_atom(22,"bits",2); i = mk_atom(23,"read-exp",1); wrd_eval = mk_atom(0,"eval",2); wrd_try = mk_atom(0,"try",4); left_bracket = mk_atom(0,"[",0); right_bracket = mk_atom(0,"]",0); left_paren = mk_atom(0,"(",0); right_paren = mk_atom(0,")",0); double_quote = mk_atom(0,"\"",0); wrd_zero = mk_numb(nil); wrd_one = mk_numb(cons('1',nil)); }
long mk_atom(long number, char *name, long args) /* make an atom */ { long a; a = cons(nil,nil); /* get an empty node */ car[a] = cdr[a] = a; /* so that car & cdr of atom = atom */ atom[a] = 1; numb[a] = 0; pname[a] = mk_string(name); pf_numb[a] = number; pf_args[a] = args; /* initially each atom evaluates to self */ vlst[a] = cons(a,nil); /* put on object list */ obj_lst = cons(a,obj_lst); return a; }
long mk_numb(long value) /* make an number */ { /* digits are in reverse order, and 0 has empty list of digits */ long a; a = cons(nil,nil); /* get an empty node */ car[a] = cdr[a] = a; /* so that car & cdr of atom = atom */ atom[a] = 1; numb[a] = 1; pname[a] = value; /* must make 00099 into 99 and 000 into empty list of digits */ /* if necessary before calling this routine (to avoid removing leading zeros unnecessarily) */ pf_numb[a] = 0; pf_args[a] = 0; vlst[a] = 0; /* do not put on object list ! */ return a; }
long mk_string(char *p) /* make list of characters */ { /* in reverse order */ long v = nil; while (*p != '\0') v = cons(*p++,v); return v; }
long cons(long x, long y) /* get free node & stuff x & y in it */ { long z;
/* if y is not a list, then cons is x */ if ( y != nil && atom[y] ) return x;
if (next >= SIZE) { printf("Storage overflow!\n"); exit(0); }
long out(char *x, long y) /* output expression */ { printf("%-12s",x); col = 0; /* so can insert \n and 12 blanks every 50 characters of output */ out_lst(y); printf("\n"); return y; }
void out_lst(long x) /* output list */ { if (numb[x] && pname[x] == nil) {out_chr('0'); return;} /* null list of digits means zero */ if (atom[x]) {out_atm(pname[x]); return;} out_chr('('); while (!atom[x]) { out_lst(car[x]); x = cdr[x]; if (!atom[x]) out_chr(' '); } out_chr(')'); }
void out_atm(long x) /* output atom */ { if (x == nil) return; out_atm(cdr[x]); /* output characters in reverse order */ out_chr(car[x]); }
void out_chr(long x) /* output character */ { if (col++ == 50) {printf("\n%-12s"," "); col = 1;} putchar(x); }
long eq_wrd(long x, long y) /* are two lists of characters equal ? */ { if (x == nil) return y == nil; if (y == nil) return 0; if (car[x] != car[y]) return 0; return eq_wrd(cdr[x],cdr[y]); }
long lookup_word(long x) /* is word in object list ? */ { long i = obj_lst; while (!atom[i]) { /* if word is already in object list, don't make a new atom */ if (eq_wrd(pname[car[i]],x)) return car[i]; i = cdr[i]; } /* if word isn't in object list, make new atom & add it to object list */ i = mk_atom(0,"",0); /* adds word to object list */ pname[i] = x; return i; }
long in_word2(void) { /* read word */ static long buffer = nil; /* buffer with all the words in a line of input */ long character, word, line, end_of_line, end_of_buffer; while ( buffer == nil ) { /* read in a line */ line = end_of_line = cons(nil,nil); /* stub */ do { /* read characters until '\n' */ character = getchar(); if (character == EOF) { time2 = time(NULL); printf( "End of LISP Run\n\nElapsed time is %.0f seconds.\n", difftime(time2,time1) /* on some systems, above line should instead be: */ /* time2 - time1 */ ); exit(0); /* terminate execution */ } /* end of if (character == EOF) */ putchar(character); /* add character to end of line */ end_of_line = cdr[end_of_line] = cons(character,nil); } /* end of read characters until '\n' */ while (character != '\n'); line = cdr[line]; /* remove stub at beginning of line */ /* break line into words at ( ) [ ] ' " characters */ buffer = end_of_buffer = cons(nil,nil); /* stub */ word = nil; while ( line != nil ) { character = car[line]; line = cdr[line]; /* look for characters that break words */ if ( character == ' ' || character == '\n' || character == '(' || character == ')' || character == '[' || character == ']' || character == '\'' || character == '\"' ) { /* add nonempty word to end of buffer */ if ( word != nil ) end_of_buffer = cdr[end_of_buffer] = cons(word,nil); word = nil; /* add break character to end of buffer */ if ( character != ' ' && character != '\n' ) end_of_buffer = cdr[end_of_buffer] = cons(cons(character,nil),nil); } else { /* add character to word (in reverse order) */ /* keep only nonblank printable ASCII codes */ if (32 < character && character < 127) word = cons(character,word); } } /* end while ( line != nil ) */ buffer = cdr[buffer]; /* remove stub at beginning of buffer */ } /* end of do while ( buffer == nil ) */ /* if buffer nonempty, return first word in buffer */ word = car[buffer]; buffer = cdr[buffer]; /* first check if word consists only of digits */ if (only_digits(word)) word = mk_numb(remove_leading_zeros(word)); /* also makes 00099 into 99 and 0000 into null */ else word = lookup_word(word); /* look up word in object list */ /* also does mk_atom and adds it to object list if necessary */ return word; }
long only_digits(long x) /* check if list of characters are exclusively digits */ { while (x != nil) { long digit = car[x]; if (digit < '0' || digit > '9') return 0; x = cdr[x]; } return 1; }
long in_word(void) /* read word - skip comments */ { long w; while (1) { w = in_word2(); if (w != left_bracket) return w; while (in_word() != right_bracket) ; /* comments may be nested */ } }
long in(long mexp, long rparenokay) /* input m-exp */ { long w = in_word(), first, last, next, name, def, body, var_lst, i ; if (w == right_paren) if (rparenokay) return w; else return nil; if (w == left_paren) { /* explicit list */ first = last = cons(nil,nil); while ((next = in(mexp,1)) != right_paren) last = cdr[last] = cons(next,nil); return cdr[first]; } /* end if (w == left_paren) */ if (!mexp) return w; /* atom */ if (w == double_quote) return in(0,0); /* s-exp */ if (w == wrd_cadr) /* expand cadr */ return cons(wrd_car, cons(cons(wrd_cdr, cons(in(1,0), nil)), nil)); if (w == wrd_caddr) /* expand caddr */ return cons(wrd_car, cons(cons(wrd_cdr, cons(cons(wrd_cdr, cons(in(1,0), nil)), nil)), nil)); if (w == wrd_let) { /* expand let name def body */ name = in(1,0); def = in(1,0); body = in(1,0); if (!atom[name]) { /* let (name var_lst) def body */ var_lst = cdr[name]; name = car[name]; def = cons(wrd_quote, cons(cons(wrd_lambda, cons(var_lst, cons(def, nil))), nil)); } /* end if (!atom[name]) */ return /* let name def body */ cons(cons(wrd_quote, cons(cons(wrd_lambda, cons(cons(name, nil), cons(body, nil))), nil)), cons(def, nil)); } /* end if (w == wrd_let) */ i = pf_args[w]; if (i == 0) return w; /* normal atom */ /* atom is a primitive function with i-1 arguments */ first = last = cons(w,nil); while (--i > 0) last = cdr[last] = cons(in(1,0),nil); return first; }
long ev(long e) /* initialize and evaluate expression */ { long v; turing_machine_tapes = cons(nil,nil); display_enabled = cons(1,nil); captured_displays = cons(nil,nil); v = eval(e,wrd_no_time_limit); return (v < 0 ? -v : v); }
long eval(long e, long d) /* evaluate expression */ { /* e is expression to be evaluated d is permitted depth - decimal integer, or wrd_no_time_limit */ long f, v, args, x, y, z, vars, body, var;
if (numb[e]) return e; /* find current binding of atomic expression */ if (atom[e]) return car[vlst[e]];
f = eval(car[e],d); /* evaluate function */ e = cdr[e]; /* remove function from list of arguments */ if (f < 0) return f; /* function = error value? */
if (f == wrd_quote) return car[e]; /* quote */
if (f == wrd_if) { /* if then else */ v = eval(car[e],d); e = cdr[e]; if (v < 0) return v; /* error? */ if (v == wrd_false) e = cdr[e]; return eval(car[e],d); }
args = evalst(e,d); /* evaluate list of arguments */ if (args < 0) return args; /* error? */
x = car[args]; /* pick up first argument */ y = car[cdr[args]]; /* pick up second argument */ z = car[cdr[cdr[args]]]; /* pick up third argument */
switch (pf_numb[f]) { case 1: return car[x]; case 2: return cdr[x]; case 3: return cons(x,y); case 4: return (atom[x] ? wrd_true : wrd_false); case 5: return (eq(x,y) ? wrd_true : wrd_false); case 6: if (car[display_enabled]) return out("display",x); else {long stub, old_end, new_end; stub = car[captured_displays]; old_end = car[stub]; new_end = cons(x,nil); cdr[old_end] = new_end; car[stub] = new_end; return x;} case 7: return out("debug",x); case 8: return append((atom[x]?nil:x),(atom[y]?nil:y)); case 9: return mk_numb(length(x)); case 10: return (compare(nmb(x),nmb(y)) == '<' ? wrd_true : wrd_false); case 11: return (compare(nmb(x),nmb(y)) == '>' ? wrd_true : wrd_false); case 12: return (compare(nmb(x),nmb(y)) != '>' ? wrd_true : wrd_false); /* <= */ case 13: return (compare(nmb(x),nmb(y)) != '<' ? wrd_true : wrd_false); /* >= */ case 14: return mk_numb(addition(nmb(x),nmb(y),0)); /* no carry in initially */ case 15: return mk_numb(multiplication(nmb(x),nmb(y))); case 16: return mk_numb(exponentiation(nmb(x),nmb(y))); case 17: if (compare(nmb(x),nmb(y)) != '>') return mk_numb(nil); /* y too big to subtract from x */ else return mk_numb(remove_leading_zeros(subtraction(nmb(x),nmb(y),0))); /* no borrow in initially */ case 18: return mk_numb(base2_to_10(x)); /* convert bit string to decimal number */ case 19: return base10_to_2(nmb(x)); /* convert decimal number to bit string */ case 20: return mk_numb(size(x)); /* size of print representation of x */ case 21: return read_bit(); /* read one square of Turing machine tape */ /* convert s-exp to list of bits */ case 22: {v = q = cons(nil,nil); write_lst(x); write_chr('\n'); return cdr[v];} /* read lisp s-expression from Turing machine tape, 8 bits per char */ case 23: {v = read_record(); if (v < 0) return v; return read_expr(0);} } /* end switch (pf_numb[f]) */
if (d != wrd_no_time_limit) { if (d == nil) return - wrd_out_of_time; /* depth exceeded -> error! */ d = sub1(d); /* decrement depth */ }
if (f == wrd_try) { long stub, old_try_has_smaller_time_limit = 0; /* assume normal case, that x < d */ if (x != wrd_no_time_limit) x = nmb(x); /* convert s-exp into number */ if (x == wrd_no_time_limit || (d != wrd_no_time_limit && compare(x,d) != '<')) { old_try_has_smaller_time_limit = 1; x = d; /* continue to use older more constraining time limit */ } turing_machine_tapes = cons(z,turing_machine_tapes); display_enabled = cons(0,display_enabled); stub = cons(0,nil); /* stub to grow list on */ car[stub] = stub; /* car of stub gives end of list */ captured_displays = cons(stub,captured_displays); clean_env(); v = eval(y,x); restore_env(); turing_machine_tapes = cdr[turing_machine_tapes]; display_enabled = cdr[display_enabled]; stub = cdr[car[captured_displays]]; /* remove stub */ captured_displays = cdr[captured_displays]; if (old_try_has_smaller_time_limit && v == - wrd_out_of_time) return v; if (v < 0) return cons(wrd_failure,cons(-v,cons(stub,nil))); return cons(wrd_success,cons(v,cons(stub,nil))); }
f = cdr[f]; vars = car[f]; f = cdr[f]; body = car[f];
bind(vars,args);
v = eval(body,d);
/* unbind */ while (!atom[vars]) { var = car[vars]; if (atom[var]) vlst[var] = cdr[vlst[var]]; vars = cdr[vars]; }
return v; }
void clean_env(void) /* clean environment */ { long o = obj_lst, var; while (o != nil) { var = car[o]; vlst[var] = cons(var,vlst[var]); /* everything eval's to self */ o = cdr[o]; } car[vlst[wrd_nil]] = nil; /* except that value of nil is () */ }
void restore_env(void) /* restore unclean environment */ { long o = obj_lst, var; while (o != nil) { var = car[o]; if (cdr[vlst[var]] != nil) /* was token read in by read-exp within a try */ vlst[var] = cdr[vlst[var]]; o = cdr[o]; } }
/* bind values of arguments to formal parameters */ void bind(long vars, long args) { long var; if (atom[vars]) return; bind(cdr[vars],cdr[args]); var = car[vars]; if (atom[var]) vlst[var] = cons(car[args],vlst[var]); }
long evalst(long e, long d) /* evaluate list of expressions */ { long x, y; if (e == nil) return nil; x = eval(car[e],d); if (x < 0) return x; /* error? */ y = evalst(cdr[e],d); if (y < 0) return y; /* error? */ return cons(x,y); }
long append(long x, long y) /* append two lists */ { if (x == nil) return y; return cons(car[x],append(cdr[x],y)); }
long eq(long x, long y) /* equal predicate */ { if (x == y) return 1; if (numb[x] && numb[y]) return eq_wrd(pname[x],pname[y]); if (numb[x] || numb[y]) return 0; if (atom[x] || atom[y]) return 0; if (eq(car[x],car[y])) return eq(cdr[x],cdr[y]); return 0; }
long length(long x) /* number of elements in list */ { if (atom[x]) return nil; /* is zero */ return add1(length(cdr[x])); }
long compare(long x, long y) /* compare two decimal numbers */ { long already_decided, digit1, digit2; if (x == nil && y == nil) return '='; if (x == nil && y != nil) return '<'; if (x != nil && y == nil) return '>'; already_decided = compare(cdr[x],cdr[y]); if (already_decided != '=') return already_decided; digit1 = car[x]; digit2 = car[y]; if (digit1 == digit2) return '='; if (digit1 < digit2) return '<'; if (digit1 > digit2) return '>'; }
long add1(long x) /* add 1 to decimal number */ { long digit; if (x == nil) return cons('1',nil); digit = car[x]; if (digit != '9') return cons(digit+1,cdr[x]); return cons('0',add1(cdr[x])); }
long sub1(long x) /* subtract 1 from decimal number */ { long digit; if (x == nil) return x; /* 0 - 1 = 0 */ digit = car[x]; if (digit == '1' && cdr[x] == nil) return nil; /* 1 - 1 = 0 */ if (digit != '0') return cons(digit-1,cdr[x]); return cons('9',sub1(cdr[x])); }
long nmb(long x) /* pick-up decimal number from atom & convert non-number to zero */ { if (numb[x]) return pname[x]; return nil; }
long remove_leading_zeros(long x) /* from reversed list of digits of decimal number */ { long rest, digit; if (x == nil) return nil; digit = car[x]; rest = remove_leading_zeros(cdr[x]); if (rest == nil && digit == '0') return nil; return cons(digit,rest); }
long addition(long x, long y, long carry_in) { long sum, digit1, digit2, rest1, rest2; if (x == nil && !carry_in) return y; if (y == nil && !carry_in) return x; if (x != nil) {digit1 = car[x]; rest1 = cdr[x];} else {digit1 = '0'; rest1 = nil;} if (y != nil) {digit2 = car[y]; rest2 = cdr[y];} else {digit2 = '0'; rest2 = nil;} sum = digit1 + digit2 + carry_in - '0'; if (sum <= '9') return cons(sum,addition(rest1,rest2,0)); return cons(sum-10,addition(rest1,rest2,1)); }
long subtraction(long x, long y, long borrow_in) /* x - y assumes x >= y */ { long difference, digit1, digit2, rest1, rest2; if (y == nil && !borrow_in) return x; if (x != nil) {digit1 = car[x]; rest1 = cdr[x];} else {digit1 = '0'; rest1 = nil;} if (y != nil) {digit2 = car[y]; rest2 = cdr[y];} else {digit2 = '0'; rest2 = nil;} difference = digit1 - digit2 - borrow_in + '0'; if (difference >= '0') return cons(difference,subtraction(rest1,rest2,0)); return cons(difference+10,subtraction(rest1,rest2,1)); }
long multiplication(long x, long y) /* goes faster if x is small */ { long sum = nil; if (y == nil) return nil; /* otherwise produces result 0000 */ while (x != nil) { long digit = car[x]; while (digit-- > '0') sum = addition(sum,y,0); x = cdr[x]; y = cons('0',y); /* these are where bad decimal numbers are generated if y is zero */ } return sum; }
long exponentiation(long base, long exponent) { long product = cons('1',nil); while (exponent != nil) { product = multiplication(base,product); /* multiply faster if smaller comes first */ exponent = sub1(exponent); } return product; }
long base2_to_10(long x) /* convert bit string to decimal number */ { long result = nil; while (!atom[x]) { long next_bit = car[x]; x = cdr[x]; if (!numb[next_bit] || pname[next_bit] != nil) next_bit = 1; else next_bit = 0; result = addition(result,result,next_bit); } return result; }
long halve(long x) /* used to convert decimal number to bit string */ { long digit, next_digit, rest, halve_digit; if (x == nil) return x; /* half of 0 is 0 */ digit = car[x] - '0'; x = cdr[x]; rest = halve(x); if (x == nil) next_digit = 0; else next_digit = car[x] - '0'; next_digit = next_digit%2; /* remainder when divided by 2 */ halve_digit = '0' + (digit/2) + (5*next_digit); if (halve_digit != '0' || rest != nil) return cons(halve_digit,rest); return nil; }
long base10_to_2(long x) /* convert decimal number to bit string */ { long bits = nil; while (x != nil) { long digit = car[x] - '0'; bits = cons((digit%2 ? wrd_one : wrd_zero),bits); x = halve(x); } return bits; }
long size(long x) /* number of characters in print representation */ { long sum = nil; if (numb[x] && pname[x] == nil) return add1(nil); /* number zero */ if (atom[x]) return length(pname[x]); while (!atom[x]) { sum = addition(sum,size(car[x]),0); x = cdr[x]; if (!atom[x]) sum = add1(sum); /* blank separator */ } return add1(add1(sum)); /* open & close paren */ }
/* read one square of Turing machine tape */ long read_bit(void) { long x, tape = car[turing_machine_tapes]; if (atom[tape]) return - wrd_out_of_data; /* tape finished ! */ x = car[tape]; car[turing_machine_tapes] = cdr[tape]; if (!numb[x] || pname[x] != nil) return wrd_one; return wrd_zero; }
void write_lst(long x) /* convert s-exp to list of bits */ { if (numb[x] && pname[x] == nil) {write_chr('0'); return;} /* null list of digits means zero */ if (atom[x]) {write_atm(pname[x]); return;} write_chr('('); while (!atom[x]) { write_lst(car[x]); x = cdr[x]; if (!atom[x]) write_chr(' '); } write_chr(')'); }
void write_atm(long x) /* convert atom to 8 bits per character */ { if (x == nil) return; write_atm(cdr[x]); /* output characters in reverse order */ write_chr(car[x]); }
/* read one character from Turing machine tape */ long read_char(void) { long c, b, i = 8; c = 0; while (i-- > 0) { b = read_bit(); if (b < 0) return b; /* error? */ if (pname[b] != nil) b = 1; else b = 0; c = c + c + b; } return c; }
long read_record(void) /* read record from Turing machine tape */ { /* fill buffer2 with all the words in an input record */ long character, word, line, end_of_line, end_of_buffer; line = end_of_line = cons(nil,nil); /* stub */ do { /* read characters until '\n' */ character = read_char(); if (character < 0) return character; /* error? */; /* add character to end of line */ end_of_line = cdr[end_of_line] = cons(character,nil); } /* end of read characters until '\n' */ while (character != '\n'); line = cdr[line]; /* remove stub at beginning of line */ /* break line into words at ( ) characters */ buffer2 = end_of_buffer = cons(nil,nil); /* stub */ word = nil; while ( line != nil ) { character = car[line]; line = cdr[line]; /* look for characters that break words */ if ( character == ' ' || character == '\n' || character == '(' || character == ')' ) { /* add nonempty word to end of buffer */ if ( word != nil ) end_of_buffer = cdr[end_of_buffer] = cons(word,nil); word = nil; /* add break character to end of buffer */ if ( character != ' ' && character != '\n' ) end_of_buffer = cdr[end_of_buffer] = cons(cons(character,nil),nil); } else { /* add character to word (in reverse order) */ /* keep only nonblank printable ASCII codes */ if (32 < character && character < 127) word = cons(character,word); } } /* end while ( line != nil ) */ buffer2 = cdr[buffer2]; /* remove stub at beginning of buffer */ return 0; /* indicates no error */ }
long read_word(void) { /* read word from Turing machine tape */ /* buffer2 has all the words in the input record */ long word; /* (if buffer empty, returns as many right parens as needed) */ if (buffer2 == nil) return right_paren; /* if buffer nonempty, return first word in buffer */ word = car[buffer2]; buffer2 = cdr[buffer2]; /* first check if word consists only of digits */ if (only_digits(word)) word = mk_numb(remove_leading_zeros(word)); /* also makes 00099 into 99 and 0000 into null */ else word = lookup_word(word); /* look up word in object list */ /* also does mk_atom and adds it to object list if necessary */ return word; }
long read_expr(long rparenokay) /* read s-exp from Turing machine tape */ { long w = read_word(), first, last, next; if (w < 0) return w; /* error? */ if (w == right_paren) if (rparenokay) return w; else return nil; if (w == left_paren) { /* explicit list */ first = last = cons(nil,nil); while ((next = read_expr(1)) != right_paren) { if (next < 0) return next; /* error? */ last = cdr[last] = cons(next,nil); } return cdr[first]; } /* end if (w == left_paren) */ return w; /* normal atom */ }
Name:
Anonymous2015-03-17 7:17
>>1 Did you just publish your own lisp interpreter on /prog/?
Name:
Anonymous2015-03-17 7:39
$ ./lisp LISP Interpreter Run
4 4
expression 4 value 4
(+ 3 4) (+ 3 4)
expression ((+ 3 4)) value 7
End of LISP Run
Elapsed time is 13 seconds. That doesn't seem right.