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

Comparing cvsroot/microscheme/scheme.c (file contents):
Revision 1.33 by root, Sat Nov 28 10:59:14 2015 UTC vs.
Revision 1.40 by root, Mon Nov 30 05:19:01 2015 UTC

 #include <sys/types.h>
 #include <sys/stat.h>
 #include <fcntl.h>
+#if !USE_ERROR_CHECKING
+# define NDEBUG
+#endif
+#include <assert.h>
+#include <stdlib.h>
 #include <string.h>
-#include <stdlib.h>
 #include <limits.h>
 #include <inttypes.h>
 #include <float.h>
 //#include <ctype.h>
+#if '1' != '0' + 1 \
+ || '2' != '0' + 2 || '3' != '0' + 3 || '4' != '0' + 4 || '5' != '0' + 5 \
+ || '6' != '0' + 6 || '7' != '0' + 7 || '8' != '0' + 8 || '9' != '0' + 9 \
+ || 'b' != 'a' + 1 || 'c' != 'a' + 2 || 'd' != 'a' + 3 || 'e' != 'a' + 4 \
+ || 'f' != 'a' + 5
+# error "execution character set digits not consecutive"
+#endif
 enum {
   TOK_EOF,
   TOK_LPAREN,
   TOK_RPAREN,
   TOK_DOT,
   TOK_ATOM,
+  TOK_DOTATOM, /* atom name starting with '.' */
+  TOK_STRATOM, /* atom name enclosed in | */
   TOK_QUOTE,
   TOK_DQUOTE,
   TOK_BQUOTE,
   TOK_COMMA,
   TOK_ATMARK,
   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);
 #endif
 static int file_push (SCHEME_P_ const char *fname);
 static void file_pop (SCHEME_P);
 static int file_interactive (SCHEME_P);
-ecb_inline int is_one_of (char *s, int c);
+ecb_inline int is_one_of (const char *s, int c);
 static int alloc_cellseg (SCHEME_P_ int n);
 ecb_inline pointer get_cell (SCHEME_P_ pointer a, pointer b);
 static void finalize_cell (SCHEME_P_ pointer a);
 static int count_consecutive_cells (pointer x, int needed);
 static pointer find_slot_in_env (SCHEME_P_ pointer env, pointer sym, int all);
 static void mark (pointer a);
 static void gc (SCHEME_P_ pointer a, pointer b);
 static int basic_inchar (port *pt);
 static int inchar (SCHEME_P);
 static void backchar (SCHEME_P_ int c);
-static char *readstr_upto (SCHEME_P_ char *delim);
+static char *readstr_upto (SCHEME_P_ int skip, const char *delim);
-static pointer readstrexp (SCHEME_P);
+static pointer readstrexp (SCHEME_P_ char delim);
 ecb_inline int skipspace (SCHEME_P);
 static int token (SCHEME_P);
 static void printslashstring (SCHEME_P_ char *s, int len);
 static void atom2str (SCHEME_P_ pointer l, int f, char **pp, int *plen);
 static void printatom (SCHEME_P_ pointer l, int f);
   return x;
 }
 /* ========== oblist implementation  ========== */
+static pointer
+generate_symbol (SCHEME_P_ const char *name)
+{
+  pointer x = mk_string (SCHEME_A_ name);
+  setimmutable (x);
+  set_typeflag (x, T_SYMBOL | T_ATOM);
+  return x;
+}
 #ifndef USE_OBJECT_LIST
 static int
 hash_fn (const char *key, int table_size)
 {
 /* returns the new symbol */
 static pointer
 oblist_add_by_name (SCHEME_P_ const char *name)
 {
-  int location;
+  pointer x = generate_symbol (SCHEME_A_ name);
-  pointer x = immutable_cons (mk_string (SCHEME_A_ name), NIL);
-  set_typeflag (x, T_SYMBOL);
-  setimmutable (car (x));
-  location = hash_fn (name, veclength (SCHEME_V->oblist));
+  int location = hash_fn (name, veclength (SCHEME_V->oblist));
   vector_set (SCHEME_V->oblist, location, immutable_cons (x, vector_get (SCHEME_V->oblist, location)));
   return x;
 }
 ecb_inline pointer
       SCHEME_V->no_memory = 1;
       return SCHEME_V->strbuff;
     }
   if (str)
-    {
+    memcpy (q, str , len_str); /* caller must ensure that *str has length len_str */
-      int l = strlen (str);
-      if (l > len_str)
-        l = len_str;
-      memcpy (q, str, l);
-      q[l] = 0;
-    }
   else
-    {
-      memset (q, fill, len_str);
+    memset (q, fill, len_str);
-      q[len_str] = 0;
+  q[len_str] = 0;
-    }
   return q;
 }
 INTERFACE pointer
   pointer x = get_cell (SCHEME_A_ NIL, NIL);
   set_typeflag (x, T_STRING | T_ATOM);
   strvalue (x) = store_string (SCHEME_A_ len, str, 0);
   strlength (x) = len;
   return x;
 }
 INTERFACE pointer
 mk_string (SCHEME_P_ const char *str)
 {
   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)
 {
 INTERFACE pointer
 gensym (SCHEME_P)
 {
   pointer x;
-  for (; SCHEME_V->gensym_cnt < LONG_MAX; SCHEME_V->gensym_cnt++)
-    {
-      char name[40] = "gensym-";
+  char name[40] = "gensym-";
-      xnum (name + 7, SCHEME_V->gensym_cnt);
+  xnum (name + 7, SCHEME_V->gensym_cnt);
-      /* first check oblist */
+  return generate_symbol (SCHEME_A_ name);
-      x = oblist_find_by_name (SCHEME_A_ name);
-      if (x == NIL)
-        {
-          x = oblist_add_by_name (SCHEME_A_ name);
-          return x;
-        }
-    }
-  return NIL;
 }
 /* make symbol or number atom from string */
 static pointer
 mk_atom (SCHEME_P_ char *q)
 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))
 #endif
 }
 /* read characters up to delimiter, but cater to character constants */
 static char *
-readstr_upto (SCHEME_P_ char *delim)
+readstr_upto (SCHEME_P_ int skip, const char *delim)
 {
-  char *p = SCHEME_V->strbuff;
+  char *p = SCHEME_V->strbuff + skip;
   while ((p - SCHEME_V->strbuff < sizeof (SCHEME_V->strbuff)) && !is_one_of (delim, (*p++ = inchar (SCHEME_A))));
   if (p == SCHEME_V->strbuff + 2 && p[-2] == '\\')
     *p = 0;
   return SCHEME_V->strbuff;
 }
 /* read string expression "xxx...xxx" */
 static pointer
-readstrexp (SCHEME_P)
+readstrexp (SCHEME_P_ char delim)
 {
   char *p = SCHEME_V->strbuff;
   int c;
   int c1 = 0;
-  enum
-  { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state = st_ok;
+  enum { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state = st_ok;
   for (;;)
     {
       c = inchar (SCHEME_A);
         return S_F;
       switch (state)
         {
           case st_ok:
-            switch (c)
+            if (ecb_expect_false (c == delim))
-              {
-                case '\\':
-                  state = st_bsl;
-                  break;
-                case '"':
-                  *p = 0;
-                  return mk_counted_string (SCHEME_A_ SCHEME_V->strbuff, p - SCHEME_V->strbuff);
+              return mk_counted_string (SCHEME_A_ SCHEME_V->strbuff, p - SCHEME_V->strbuff);
-                default:
+            if (ecb_expect_false (c == '\\'))
+              state = st_bsl;
+            else
-                  *p++ = c;
+              *p++ = c;
-                  break;
-              }
             break;
           case st_bsl:
             switch (c)
                 case 'r':
                   *p++ = '\r';
                   state = st_ok;
                   break;
-                case '"':
-                  *p++ = '"';
-                  state = st_ok;
-                  break;
                 default:
                   *p++ = c;
                   state = st_ok;
                   break;
               }
             break;
           case st_x1:
           case st_x2:
-            c = toupper (c);
+            c = tolower (c);
-            if (c >= '0' && c <= 'F')
+            if (c >= '0' && c <= '9')
-              {
-                if (c <= '9')
-                  c1 = (c1 << 4) + c - '0';
+              c1 = (c1 << 4) + c - '0';
-                else
+            else if (c >= 'a' && c <= 'f')
-                  c1 = (c1 << 4) + c - 'A' + 10;
+              c1 = (c1 << 4) + c - 'a' + 10;
-                if (state == st_x1)
-                  state = st_x2;
-                else
-                  {
-                    *p++ = c1;
-                    state = st_ok;
-                  }
-              }
             else
               return S_F;
+            if (state == st_x1)
+              state = st_x2;
+            else
+              {
+                *p++ = c1;
+                state = st_ok;
+              }
             break;
           case st_oct1:
           case st_oct2:
                 backchar (SCHEME_A_ c);
                 state = st_ok;
               }
             else
               {
-                if (state == st_oct2 && c1 >= 32)
+                if (state == st_oct2 && c1 >= ' ')
                   return S_F;
                 c1 = (c1 << 3) + (c - '0');
                 if (state == st_oct1)
                     state = st_ok;
                   }
               }
             break;
         }
     }
 }
 /* check c is in chars */
 ecb_inline int
-is_one_of (char *s, int c)
+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
           {
-            //TODO: ungetc twice in a row is not supported in C
             backchar (SCHEME_A_ c);
-            backchar (SCHEME_A_ '.');
-            return TOK_ATOM;
+            return TOK_DOTATOM;
           }
+      case '|':
+        return TOK_STRATOM;
       case '\'':
         return TOK_QUOTE;
       case ';':
     }
   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_save (SCHEME_A_ OP_RDUQTSP, NIL, NIL);
               SCHEME_V->tok = token (SCHEME_A);
               s_goto (OP_RDSEXPR);
             case TOK_ATOM:
-              s_return (mk_atom (SCHEME_A_ readstr_upto (SCHEME_A_ DELIMITERS)));
+              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);
+              x = readstrexp (SCHEME_A_ '"');
               if (x == S_F)
                 Error_0 ("Error reading string");
               setimmutable (x);
                     s_goto (OP_EVAL);
                   }
               }
             case TOK_SHARP_CONST:
-              if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ DELIMITERS))) == NIL)
+              if ((x = mk_sharp_const (SCHEME_A_ readstr_upto (SCHEME_A_ 0, DELIMITERS))) == NIL)
                 Error_0 ("undefined sharp expression");
               else
                 s_return (x);
             default:
       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.33 by root, Sat Nov 28 10:59:14 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.33 by root, Sat Nov 28 10:59:14 2015 UTC vs.
Revision 1.40 by root, Mon Nov 30 05:19:01 2015 UTC