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

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.35 by root, Sun Nov 29 00:02:21 2015 UTC vs.
Revision 1.39 by root, Sun Nov 29 14:22:30 2015 UTC

 }
 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)
 {
     }
   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);
         }
       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));
           if (index >= veclength (car (args)) && USE_ERROR_CHECKING)
               s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS)));
             case TOK_DOTATOM:
               SCHEME_V->strbuff[0] = '.';
               s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ 1, DELIMITERS)));
+            case TOK_STRATOM:
+              x = readstrexp (SCHEME_A_ '|');
+              //TODO: haven't checked whether the garbage collector could interfere
+              s_return (mk_atom (SCHEME_A_ strvalue (x)));
             case TOK_DQUOTE:
               x = readstrexp (SCHEME_A_ '"');
               if (x == S_F)
       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.35 by root, Sun Nov 29 00:02:21 2015 UTC vs. Revision 1.39 by root, Sun Nov 29 14:22:30 2015 UTC

Diff Legend

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.35 by root, Sun Nov 29 00:02:21 2015 UTC vs.
Revision 1.39 by root, Sun Nov 29 14:22:30 2015 UTC