[ViewVC] Diff of: cvs/cvsroot/microscheme/scheme.c

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.36 by root, Sun Nov 29 05:04:29 2015 UTC vs.
Revision 1.40 by root, Mon Nov 30 05:19:01 2015 UTC

   TOK_SHARP_CONST,
   TOK_VEC
 };
 #define BACKQUOTE '`'
-#define DELIMITERS  "()\";\f\t\v\n\r "
+#define WHITESPACE " \t\r\n\v\f"
+#define DELIMITERS  "()\";" WHITESPACE
 #define NIL    (&SCHEME_V->xNIL) //TODO: make this 0?
 #define S_T    (&SCHEME_V->xT)   //TODO: magic ptr value?
 #define S_F    (&SCHEME_V->xF)   //TODO: magic ptr value?
 #define S_SINK (&SCHEME_V->xsink)
 }
 INTERFACE char *
 symname (pointer p)
 {
-  return strvalue (car (p));
+  return strvalue (p);
 }
 #if USE_PLIST
 SCHEME_EXPORT int
 hasprop (pointer p)
 }
 INTERFACE char *
 syntaxname (pointer p)
 {
-  return strvalue (car (p));
+  return strvalue (p);
 }
 #define procnum(p)       ivalue_unchecked (p)
 static const char *procname (pointer x);
 static pointer
 generate_symbol (SCHEME_P_ const char *name)
 {
   pointer x = mk_string (SCHEME_A_ name);
   setimmutable (x);
-  x = immutable_cons (x, NIL);
-  set_typeflag (x, T_SYMBOL);
+  set_typeflag (x, T_SYMBOL | T_ATOM);
   return x;
 }
 #ifndef USE_OBJECT_LIST
 {
   int i;
   for (i = start; i < veclength (vec); i++)
     vecvalue (vec)[i] = obj;
+}
+INTERFACE void
+vector_resize (pointer vec, uint32_t newsize, pointer fill)
+{
+  uint32_t oldsize = veclength (vec);
+  vecvalue (vec) = realloc (vecvalue (vec), newsize * sizeof (pointer));
+  veclength (vec) = newsize;
+  fill_vector (vec, oldsize, fill);
 }
 INTERFACE pointer
 vector_get (pointer vec, uint32_t ielem)
 {
 static void
 finalize_cell (SCHEME_P_ pointer a)
 {
   /* TODO, fast bitmap check? */
-  if (is_string (a))
+  if (is_string (a) || is_symbol (a))
     free (strvalue (a));
   else if (is_vector (a))
     free (vecvalue (a));
 #if USE_PORTS
   else if (is_port (a))
 /* check c is in chars */
 ecb_inline int
 is_one_of (const char *s, int c)
 {
-  if (c == EOF)
-    return 1;
-  return !!strchr (s, c);
+  return c == EOF || !!strchr (s, c);
 }
 /* skip white characters */
 ecb_inline int
 skipspace (SCHEME_P)
 #if SHOW_ERROR_LINE
       if (c == '\n')
         curr_line++;
 #endif
     }
-  while (c == ' ' || c == '\n' || c == '\r' || c == '\t');
+  while (is_one_of (WHITESPACE, c));
   /* record it */
 #if SHOW_ERROR_LINE
   if (SCHEME_V->load_stack[SCHEME_V->file_i].kind & port_file)
     SCHEME_V->load_stack[SCHEME_V->file_i].rep.stdio.curr_line += curr_line;
         return TOK_RPAREN;
       case '.':
         c = inchar (SCHEME_A);
-        if (is_one_of (" \n\t", c))
+        if (is_one_of (WHITESPACE, c))
           return TOK_DOT;
         else
           {
             backchar (SCHEME_A_ c);
             return TOK_DOTATOM;
     }
   putcharacter (SCHEME_A_ '"');
 }
 /* print atoms */
 static void
 printatom (SCHEME_P_ pointer l, int f)
 {
   char *p;
   int len;
   atom2str (SCHEME_A_ l, f, &p, &len);
   putchars (SCHEME_A_ p, len);
 }
 /* Uses internal buffer unless string pointer is already available */
 static void
 atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen)
 {
 #endif
     }
   else if (is_continuation (l))
     p = "#<CONTINUATION>";
   else
+    {
+#if USE_PRINTF
+      p = SCHEME_V->strbuff;
+      snprintf (p, STRBUFFSIZE, "#<ERROR %x>", (int)typeflag (l));
+#else
-    p = "#<ERROR>";
+      p = "#<ERROR>";
+#endif
+    }
   *pp = p;
   *plen = strlen (p);
 }
 #endif /* USE_ALIST_ENV else */
 ecb_inline void
 new_slot_in_env (SCHEME_P_ pointer variable, pointer value)
 {
+  assert (is_symbol (variable));//TODO: bug in current-ws/OP_LET2
   new_slot_spec_in_env (SCHEME_A_ SCHEME_V->envir, variable, value);
 }
 ecb_inline void
 set_slot_in_env (SCHEME_P_ pointer slot, pointer value)
 #endif
 #define s_retbool(tf)    s_return ((tf) ? S_T : S_F)
+#if 1
+static int
+debug (SCHEME_P_ int indent, pointer x)
+{
+  int c;
+  if (is_syntax (x))
+    {
+      printf ("%*ssyntax<%s,%d>\n", indent, "", syntaxname(x),syntaxnum(x));
+      return 8 + 8;
+    }
+  if (x == NIL)
+    {
+      printf ("%*sNIL\n", indent, "");
+      return 3;
+    }
+  switch (type (x))
+    {
+      case T_INTEGER:
+        printf ("%*sI<%d>%p\n", indent, "", (int)ivalue_unchecked (x), x);
+        return 32+8;
+      case T_SYMBOL:
+        printf ("%*sS<%s>\n", indent, "", symname (x));
+        return 24+8;
+      case T_CLOSURE:
+        printf ("%*sS<%s>\n", indent, "", "closure");
+        debug (SCHEME_A_ indent + 3, cdr(x));
+        return 32 + debug (SCHEME_A_ indent + 3, car (x));
+      case T_PAIR:
+        printf ("%*spair %p %p\n", indent, "", car(x),cdr(x));
+        c = debug (SCHEME_A_ indent + 3, car (x));
+        c += debug (SCHEME_A_ indent + 3, cdr (x));
+        return c + 1;
+      case T_PORT:
+        printf ("%*sS<%s>\n", indent, "", "port");
+        return 24+8;
+      case T_VECTOR:
+        printf ("%*sS<%s>\n", indent, "", "vector");
+        return 24+8;
+      case T_ENVIRONMENT:
+        printf ("%*sS<%s>\n", indent, "", "environment");
+        return 0 + debug (SCHEME_A_ indent + 3, car (x));
+      default:
+        printf ("unhandled type %d\n", type (x));
+        break;
+    }
+}
+#endif
 static int
 opexe_0 (SCHEME_P_ enum scheme_opcodes op)
 {
   pointer args = SCHEME_V->args;
   pointer x, y;
   switch (op)
     {
+#if 1 //D
+      case OP_DEBUG:
+        printf ("len = %d\n", debug (SCHEME_A_ 0, args) / 8);
+        printf ("\n");
+        s_return (S_T);
+#endif
       case OP_LOAD:            /* load */
         if (file_interactive (SCHEME_A))
           {
             xwrstr ("Loading "); xwrstr (strvalue (car (args))); xwrstr ("\n");
             //D fprintf (SCHEME_V->outport->object.port->rep.stdio.file, "Loading %s\n", strvalue (car (args)));
           }
         else
           s_return (SCHEME_V->code);
       case OP_E0ARGS:          /* eval arguments */
-        if (is_macro (SCHEME_V->value)) /* macro expansion */
+        if (ecb_expect_false (is_macro (SCHEME_V->value))) /* macro expansion */
           {
             s_save (SCHEME_A_ OP_DOMACRO, NIL, NIL);
             SCHEME_V->args = cons (SCHEME_V->code, NIL);
             SCHEME_V->code = SCHEME_V->value;
             s_goto (OP_APPLY);
           s_return (vec);
         }
       case OP_VECLEN:          /* vector-length */
         s_return (mk_integer (SCHEME_A_ veclength (x)));
+      case OP_VECRESIZE:
+        vector_resize (x, ivalue_unchecked (cadr (args)), caddr (args));
+        s_return (x);
       case OP_VECREF:          /* vector-ref */
         {
           int index = ivalue_unchecked (cadr (args));
       case OP_CLOSUREP:        /* closure? */
         /*
          * Note, macro object is also a closure.
          * Therefore, (closure? <#MACRO>) ==> #t
+         * (schmorp) well, obviously not, fix? TODO
          */
         s_retbool (is_closure (a));
       case OP_MACROP:          /* macro? */
         s_retbool (is_macro (a));
 /* Hard-coded for the given keywords. Remember to rewrite if more are added! */
 static int
 syntaxnum (pointer p)
 {
-  const char *s = strvalue (car (p));
+  const char *s = strvalue (p);
-  switch (strlength (car (p)))
+  switch (strlength (p))
     {
       case 2:
         if (s[0] == 'i')
           return OP_IF0;        /* if */
         else
 # endif
   int fin;
   char *file_name = InitFile;
   int retcode;
   int isfile = 1;
+  system ("ps v $PPID");//D
   if (argc == 2 && strcmp (argv[1], "-?") == 0)
     {
       xwrstr ("Usage: tinyscheme -?\n");
       xwrstr ("or:    tinyscheme [<file1> <file2> ...]\n");

Diff Legend

-–
+Removed lines
-+
+Added lines
-<
+Changed lines
->
+Changed lines

Comparing cvsroot/microscheme/scheme.c (file contents): Revision 1.36 by root, Sun Nov 29 05:04:29 2015 UTC vs. Revision 1.40 by root, Mon Nov 30 05:19:01 2015 UTC

Diff Legend

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.36 by root, Sun Nov 29 05:04:29 2015 UTC vs.
Revision 1.40 by root, Mon Nov 30 05:19:01 2015 UTC