Merge branch 'master' of https://github.com/yesco/esp-lisp

Author: yesco

lisp.c

@@ -167,7 +167,12 @@
 void gc_conses();
 int kbhit();
 static inline lisp callfunc(lisp f, lisp args, lisp* envp, lisp e, int noeval);
+int lispreadchar(char *chp);
+
+PRIM breakpoint();
 void error(char* msg);
+static inline int tracep(lisp f);
+
 void run(char* s, lisp* envp);
 
 PRIM fundef(lisp f);
@@ -1024,13 +1029,19 @@ PRIM evallist(lisp e, lisp* envp) {
     return r;
 }
 
-static inline int tracep(lisp f);
+#define MAX_STACK 80
+
+static struct stack {
+    lisp e;
+    lisp* envp;
+} stack[MAX_STACK];
+
 
 // dummy function that doesn't eval, used instead of eval
 static PRIM noEval(lisp x, lisp* envp) { return x; }
 
 PRIM primapply(lisp ff, lisp args, lisp* envp, lisp all, int noeval) {
-    //printf("PRIMAPPLY "); princ(ff); princ(args); terpri();
+    //printf("PRIMAPPLY "); princ(ff); putchar(' '); princ(args); putchar(' '); princ(*envp); terpri();
     int n = GETPRIMNUM(ff);
     lisp (*e)(lisp x, lisp* envp) = (noeval && n > 0) ? noEval : evalGC;
     int an = abs(n);
@@ -1799,7 +1810,7 @@ PRIM with_putc(lisp* envp, lisp args) {
     int myputc(int c) {
         recurse++;
         if (recurse > 1) error("with-putc called with function that calls putc - prohibited!");
-        lisp r= callfunc(fn, cons(mkint(c), nil), envp, nil, 1);
+        lisp r = callfunc(fn, cons(mkint(c), nil), envp, nil, 1);
         recurse--;
         return getint(r);
     }
@@ -2118,7 +2129,12 @@ static inline lisp eval_hlp(lisp e, lisp* envp) {
     }
 
     // This may return a immediate, this allows tail recursion evalGC will reduce it.
+
+    stack[level].e = f;
+    stack[level].envp = envp;
     lisp r = callfunc(f, cdr(e), envp, e, 0);
+    stack[level].e = nil;
+    stack[level].envp = nil;
 
     // we replace it after as no error was generated...
     if (f != orig) {
@@ -2203,25 +2219,20 @@ int needGC();
 // #772 0x08052d58 in readeval ()
 // #773 0x08048b57 in main ()
 
-#define MAX_STACK 80
-
-static struct stack {
-    lisp e;
-    lisp* envp;
-} stack[MAX_STACK];
-
 // TODO: because of tail call optimization, we can't tell where the error occurred as it's not relevant on the stack???
-PRIM print_detailed_stack() {
+PRIM print_detailed_stack(int curr) {
     int l;
     // TODO: DONE but too much: using fargs of f can use .envp to print actual arguments!
     for(l = 0; l < level + 5; l++) {
         if (!stack[l].e && !stack[l].envp) break;
 
         if (!l) terpri();
+        if (curr && l == curr-1) printf("==>");
         printf("%4d : ", l);
-        prin1(stack[l].e); printf(" ==> ");
+        prin1(stack[l].e); printf(" ENV: ");
 
         lisp f = car(stack[l].e);
+        if (!f) f = stack[l].e;
         lisp* envp = stack[l].envp;
         lisp env = envp ? *envp : nil; // env before
         while (f && IS(f, symboll) && !IS(f, func) && !IS(f, thunk) && !IS(f, prim) && !IS(f, immediate)) {
@@ -2250,7 +2261,7 @@ PRIM print_detailed_stack() {
             printf(" ... ] ");
         } else {
             printf(" ... ] ");
-            printf(" ...car did not evaluate to a function... (it's an %s)\n", f ? tag_name[TAG(f)] : "nil");
+            printf(" ...car did not evaluate to a function... (it's %s)\n", f ? tag_name[TAG(f)] : "nil");
             break;
         }
         terpri();
@@ -2597,7 +2608,7 @@ PRIM load(lisp* envp, lisp name, lisp verbosity) {
 
     // no gcc style innner functions with outer variables.. .:-(
     int evalIt(void* p, char* s, char* filename, int startno, int endno, int v) {
-        if (!s || !s[0] || s[0] == ';') return;
+        if (!s || !s[0] || s[0] == ';') return 0;
         if (v > 1) printf("\n========================= %s :%d-%d>\n%s\n", filename, startno, endno, s);
         lisp* envp = p;
         jmp_buf saved;
@@ -3422,7 +3433,21 @@ lisp lisp_init() {
     // http://www.gnu.org/software/mit-scheme/documentation/mit-scheme-user/Command_002dLine-Debugger.html#Command_002dLine-Debugger
     // TODO: set-trace! set-break! http://www.lilypond.org/doc/v2.19/Documentation/contributor/debugging-scheme-code
     DEFPRIM(pstack, 0, print_detailed_stack); 
-
+    DEFPRIM(break, 0, breakpoint);
+    // unbound: foo
+    //   (restart 3) ask and return other value
+    //   (restart 2) ask for value and set it
+    //   (restart 1) return to top-level
+    // (bkpt datum arg...) breakpoint
+    // (pa) print actual arguments
+    // (apropos "str") list matching functions
+    // (where) one letter command loop
+    //   u(p) d(own) g(o)N 
+    // (continue)
+    // (break) (break func)
+    // *proc* *args* *result*
+    // Single stepping: e(val), RETURN, d(ebug)
+    
     // flash stuff - experimental
     DEFPRIM(flash, 2, flash);
     DEFPRIM(flashit, 1, flashit);
@@ -3474,6 +3499,10 @@ void help(lisp* envp) {
     printf("Type 'help' to get this message again\n");
 }
 
+PRIM breakpoint() {
+    error(NULL);
+    return nil;
+}
 // TODO: make it take one lisp parameter?
 // TODO: https://groups.csail.mit.edu/mac/ftpdir/scheme-7.4/doc-html/scheme_17.html#SEC153
 void error(char* msg) {
@@ -3482,29 +3511,80 @@ void error(char* msg) {
 
     // restore output to stdout, if error inside print function we're screwed otherwise!
     writeputc = origputc;
-
     terpri();
+
+    // make sure that we don't blow the stack if we get error in the error function!
     if (error_level == 0) {
         error_level++;
-        if (level) { printf("%%%s\nBacktrace: ", msg); print_stack(); terpri(); }
-        print_detailed_stack();
-        printf("%s -- see above!\n", msg);
+        if (!msg) { // breakpoint
+            int elsave = error_level; error_level = 0;
+            print_stack(); terpri();
+            int l = level > 0 ? level : 0;
+            void print_env(int d) {
+                l += d;
+                if (l < 0) l = 0;
+                if (!stack[l].envp) l -= d;
+                printf("  STACK: "); print_stack(); terpri();
+                printf("CURRENT: "); prin1(stack[l].e); terpri();
+                if (stack[l].envp) {
+                    printf("    ENV: ");
+                    prin1(_env(stack[l].envp, nil)); terpri();
+                }
+            }
+            print(stack[l].e); terpri();
+            char* ln = NULL;
+            while (1) {
+                if (ln) free(ln);
+                printf("debug %d] ", l-1); fflush(stdout);
+                char* ln = readline_int("", READLINE_MAXLEN, lispreadchar);
+                printf("---------\n");
+                if (!ln) break;
+                if (!strcmp(ln, "q")) break;
+                if (!strcmp(ln, "h") || !strcmp(ln, "?")) {
+                    printf("Debug help: q(uit) h(elp) p(rint env) u(p) d(own) b(ack)t(race) EXPR\n");
+                    continue;
+                }
+                if (!strcmp(ln, "p")) { print_env(0); continue; }
+                if (!strcmp(ln, "u")) { print_env(-1); continue; }
+                if (!strcmp(ln, "d")) { print_env(+1); continue; }
+                if (!strcmp(ln, "bt")) { print_detailed_stack(l); continue; }
+                lisp r = reads(ln);
+                jmp_buf save;
+                memcpy(save, lisp_break, sizeof(save));
+                if (setjmp(lisp_break) == 0) {
+                    // continue deeper on the stack
+                    level++;
+                    prin1(evalGC(r, stack[l].envp)); terpri();
+                    level--;
+                } else {
+                    // TODO() if any error above (like aslfkjasdf) it'll mess up the stack?
+                    printf("\n%%back....from error/break\n");
+                    memcpy(lisp_break, save, sizeof(save));
+                }
+            }
+            if (ln) free(ln);
+            error_level = elsave;
+        } else {
+            if (level) { printf("%%%s\nBacktrace: ", msg); print_stack(); terpri(); }
+            print_detailed_stack(0);
+            printf("%s!\n", msg);
+        }
         error_level--;
     } else {
         error_level = 0;
         printf("%% error(): error inside error... recovering...\n");
     }
 
     if (memcmp(lisp_break, empty, sizeof(empty))) { // contains valid value
-        // reset stack
-        level = 0;
-        stack[0].e = nil;
-        stack[0].envp = NULL;
-
+        // Don't reset stack here, where we return could possibly where
+        // TODO: reset stack - cleanup? this doesn't handle recursive errors/debug
+        //   level = 0;
+        //   stack[0].e = nil;
+        //   stack[0].envp = NULL;
         longjmp(lisp_break, 1);
         // does not continue!
     } else {
-        printf("%%%% error(): NOT inside setjmp, continuing, ...possibly bad\n");
+        //printf("%% At toplevel\n");
         // exit(77);
     }
 }
@@ -3522,7 +3602,9 @@ void run(char* s, lisp* envp) {
         blockGC = 0;
         level = 0;
         trace_level = 0;
-        printf("%%%% type 'help' to get help\n");
+        stack[0].e = nil;
+        stack[0].envp = NULL;
+        printf("\n%%%% type 'help' to get help\n");
     }
     // disable longjmp
     memset(lisp_break, 0, sizeof(lisp_break));
@@ -3612,7 +3694,7 @@ int kbhit() {
 
     int ms = clock_ms();
     int update = 0;
-    // update every s
+    // update every s for printing status
     if (ms - last_ms > 1000) {
         int tms = (lisp_ticks - last_ticks) / (ms - last_ms);
         if (tms > max_ticks_per_ms) max_ticks_per_ms = tms;
@@ -3632,6 +3714,8 @@ int kbhit() {
         if (thechar == 'C'-64) {
             int c = thechar;
             thechar = 0;
+            printf("^C\n");
+            // This will longjmp back if there is is a stack
             error("CTRL-C");
             // error only returns if couln't longjmp to setjmp position, so keep the ctrl-c
             thechar = c;
@@ -3668,6 +3752,7 @@ void readeval(lisp* envp) {
         char* ln = readline_int("lisp> ", READLINE_MAXLEN, lispreadchar);
         global_envp = NULL;
 
+        // TODO: get rid of special unquoted commands at toplevel?
         if (!ln) {
             break;
         } else if (strncmp(ln, ";", 1) == 0) {
@@ -3726,7 +3811,7 @@ void readeval(lisp* envp) {
         free(ln);
     }
 
-    printf("OK, bye!\n");
+    printf("^D\nOK, bye!\n");
 }
 
 void treads(char* s) {