Patch Tuesday - E

builtin.c

@@ -70,6 +70,7 @@
 #include "./src/file.c"
 #include "./src/filetime.c"
 #include "./src/filter.c"
+#include "./src/finclude.c"
 #include "./src/first.c"
 #include "./src/float.c"
 #include "./src/floor.c"
@@ -93,7 +94,6 @@
 #include "./src/genrecaux.c"
 #include "./src/geql.c"
 #include "./src/get.c"
-#include "./src/getch.c"
 #include "./src/getenv.c"
 #include "./src/gmtime.c"
 #include "./src/greater.c"
@@ -215,6 +215,7 @@
 #include "./src/unary2.c"
 #include "./src/unary3.c"
 #include "./src/unary4.c"
+#include "./src/unassign.c"
 #include "./src/uncons.c"
 #include "./src/undeferror.c"
 #include "./src/undefs.c"

builtin.h

@@ -70,6 +70,7 @@ void fgets_(pEnv env);
 void file_(pEnv env);
 void filetime_(pEnv env);
 void filter_(pEnv env);
+void finclude_(pEnv env);
 void first_(pEnv env);
 void float_(pEnv env);
 void floor_(pEnv env);
@@ -93,7 +94,6 @@ void genrec_(pEnv env);
 void genrecaux_(pEnv env);
 void geql_(pEnv env);
 void get_(pEnv env);
-void getch_(pEnv env);
 void getenv_(pEnv env);
 void gmtime_(pEnv env);
 void greater_(pEnv env);
@@ -215,6 +215,7 @@ void unary_(pEnv env);
 void unary2_(pEnv env);
 void unary3_(pEnv env);
 void unary4_(pEnv env);
+void unassign_(pEnv env);
 void uncons_(pEnv env);
 void undeferror_(pEnv env);
 void undefs_(pEnv env);

factor.c

@@ -1,8 +1,8 @@
 /* FILE: factor.c */
 /*
  *  module  : factor.c
- *  version : 1.30
- *  date    : 03/23/24
+ *  version : 1.31
+ *  date    : 04/19/24
  */
 #include "globals.h"
 
@@ -257,9 +257,11 @@ void writefactor(pEnv env, Index n, FILE *fp)
     case FLOAT_:
 	sprintf(buf, "%g", nodevalue(n).dbl);	/* exponent character is e */
 	if ((ptr = strchr(buf, '.')) == 0) {	/* locate decimal point */
-	    if ((ptr = strchr(buf, 'e')) == 0)  /* locate start of exponent */
-		strcat(buf, ".0");		/* add decimal point and 0 */
-	    else {
+	    if ((ptr = strchr(buf, 'e')) == 0) {/* locate start of exponent */
+		i = buf[strlen(buf) - 1];
+		if (isdigit(i))			/* check digit present */
+		    strcat(buf, ".0");		/* add decimal point and 0 */
+	    } else {
 		strcpy(tmp, ptr);		/* save exponent */
 		sprintf(ptr, ".0%s", tmp);	/* insert decimal point + 0 */
 	    }

globals.h

@@ -1,8 +1,8 @@
 /* FILE: globals.h */
 /*
  *  module  : globals.h
- *  version : 1.95
- *  date    : 04/12/24
+ *  version : 1.96
+ *  date    : 05/02/24
  */
 #ifndef GLOBALS_H
 #define GLOBALS_H
@@ -161,6 +161,7 @@ KHASH_MAP_INIT_STR(Symtab, int)
 KHASH_MAP_INIT_INT64(Funtab, int)
 
 typedef struct Env {
+    jmp_buf finclude;		/* return point in finclude */
     double maxnodes;
     double nodes;		/* statistics */
     double avail;
@@ -184,10 +185,9 @@ typedef struct Env {
 #ifdef NOBDW
     clock_t gc_clock;
     vector(Node) *memory;	/* dynamic memory */
-    Index prog, stck, conts, dump, dump1, dump2, dump3, dump4, dump5;
-#else
-    Node *prog, *stck;
+    Index conts, dump, dump1, dump2, dump3, dump4, dump5;
 #endif
+    Index prog, stck;
     int g_argc;			/* command line */
     int hide_stack[DISPLAYMAX];
     struct {
@@ -206,6 +206,7 @@ typedef struct Env {
     unsigned char ignore;
     unsigned char overwrite;
     unsigned char printing;
+    unsigned char finclude_busy;
 } Env;
 
 /* GOOD REFS:

main.c

@@ -1,8 +1,8 @@
 /* FILE: main.c */
 /*
  *  module  : main.c
- *  version : 1.95
- *  date    : 04/11/24
+ *  version : 1.96
+ *  date    : 04/19/24
  */
 
 /*
@@ -138,6 +138,7 @@ static void dump(pEnv env);
  */
 void abortexecution_(int num)
 {
+    fflush(stdin);
     longjmp(begin, num);
 }
 

optable.c

@@ -1,7 +1,7 @@
 /*
  *  module  : optable.c
- *  version : 1.3
- *  date    : 04/11/24
+ *  version : 1.4
+ *  date    : 04/29/24
  */
 #include "globals.h"
 
@@ -95,6 +95,9 @@
 #define INTEGER(NAME)							\
     if (nodetype(env->stck) != INTEGER_)				\
     execerror("integer", NAME)
+#define POSITIVEINTEGER(NAME)						\
+    if (nodetype(env->stck) != INTEGER_ || nodevalue(env->stck).num < 0)\
+    execerror("non-negative integer", NAME)
 #define INTEGER2(NAME)							\
     if (nodetype(nextnode1(env->stck)) != INTEGER_)			\
     execerror("integer as second parameter", NAME)
@@ -200,6 +203,7 @@
 #define STRING(NAME)
 #define STRING2(NAME)
 #define INTEGER(NAME)
+#define POSITIVEINTEGER(NAME)
 #define INTEGER2(NAME)
 #define CHARACTER(NAME)
 #define INTEGERS2(NAME)

prims.sh

@@ -1,7 +1,7 @@
 #
 #   module  : prims.sh
-#   version : 1.4
-#   date    : 10/26/23
+#   version : 1.6
+#   date    : 05/01/24
 #
 #   Generate builtin.c and builtin.h
 #   The directory needs to be given as parameter.
@@ -14,7 +14,7 @@ then
   echo creating builtin.c and builtin.h
   todo=1
 else
-  diff prims.tmp $1/builtin.c
+  diff $1/builtin.c prims.tmp
   if [ $? -eq 0 ]
   then
     echo builtin.c and builtin.h are up-to-date
@@ -29,5 +29,5 @@ then
   rm -f $1/builtin.c $1/builtin.h
   mv prims.tmp $1/builtin.c
   sed 's/.*\//void /;s/\..*/_(pEnv env);/' <$1/builtin.c >$1/builtin.h
-  touch $1/interp.c
+  touch $1/optable.c
 fi

scan.c

@@ -1,7 +1,7 @@
 /*
     module  : scan.c
-    version : 1.67
-    date    : 03/23/24
+    version : 1.68
+    date    : 05/02/24
 */
 #include "globals.h"
 
@@ -54,14 +54,14 @@ int getch(pEnv env)
     int ch;
 
 again:
-    if (vec_size(env->pushback)) {
-	ch = vec_pop(env->pushback);
-	return ch;
-    }
+    if (vec_size(env->pushback))
+	return vec_pop(env->pushback);
     if ((ch = fgetc(srcfile)) == EOF) {
 	if (!ilevel)
 	    abortexecution_(ABORT_QUIT);
 	fclose(srcfile);
+	if (env->finclude_busy)
+	    longjmp(env->finclude, 1);	/* back to finclude */
 	srcfile = infile[--ilevel].fp;
 	linenum = infile[ilevel].line;
 	filenam = infile[ilevel].name;

src/finclude.c

@@ -0,0 +1,28 @@
+/*
+    module  : finclude.c
+    version : 1.12
+    date    : 05/02/24
+*/
+#ifndef FINCLUDE_C
+#define FINCLUDE_C
+
+/**
+OK 3160  finclude  :  S  ->  F ...
+[FOREIGN] Reads Joy source code from stream S and pushes it onto stack.
+*/
+void finclude_(pEnv env)
+{
+    char *str;
+
+    ONEPARAM("finclude");
+    STRING("finclude");
+    str = nodevalue(env->stck).str;	/* read file name */
+    POP(env->stck);			/* remove file name from stack */
+    include(env, str);			/* include new file */
+    env->finclude_busy = 1;		/* tell scanner about finclude */
+    if (setjmp(env->finclude))
+	env->finclude_busy = 0;		/* done with finclude */
+    else while (1)
+	get_(env);			/* read all factors from file */
+}
+#endif

src/fput.c

@@ -1,7 +1,7 @@
 /*
     module  : fput.c
-    version : 1.8
-    date    : 03/21/24
+    version : 1.9
+    date    : 04/27/24
 */
 #ifndef FPUT_C
 #define FPUT_C
@@ -21,6 +21,5 @@ void fput_(pEnv env)
     FILE("fput");
     fp = nodevalue(env->stck).fil;
     writefactor(env, node, fp);
-    putc(' ', fp);
 }
 #endif

src/fputch.c

@@ -1,7 +1,7 @@
 /*
     module  : fputch.c
-    version : 1.5
-    date    : 03/21/24
+    version : 1.6
+    date    : 04/29/24
 */
 #ifndef FPUTCH_C
 #define FPUTCH_C
@@ -15,7 +15,7 @@ void fputch_(pEnv env)
     int ch;
 
     TWOPARAMS("fputch");
-    INTEGER("fputch");
+    NUMERICTYPE("fputch");
     ch = nodevalue(env->stck).num;
     POP(env->stck);
     FILE("fputch");

src/quit.c

@@ -1,7 +1,7 @@
 /*
     module  : quit.c
-    version : 1.9
-    date    : 03/21/24
+    version : 1.10
+    date    : 04/29/24
 */
 #ifndef QUIT_C
 #define QUIT_C
@@ -12,6 +12,6 @@ IGNORE_OK  3130  quit  :  ->
 */
 void quit_(pEnv env)
 {
-    exit(EXIT_SUCCESS);
+    abortexecution_(ABORT_QUIT);
 }
 #endif

src/times.c

@@ -1,7 +1,7 @@
 /*
     module  : times.c
-    version : 1.5
-    date    : 03/21/24
+    version : 1.6
+    date    : 04/29/24
 */
 #ifndef TIMES_C
 #define TIMES_C
@@ -19,7 +19,7 @@ void times_(pEnv env)
     ONEQUOTE("times");
     program = env->stck->u.lis;
     POP(env->stck);
-    INTEGER("times");
+    POSITIVEINTEGER("times");
     n = env->stck->u.num;
     POP(env->stck);
     for (i = 0; i < n; i++)

src/unassign.c

@@ -0,0 +1,31 @@
+/*
+    module  : unassign.c
+    version : 1.1
+    date    : 05/06/24
+*/
+#ifndef UNASSIGN_C
+#define UNASSIGN_C
+
+/**
+IGNORE_POP  3235  unassign  :  [N]  ->
+[IMPURE] Sets the body of the name N to uninitialized.
+*/
+void unassign_(pEnv env)
+{
+    Index lis;
+    int index;
+    Entry ent;
+
+    ONEPARAM(__FILE__);			/* name */
+    ONEQUOTE(__FILE__);			/* quotation on top */
+    lis = nodevalue(env->stck).lis;	/* singleton list */
+    CHECKEMPTYLIST(lis, __FILE__);	/* check non-empty list */
+    USERDEF2(lis, __FILE__);		/* check user defined name */
+    index = nodevalue(lis).ent;		/* index user defined name */
+    ent = vec_at(env->symtab, index);	/* symbol table entry */
+    POP(env->stck);			/* bump stack again */
+    ent.is_user = 1;			/* ensure again user defined */
+    ent.u.body = 0;			/* ensure empty body */
+    vec_at(env->symtab, index) = ent;	/* update symbol table */
+}
+#endif

table.c

@@ -214,13 +214,14 @@
 /* 3130 */ { IGNORE_OK, "quit", quit_, "->", "[IMPURE] Exit from Joy.\n" },
 /* 3140 */ { OK, "casting", casting_, "X Y  ->  Z", "[EXT] Z takes the value from X and uses the value from Y as its type.\n" },
 /* 3150 */ { OK, "filetime", filetime_, "F  ->  T", "[FOREIGN] T is the modification time of file F.\n" },
-/* 3160 */ { POSTPONE, "getch", getch_, "->  N", "[IMPURE] Reads a character from input and puts it onto stack.\n" },
+/* 3160 */ { OK, "finclude", finclude_, "S  ->  F ...", "[FOREIGN] Reads Joy source code from stream S and pushes it onto stack.\n" },
 /* 3170 */ { OK, "over", over_, "X Y  ->  X Y X", "[EXT] Pushes an extra copy of the second item X on top of the stack.\n" },
 /* 3180 */ { OK, "pick", pick_, "X Y Z 2  ->  X Y Z X", "[EXT] Pushes an extra copy of nth (e.g. 2) item X on top of the stack.\n" },
 /* 3190 */ { IGNORE_POP, "assign", assign_, "V [N]  ->", "[IMPURE] Assigns value V to the variable with name N.\n" },
 /* 3200 */ { OK, "round", round_, "F  ->  G", "[EXT] G is F rounded to the nearest integer.\n" },
 /* 3210 */ { OK, "sametype", sametype_, "X Y  ->  B", "[EXT] Tests whether X and Y have the same type.\n" },
 /* 3230 */ { OK, "typeof", typeof_, "X  ->  I", "[EXT] Replace X by its type.\n" },
+/* 3235 */ { IGNORE_POP, "unassign", unassign_, "[N]  ->", "[IMPURE] Sets the body of the name N to uninitialized.\n" },
 /* 3240 */ { OK, "#genrec", genrecaux_, "[[B] [T] [R1] R2]  ->  ...", "Executes B, if that yields true, executes T.\nElse executes R1 and then [[[B] [T] [R1] R2] genrec] R2.\n" },
 /* 3250 */ { OK, "#treegenrec", treegenrecaux_, "T [[O1] [O2] C]  ->  ...", "T is a tree. If T is a leaf, executes O1.\nElse executes O2 and then [[[O1] [O2] C] treegenrec] C.\n" },
 /* 3260 */ { OK, "#treerec", treerecaux_, "T [[O] C]  ->  ...", "T is a tree. If T is a leaf, executes O. Else executes [[[O] C] treerec] C.\n" },

table.sh

@@ -1,7 +1,7 @@
 #
 #   module  : table.sh
-#   version : 1.5
-#   date    : 08/13/23
+#   version : 1.6
+#   date    : 04/19/24
 #
 #   Generate table.c
 #   The directory needs to be given as parameter.
@@ -49,4 +49,4 @@ do
 	P
   }' <$i
 done | sort >$1/table.c
-touch $1/interp.c
+touch $1/optable.c