[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.38 by root, Sun Nov 29 13:47:15 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);
 }
           }
         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_LET2:            /* let */
         new_frame_in_env (SCHEME_A_ SCHEME_V->envir);
         for (x = is_symbol (car (SCHEME_V->code)) ? cadr (SCHEME_V->code) : car (SCHEME_V->code), y = args;
              y != NIL; x = cdr (x), y = cdr (y))
+          { if (is_pair(caar(x))){debug(SCHEME_A_ 0, SCHEME_V->code);};//D
+            pointer z = caar (x);
+            if(is_pair(z)) z = car(z);//D
+            new_slot_in_env (SCHEME_A_ z, car (y));
+          }
-          new_slot_in_env (SCHEME_A_ caar (x), car (y));
+          //new_slot_in_env (SCHEME_A_ caar (x), car (y));
         if (is_symbol (car (SCHEME_V->code)))   /* named let */
           {
             for (x = cadr (SCHEME_V->code), args = NIL; x != NIL; x = cdr (x))
               {
         }
       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.38 by root, Sun Nov 29 13:47:15 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.38 by root, Sun Nov 29 13:47:15 2015 UTC