Enable runtime controlled debug output.

Currently only in make_X_keymap.
Output is to STDOUT (since the conditional compilation DEBUG did)

Medley branch: mth38--command-line-arg-to-support-maiko-runtime-debug adds command line argument support for this.

.github/workflows/Dockerfile_maiko

@@ -18,17 +18,8 @@ COPY . ${INSTALL_LOCATION}
 # Build maiko
 RUN cd ${INSTALL_LOCATION}/bin \
     && ./makeright x cleanup \
-    && ./makeright x \
+    && ./makeright x
+RUN cd ${INSTALL_LOCATION}/bin \
     && if [ "$(./machinetype)" = "x86_64" ]; then \
            ./makeright init; \
        fi
-# Build specially for WSL1 by "fooling" a linux build
-RUN cd ${INSTALL_LOCATION}/bin \
-    && arch="$(./machinetype)" \
-    && if [ "$arch" = "x86_64" ] || [ "$arch" = "aarch64" ]; then \
-           export LDEARCH="${arch}-microsoft-wsl1" \
-           && ./makeright x cleanup \
-           && ./makeright x \
-           && ./makeright init \
-           ; \
-       fi

.github/workflows/buildRelease.yml

@@ -224,13 +224,7 @@ jobs:
           RELEASE_TAG: ${{ steps.tag.outputs.release_tag }}
         run: |
           mkdir -p /tmp/release_tars
-          for OSARCH in                                                                \
+          for OSARCH in "linux.x86_64:linux_amd64" "linux.aarch64:linux_arm64" "linux.armv7l:linux_arm_v7" ;    \
-                        "linux.x86_64:linux_amd64"                                     \
-                        "linux.aarch64:linux_arm64"                                    \
-                        "linux.armv7l:linux_arm_v7"                                    \
-                        "wsl1.x86_64:linux_amd64"                                      \
-                        "wsl1.aarch64:linux_arm64"                                     \
-                        ;                                                              \
             do                                                                         \
               pushd /tmp/docker_images/${OSARCH##*:}/usr/local/interlisp >/dev/null ;  \
               /usr/bin/tar -c -z                                                       \
@@ -252,8 +246,6 @@ jobs:
           artifacts:
             /tmp/release_tars/${{ steps.tag.outputs.release_tag }}-linux.x86_64.tgz,
             /tmp/release_tars/${{ steps.tag.outputs.release_tag }}-linux.aarch64.tgz,
-            /tmp/release_tars/${{ steps.tag.outputs.release_tag }}-wsl1.x86_64.tgz,
-            /tmp/release_tars/${{ steps.tag.outputs.release_tag }}-wsl1.aarch64.tgz,
             /tmp/release_tars/${{ steps.tag.outputs.release_tag }}-linux.armv7l.tgz
           tag: ${{ steps.tag.outputs.release_tag }}
           draft: ${{ needs.inputs.outputs.draft }}

bin/makefile-init-wsl1.aarch64

@@ -1,29 +0,0 @@
-# Options for Windows System for Linux v1, aarch64 processor, X windows, for INIT processing
-
-CC = gcc $(GCC_CFLAGS)
-#CC = clang $(CLANG_CFLAGS)
-
-XFILES = $(OBJECTDIR)xmkicon.o \
-	$(OBJECTDIR)xbbt.o \
-	$(OBJECTDIR)dspif.o \
-	$(OBJECTDIR)xinit.o \
-	$(OBJECTDIR)xscroll.o \
-	$(OBJECTDIR)xcursor.o \
-	$(OBJECTDIR)xlspwin.o \
-	$(OBJECTDIR)xrdopt.o \
-	$(OBJECTDIR)xwinman.o
-
-
-XFLAGS = -DXWINDOW
-
-# OPTFLAGS is normally -O2, for INIT we want unoptimized in case we need to debug it
-OPTFLAGS =  -O0 -g
-DEBUGFLAGS =
-DFLAGS = $(DEBUGFLAGS) $(XFLAGS) -DRELEASE=$(RELEASE) -DNOVERSION -DINIT -D__wsl1__
-
-LDFLAGS = -L/usr/X11/lib -lX11 -lc -lm
-LDELDFLAGS =  -L/usr/X11/lib -lX11 -lc -lm
-
-OBJECTDIR = ../$(RELEASENAME)/
-
-default	: ../$(OSARCHNAME)/ldeinit

bin/makefile-init-wsl1.x86_64

@@ -1,29 +0,0 @@
-# Options for Windows System for Linux v1, Intel x86_64 processor, X windows, for INIT processing
-
-CC = gcc $(GCC_CFLAGS)
-#CC = clang $(CLANG_CFLAGS)
-
-XFILES = $(OBJECTDIR)xmkicon.o \
-	$(OBJECTDIR)xbbt.o \
-	$(OBJECTDIR)dspif.o \
-	$(OBJECTDIR)xinit.o \
-	$(OBJECTDIR)xscroll.o \
-	$(OBJECTDIR)xcursor.o \
-	$(OBJECTDIR)xlspwin.o \
-	$(OBJECTDIR)xrdopt.o \
-	$(OBJECTDIR)xwinman.o
-
-
-XFLAGS = -DXWINDOW
-
-# OPTFLAGS is normally -O2, for INIT we want unoptimized in case we need to debug it
-OPTFLAGS =  -O0 -g
-DEBUGFLAGS =
-DFLAGS = $(DEBUGFLAGS) $(XFLAGS) -DRELEASE=$(RELEASE) -DNOVERSION -DINIT -D__wsl1__
-
-LDFLAGS = -L/usr/X11/lib -lX11 -lc -lm
-LDELDFLAGS =  -L/usr/X11/lib -lX11 -lc -lm
-
-OBJECTDIR = ../$(RELEASENAME)/
-
-default	: ../$(OSARCHNAME)/ldeinit

bin/makefile-wsl1.aarch64-sdl

@@ -1,25 +0,0 @@
-# Options for Windows System for Linux v1, ARM64 and SDL
-
-CC = gcc $(GCC_CFLAGS)
-#CC = clang $(CLANG_CFLAGS)
-
-XFILES = $(OBJECTDIR)sdl.o
-
-#
-#  For SDL version 2
-#      -DSDL=2 in SDLFLAGS and -lSDL2 in LDFLAGS
-#  For SDL version 3
-#      -DSDL=3 in SDLFLAGS and -lSDL3 in LDFLAGS
-#
-SDLFLAGS = -DSDL=2
-
-# OPTFLAGS is normally -O2.
-OPTFLAGS =  -O2 -g3
-DFLAGS = $(SDLFLAGS) -DRELEASE=$(RELEASE) -D__wsl1__
-
-LDFLAGS = -lSDL2 -lm
-LDELDFLAGS =
-
-OBJECTDIR = ../$(RELEASENAME)/
-
-default	: ../$(OSARCHNAME)/lde ../$(OSARCHNAME)/ldesdl

bin/makefile-wsl1.aarch64-x

@@ -1,27 +0,0 @@
-# Options for Windows System for Linux v1, aarch64 and X-Window
-
-CC = gcc $(GCC_CFLAGS)
-#CC = clang $(CLANG_CFLAGS)
-
-XFILES = $(OBJECTDIR)xmkicon.o \
-	$(OBJECTDIR)xbbt.o \
-	$(OBJECTDIR)dspif.o \
-	$(OBJECTDIR)xinit.o \
-	$(OBJECTDIR)xscroll.o \
-	$(OBJECTDIR)xcursor.o \
-	$(OBJECTDIR)xlspwin.o \
-	$(OBJECTDIR)xrdopt.o \
-	$(OBJECTDIR)xwinman.o
-
-XFLAGS = -DXWINDOW
-
-# OPTFLAGS is normally -O2.
-OPTFLAGS =  -O2 -g3
-DFLAGS = $(XFLAGS) -DRELEASE=$(RELEASE) -D__wsl1__
-
-LDFLAGS = -L/usr/X11/lib -lX11 -lc -lm
-LDELDFLAGS =  -L/usr/X11/lib -lX11 -lc -lm
-
-OBJECTDIR = ../$(RELEASENAME)/
-
-default	: ../$(OSARCHNAME)/lde ../$(OSARCHNAME)/ldex

bin/makefile-wsl1.x86_64-sdl

@@ -1,25 +0,0 @@
-# Options for Windows System for Linux v1, Intel x86_64 and SDL
-
-CC = gcc -m64 $(GCC_CFLAGS)
-# CC = clang -m64 $(CLANG_CFLAGS)
-
-XFILES = $(OBJECTDIR)sdl.o
-
-#
-#  For SDL version 2
-#      -DSDL=2 in XFLAGS and -lSDL2 in LDFLAGS
-#  For SDL version 3
-#      -DSDL=3 in XFLAGS and -lSDL3 in LDFLAGS
-#
-XFLAGS = -DSDL=2
-
-# OPTFLAGS is normally -O2.
-OPTFLAGS =  -O2 -g3
-DFLAGS = $(XFLAGS) -DRELEASE=$(RELEASE) -D__wsl1__
-
-LDFLAGS = -lm -lSDL2
-LDELDFLAGS =
-
-OBJECTDIR = ../$(RELEASENAME)/
-
-default	: ../$(OSARCHNAME)/lde ../$(OSARCHNAME)/ldesdl

bin/makefile-wsl1.x86_64-x

@@ -1,28 +0,0 @@
-# Options for Windows System for Linux v1, Intel x86_64 and X-Window
-
-CC = gcc -m64 $(GCC_CFLAGS)
-# CC = clang -m64 $(CLANG_CFLAGS)
-
-XFILES = $(OBJECTDIR)xmkicon.o \
-	$(OBJECTDIR)xbbt.o \
-	$(OBJECTDIR)dspif.o \
-	$(OBJECTDIR)xinit.o \
-	$(OBJECTDIR)xscroll.o \
-	$(OBJECTDIR)xcursor.o \
-	$(OBJECTDIR)xlspwin.o \
-	$(OBJECTDIR)xrdopt.o \
-	$(OBJECTDIR)xwinman.o
-
-
-XFLAGS = -DXWINDOW
-
-# OPTFLAGS is normally -O2.
-OPTFLAGS =  -O2 -g3
-DFLAGS = $(XFLAGS) -DRELEASE=$(RELEASE) -D__wsl1__
-
-LDFLAGS = -L/usr/X11/lib -lX11 -lc -lm
-LDELDFLAGS =  -L/usr/X11/lib -lX11 -lc -lm
-
-OBJECTDIR = ../$(RELEASENAME)/
-
-default	: ../$(OSARCHNAME)/lde ../$(OSARCHNAME)/ldex

bin/mkvdate

@@ -1,7 +1,7 @@
 #!/bin/sh
 if command -v "git" >/dev/null 2>&1; then
     MAIKO_REV="$(git status --porcelain)"
-    if [ $? -eq 0 ]; then
+    if [ $? == 0 ]; then
 	if [ ! -z "$(git status --porcelain)" ]; then
             MAIKO_REV="$(git rev-parse --short HEAD)-dirty"
 	else

bin/osversion

@@ -8,14 +8,11 @@ case "$os" in
         *-*-solaris2*)	        echo sunos5 ;;
         alpha-dec-osf1)		echo osf1 ;;
 	*-apple-darwin*)	echo darwin ;;
-        *-*-linux*)
+        *-*-linux*)		echo linux ;;
-           if [ -n "${WSL_DISTRO_NAME}" ] && [ -z "${WSL_INTEROP}" ];
-           then echo wsl1; else echo linux; fi ;;
         *-*-openbsd*)		echo openbsd ;;
         *-*-freebsd*)		echo freebsd ;;
 	*-*-cygwin*)            echo cygwin ;;
 	*-*-haiku*)             echo haiku ;;
-        *-microsoft-wsl1)       echo wsl1 ;;
 esac
 ### Don't leave the variable set.
 unset os

inc/gcfinaldefs.h

@@ -2,10 +2,14 @@
 #define GCFINALDEFS_H 1
 #include "lispemul.h" /* for LispPTR, DLword */
 void printarrayblock(LispPTR base);
-void printfreeblockchainn(int arlen);
+int integerlength(unsigned int n);
+LispPTR findptrsbuffer(LispPTR ptr);
 LispPTR releasingvmempage(LispPTR ptr);
 LispPTR checkarrayblock(LispPTR base, LispPTR free, LispPTR onfreelist);
+LispPTR deleteblock(LispPTR base);
+LispPTR linkblock(LispPTR base);
 LispPTR makefreearrayblock(LispPTR block, DLword length);
+LispPTR arrayblockmerger(LispPTR base, LispPTR nbase);
 LispPTR mergebackward(LispPTR base);
 LispPTR mergeforward(LispPTR base);
 LispPTR reclaimarrayblock(LispPTR ptr);

inc/lispver2.h

@@ -9,7 +9,7 @@
 	char	*lv_cp;						\
 	char	*lv_vp;						\
 	unsigned lv_ver;					\
-	char		lv_ver_buf[VERSIONLEN + 3];			\
+	char		lv_ver_buf[VERSIONLEN];				\
 									\
 	lv_cp = pathname;						\
 	lv_vp = NULL;							\

inc/locfile.h

@@ -8,14 +8,10 @@
 /*	Manufactured in the United States of America.			*/
 /*									*/
 /************************************************************************/
-#include <ctype.h>     /* for isdigit */
 #include <errno.h>
 #include <limits.h>   /* for NAME_MAX */
-#include <string.h>   /* for strlen */
-#include <sys/param.h> /* for MAXPATHLEN */
 #include <dirent.h>   /* for MAXNAMLEN */
 #include "lispemul.h" /* for DLword */
-#include "commondefs.h" /* for error */
 
 #define	FDEV_PAGE_SIZE		512	/* 1 page == 512 byte */
 
@@ -67,9 +63,6 @@
         else if(((ptr) & SEGMASK)== S_NEGATIVE) {(place) = (int)((ptr)| 0xffff0000);}\
         else {return(NIL);}} while (0)
 
-#ifndef min
-#define min(a, b) (((a) <= (b))?(a):(b))
-#endif /* min */
 
 /************************************************************************/
 /*									*/
@@ -86,65 +79,65 @@
 /*									*/
 /************************************************************************/
 #ifndef BYTESWAP
-static inline void LispStringToCString(LispPTR Lisp, char *C, size_t MaxLen)
+#define	LispStringToCString(Lisp, C, MaxLen)				\
-{
+  do {									\
-    OneDArray	*lf_arrayp;
+    OneDArray	*lf_arrayp;						\
-    char	*lf_base, *lf_dp;
+    char	*lf_base, *lf_dp;						\
-    short	*lf_sbase;
+    short	*lf_sbase;							\
-    size_t		 lf_length;
+    size_t		 lf_length;						\
-    lf_arrayp = (OneDArray *)NativeAligned4FromLAddr(Lisp);
+    lf_arrayp = (OneDArray *)NativeAligned4FromLAddr(Lisp);		\
-    lf_length = min(MaxLen, lf_arrayp->fillpointer);
+    lf_length = min(MaxLen, lf_arrayp->fillpointer);			\
-    switch(lf_arrayp->typenumber)
+    switch(lf_arrayp->typenumber)						\
-      {
+      {									\
-	case THIN_CHAR_TYPENUMBER:
+	case THIN_CHAR_TYPENUMBER:					\
-		lf_base = ((char *)(NativeAligned2FromLAddr(lf_arrayp->base)))
+		lf_base = ((char *)(NativeAligned2FromLAddr(lf_arrayp->base)))  	\
-		       + ((int)(lf_arrayp->offset));
+		       + ((int)(lf_arrayp->offset));			\
-		strncpy(C, lf_base, lf_length);
+		strncpy(C, lf_base, lf_length);				\
-		(C)[lf_length] = '\0';
+		(C)[lf_length] = '\0';					\
-		break;
+		break;							\
-
+									\
-	case FAT_CHAR_TYPENUMBER:
+	case FAT_CHAR_TYPENUMBER:					\
-		lf_sbase = ((short *)(NativeAligned2FromLAddr(lf_arrayp->base)))
+		lf_sbase = ((short *)(NativeAligned2FromLAddr(lf_arrayp->base)))	\
-		       + ((int)(lf_arrayp->offset));
+		       + ((int)(lf_arrayp->offset));			\
-                lf_dp = C;
+                lf_dp = C;						\
-		for(size_t lf_i=0;lf_i<(lf_length);lf_i++)
+		for(size_t lf_i=0;lf_i<(lf_length);lf_i++)		\
-		  *lf_dp++ = (char)(*lf_sbase++);
+		  *lf_dp++ = (char)(*lf_sbase++);			\
-		*lf_dp = '\0';
+		*lf_dp = '\0';						\
-		break;
+		break;							\
-	default:
+	default:							\
-		error("LispStringToCString: Not a character array.\n");
+		error("LispStringToCString: Not a character array.\n");	\
-      }
+      }									\
-}
+ } while (0)
 #else  /* BYTESWAP == T CHANGED-BY-TAKE */
-static inline void LispStringToCString(LispPTR Lisp, char *C, size_t MaxLen)
+#define	LispStringToCString(Lisp, C, MaxLen)				\
-{
+  do {									\
-    OneDArray	*lf_arrayp;
+    OneDArray	*lf_arrayp;						\
-    char	*lf_base, *lf_dp;
+    char	*lf_base, *lf_dp;						\
-    short	*lf_sbase;
+    short	*lf_sbase;							\
-    size_t 	lf_length;
+    size_t 	lf_length;						\
-    lf_arrayp = (OneDArray *)(NativeAligned4FromLAddr(Lisp));
+    lf_arrayp = (OneDArray *)(NativeAligned4FromLAddr(Lisp));			\
-    lf_length = min(MaxLen, lf_arrayp->fillpointer);
+    lf_length = min(MaxLen, lf_arrayp->fillpointer);			\
-    switch(lf_arrayp->typenumber)
+    switch(lf_arrayp->typenumber)						\
-      {
+      {									\
-	case THIN_CHAR_TYPENUMBER:
+	case THIN_CHAR_TYPENUMBER:					\
-		lf_base = ((char *)(NativeAligned2FromLAddr(lf_arrayp->base)))
+		lf_base = ((char *)(NativeAligned2FromLAddr(lf_arrayp->base)))  	\
-		       + ((int)(lf_arrayp->offset));
+		       + ((int)(lf_arrayp->offset));			\
-		StrNCpyFromLispToC(C , lf_base , lf_length );
+		StrNCpyFromLispToC(C , lf_base , lf_length );		\
-		(C)[lf_length] = '\0';
+		(C)[lf_length] = '\0';					\
-		break;
+		break;							\
-
+									\
-	case FAT_CHAR_TYPENUMBER:
+	case FAT_CHAR_TYPENUMBER:					\
-		lf_sbase = ((short *)(NativeAligned2FromLAddr(lf_arrayp->base)))
+		lf_sbase = ((short *)(NativeAligned2FromLAddr(lf_arrayp->base)))	\
-		       + ((int)(lf_arrayp->offset));
+		       + ((int)(lf_arrayp->offset));			\
-                lf_dp = C;
+                lf_dp = C;						\
-		for(size_t lf_ii=0;lf_ii<(lf_length);lf_ii++,lf_sbase++)
+		for(size_t lf_ii=0;lf_ii<(lf_length);lf_ii++,lf_sbase++)  \
-                    *lf_dp++ = (char)(GETWORD(lf_sbase));
+                    *lf_dp++ = (char)(GETWORD(lf_sbase));               \
-		*lf_dp = '\0';
+		*lf_dp = '\0';						\
-		break;
+		break;							\
-	default:
+	default:							\
-		error("LispStringToCString: Not a character array.\n");
+		error("LispStringToCString: Not a character array.\n");	\
-      }
+      }									\
-}
+  } while (0)
 
 #endif /* BYTESWAP */
 
@@ -196,6 +189,10 @@ do  {				\
 	(cstringp) = (char *)(NativeAligned2FromLAddr(((OneDArray *)lf_naddress)->base)); \
  } while (0)
 
+#ifndef min
+#define min(a, b) (((a) <= (b))?(a):(b))
+#endif /* min */
+
 #define	LispNumToCInt(Lisp)					\
        ( (((Lisp) & SEGMASK) == S_POSITIVE) ? ((Lisp) & 0xFFFF) : \
           (((Lisp) & SEGMASK) == S_NEGATIVE) ? ((Lisp) | 0xFFFF0000) : \
@@ -334,10 +331,14 @@ do  {				\
 /*		
  * Name:	UnixVersionToLispVersion
  *
- * Argument:	char *pathname  UNIX syntax pathname.
+ * Argument:	char	*pathname
- *		int vlessp      If 0, versionless file is converted to version 1.
+ *				UNIX syntax pathname.
+ *		int	vlessp
+ *				If 0, versionless file is converted to version 1.
  *				Otherwise, remains as versionless.
  *
+ * Value:	If succeed, returns 1, otherwise 0.
+ *
  * Side Effect:	The version part of pathname is destructively modified.
  *
  * Description:
@@ -352,18 +353,60 @@ do  {				\
  * dealt with as version 1. 
  */
 
-#define UnixVersionToLispVersion(pathname, vlessp)                      \
+#define UnixVersionToLispVersion(pathname, vlessp) do {				\
-  do {                                                                  \
-    char *n_end;                                                        \
-    char *v_start;                                                      \
-    int	v_len;                                                          \
 										\
-    if (!parse_file_version(pathname, 1, &n_end, &v_start, &v_len)) {   \
+	char	*start;							\
-      if (!vlessp) strcat(pathname, ";1");                              \
+	char	*end;							\
+	char	*lf_cp;							\
+	int	ver_no;								\
+	size_t	len;								\
+	char		ver_buf[VERSIONLEN];					\
+										\
+	if ((start = strchr(pathname, '~')) != NULL) {				\
+		/* First of all, find the version field in pathname. */		\
+		end = start;							\
+		lf_cp = start + 1;							\
+		while (*lf_cp) {							\
+			if (*lf_cp == '~') {					\
+				start = end;					\
+				end = lf_cp;					\
+				lf_cp++;						\
 			} else {						\
-      *n_end++ = ';';                                                   \
+				lf_cp++;						\
-      while (v_len-- > 0) *n_end++ = *v_start++;                        \
+			}							\
-      *n_end = '\0';                                                    \
+		}								\
+										\
+		if (start != end && *(start - 1) == '.' && end == (lf_cp - 1)) {	\
+			/*							\
+			 * pathname ends in the form ".~###~".  But we		\
+			 * check ### is a valid number or not.			\
+			 */							\
+			len = (end - start) - 1;			\
+			strncpy(ver_buf, start + 1, len);			\
+			ver_buf[len] = '\0';					\
+			NumericStringP(ver_buf, YES, NO);			\
+		      YES:							\
+			*(start - 1) = ';';					\
+			*start = '\0';						\
+			*end = '\0';						\
+			/* call strtoul() to eliminate leading 0s. */		\
+			ver_no = strtoul(start + 1, (char **)NULL, 10);		\
+			sprintf(ver_buf, "%u", ver_no);				\
+			strcat(pathname, ver_buf);				\
+			goto CONT;						\
+										\
+		      NO:							\
+			/* Dealt with as version 1 unless vlessp */		\
+			if (!(vlessp)) strcat(pathname, ";1");                  \
+		      CONT:							\
+			lf_cp--;	/* Just for label */			\
+		} else {							\
+			/* Dealt with as version 1 unless vlessp. */		\
+                        if (!(vlessp)) strcat(pathname, ";1");                  \
+		}								\
+	} else {								\
+		/* Dealt with as version 1 unless vlessp. */			\
+                if (!(vlessp)) strcat(pathname, ";1");                          \
 	}									\
   } while (0)
 
@@ -385,43 +428,43 @@ do  {				\
  *
  */
 
-static inline void ConcDirAndName(char *dir, char *name, char *fname)
+#define ConcDirAndName(dir, name, fname) do {					\
-{
+									\
-  char	*lf_cp1, *lf_cp2;
+	char	*lf_cp1, *lf_cp2;					\
-
+									\
-  lf_cp1 = dir;
+	lf_cp1 = dir;							\
-  lf_cp2 = dir;
+	lf_cp2 = dir;							\
-
+									\
-  while (*lf_cp2 != '\0') {
+	while (*lf_cp2 != '\0') {						\
-    switch (*lf_cp2) {
+		switch (*lf_cp2) {						\
-
+									\
-    case '/':
+		      case '/':						\
-      lf_cp1 = lf_cp2;
+			lf_cp1 = lf_cp2;					\
-      lf_cp2++;
+			lf_cp2++;						\
-      break;
+			break;						\
-
+									\
-    default:
+		      default:						\
-      lf_cp2++;
+			lf_cp2++;						\
-      break;
+			break;						\
-    }
+		}							\
-  }
+	}								\
-  if (lf_cp1 == (lf_cp2 - 1)) {
+	if (lf_cp1 == (lf_cp2 - 1)) {						\
-    if (lf_cp1 == (dir)) {
+                if (lf_cp1 == (dir)) {					\
-      /* dir is a root directory. */
+			/* dir is a root directory. */			\
-      strcpy(fname, "/");
+			strcpy(fname, "/");				\
-      strcat(fname, name);
+			strcat(fname, name);				\
-    } else {
+		} else {						\
-      /* The trail directory is included. */
+			/* The trail directory is included. */		\
-      strcpy(fname, dir);
+			strcpy(fname, dir);				\
-      strcat(fname, name);
+			strcat(fname, name);				\
-    }
+		}							\
-  } else {
+	} else {							\
-    /* The trail directory is not included */
+		/* The trail directory is not included */		\
-    strcpy(fname, dir);
+		strcpy(fname, dir);					\
-    strcat(fname, "/");
+		strcat(fname, "/");					\
-    strcat(fname, name);
+		strcat(fname, name);					\
-  }
+	}								\
-}
+  } while (0)
 
 /*		
  * Name:	ConcNameAndVersion
@@ -438,24 +481,20 @@ static inline void ConcDirAndName(char *dir, char *name, char *fname)
  *
  * Concatenate the root file name and its version in UNIX format.
  *
- * XXX: this code is unsafe and could result in memory smashes if the
- * sizes of the arguments are not correctly specified
- *
  */
 
-static inline void ConcNameAndVersion(char *name, char *ver, char *rname)
+#define ConcNameAndVersion(name, ver, rname) do {				\
-{
+	if (*(ver) != '\0') {						\
-	if (*ver != '\0') {
+		strcpy(rname, name);					\
-		strcpy(rname, name);
+		strcat(rname, ".~");					\
-		strcat(rname, ".~");
+		strcat(rname, ver);					\
-		strcat(rname, ver);
+		strcat(rname, "~");					\
-		strcat(rname, "~");
+	} else {							\
-	} else {
+		strcpy(rname, name);					\
-		strcpy(rname, name);
+	}								\
-	}
+} while (0)
-}
 
-#define	 VERSIONLEN		10
+#define	 VERSIONLEN		16
 
 #define	MAXVERSION		999999999
 
@@ -537,9 +576,9 @@ static inline void ConcNameAndVersion(char *name, char *ver, char *rname)
 		TIMEOUT(lf_rval=rename(x, y));		\
 		if(lf_rval == -1){				\
 			switch(errno){			\
-			case ENOENT:				\
+			case 2:				\
 				return(1);		\
-			case EXDEV:			\
+			case 18:			\
 				*Lisp_errno = errno;	\
 				return(0);		\
 			default:			\
@@ -562,78 +601,20 @@ static inline void ConcNameAndVersion(char *name, char *ver, char *rname)
 /*
  * For file name length check
  */
+#define FNAMETOOLONG	200
 
 #define FileNameTooLong(val) do {				\
-	*Lisp_errno = ENAMETOOLONG;                     \
+	*Lisp_errno = FNAMETOOLONG;			\
 	return((val));					\
   } while (0)
 
-static inline int parse_file_version(char *name, int digitsonly, char **n_end,
-                                      char **v_start, int *v_length)
-{
-  char *sp, *ep;
-  size_t name_len;
 
-  name_len = strlen(name);
-  ep = &name[name_len - 1];
 
-  /* handle special case of Alto/IFS names with !nnn version.
-     To be considered for this case the name MUST end with ![0-9]+, however
-     version 0 is not valid.
-   */
-  sp = strrchr(name, '!');
-  if (sp != NULL) {
-    sp++;         /* "!nnn" => "nnn" or "!" => ""  */
-    if (*sp != '\0' && sp[strspn(sp, "0123456789")] == '\0') {
-      /* it was all digits after the '!', so go with it */
-      *n_end = sp - 1; /* name ends at '!'  */
-      while (*sp == '0' && sp < ep) sp++; /* skip leading zeroes */
-      if (*sp == '0') return (0); /* version 0 is not valid */
-      *v_start = sp;   /* version start after '!' */
-      *v_length = (ep - sp) + 1;
-      return ((*v_length >= VERSIONLEN) ? 0 : 1); /* fail on version too long */
-    }
-  }
 
-  /* if the name is too short to have a name and a version number
-     ".~#~" or doesn't end with "~" then there is no version number
-  */
-  if (name_len < 4 || *ep != '~')
-    return (0);
 
-  /* The name ends with a "~" so scan back in the filename looking for
-     another "~" terminating early if we need only digits and find
-     something else
-  */
-  sp = ep - 1;
-  while (sp > name && *sp != '~') {
-    if (digitsonly && !isdigit(*sp)) return (0);
-    --sp;
-  }
 
-  /* test for no initial "~" or no "." before "~", or
-   * version number length not at least 1
-   */
-  if (sp == name || *(sp - 1) != '.' || (ep - sp) - 1 < 1)
-    return (0);
 
-  /* After this point we have a version number in the form .~#~ with sp
-     pointing at the starting "~", ep pointing at the last "~",
-     and there must be at least one digit. Scan past any leading
-     zeros in the version, taking care not to remove the last digit.
-  */
 
-  *n_end = sp - 1;    /* save location of "." */
-
-  sp++;                  /* skip over the "." */
-  while (*sp == '0' && sp < (ep - 1)) {
-    sp++;
-  }
-  if (*sp == '0') return (0);  /* version 0 is not valid */
-  *v_start = sp;           /* save location of first significant digit in version */
-  *v_length = (ep - sp);   /* save length of version */
-  return ((*v_length >= VERSIONLEN) ? 0 : 1); /* fail on version too long */
-}
 
 /********************************************************/
 /*  file-system-specific defns                */

inc/maiko/platform.h

@@ -38,23 +38,13 @@
 #  define MAIKO_OS_DETECTED 1
 #endif
 
-#if defined(__linux__) && !defined(__wsl1__)
+#ifdef __linux__
 #  define MAIKO_OS_LINUX 1
 #  define MAIKO_OS_NAME "Linux"
 #  define MAIKO_OS_UNIX_LIKE 1
 #  define MAIKO_OS_DETECTED 1
 #endif
 
-#if defined(__linux__) && defined(__wsl1__)
-#  define MAIKO_OS_LINUX 1
-#  define MAIKO_OS_WSL1 1
-#  define MAIKO_OS_NAME "Windows System for Linux v1"
-#  define MAIKO_OS_UNIX_LIKE 1
-#  define MAIKO_EMULATE_TIMER_INTERRUPTS 1
-#  define MAIKO_EMULATE_ASYNC_INTERRUPTS 1
-#  define MAIKO_OS_DETECTED 1
-#endif
-
 #ifdef __NetBSD__
 #  define MAIKO_OS_NETBSD 1
 #  define MAIKO_OS_NAME "NetBSD"

inc/uraidextdefs.h

@@ -4,7 +4,7 @@
 #include "stack.h" /* for FX */
 #include "lispemul.h" /* for LispPTR */
 
-#define URMAXFXNUM 4096
+#define URMAXFXNUM 2000
 #define URMAXCOMM 512
 #define URSCAN_ALINK 0
 #define URSCAN_CLINK 1

src/dsk.c

@@ -3246,7 +3246,6 @@ static int maintain_version(char *file, int forcep)
      * is versioned one higher than the existing highest version.
      */
     FindHighestVersion(VA.files, entry, max_no);
-    if (max_no >= MAXVERSION) {*Lisp_errno = EIO; return (0);}
     sprintf(ver, "%u", max_no + 1);
 /*
  * The old file should have the same case name as the versionless
@@ -3571,7 +3570,6 @@ static int get_old(char *dir, FileName *varray, char *afile, char *vfile)
          * link missing versionless file.
          */
         FindHighestVersion(varray, entry, max_no);
-        if (max_no >= MAXVERSION) {*Lisp_errno = EIO; return (0);}
         sprintf(vbuf, "%u", max_no + 1);
         ConcNameAndVersion(vless, vbuf, vfile);
         strcpy(afile, vless);
@@ -3580,7 +3578,6 @@ static int get_old(char *dir, FileName *varray, char *afile, char *vfile)
         /* A version is specified. */
         ver_no = strtoul(ver, (char **)NULL, 10);
         FindHighestVersion(varray, entry, max_no);
-        if (max_no >= MAXVERSION) {*Lisp_errno = EIO; return (0);}
         if (ver_no == max_no + 1) {
           /*
            * If the version is one higher than the
@@ -3929,7 +3926,6 @@ static int get_new(char *dir, FileName *varray, char *afile, char *vfile)
        * the existing highest version.
        */
       FindHighestVersion(varray, entry, max_no);
-      if (max_no + 1 >= MAXVERSION) {*Lisp_errno = EIO; return (0);}
       sprintf(vbuf, "%u", max_no + 1);
       /*
        * We will use the file name of the existing highest
@@ -4022,7 +4018,6 @@ static int get_new(char *dir, FileName *varray, char *afile, char *vfile)
          * missing versionless file.
          */
         FindHighestVersion(varray, entry, max_no);
-        if (max_no + 1 >= MAXVERSION) {*Lisp_errno = EIO; return (0);}
         sprintf(vbuf, "%u", max_no + 2);
         ConcNameAndVersion(vless, vbuf, vfile);
         strcpy(afile, vfile);
@@ -4086,7 +4081,6 @@ static int get_new(char *dir, FileName *varray, char *afile, char *vfile)
          * new file.
          */
         FindHighestVersion(varray, entry, max_no);
-        if (max_no >= MAXVERSION) {*Lisp_errno = EIO; return (0);}
         sprintf(vbuf, "%u", max_no + 1);
         /*
          * We will use the name of the highest versioned file
@@ -4303,7 +4297,6 @@ static int get_old_new(char *dir, FileName *varray, char *afile, char *vfile)
          * link missing versionless file.
          */
         FindHighestVersion(varray, entry, max_no);
-        if (max_no >= MAXVERSION) {*Lisp_errno = EIO; return (0);}
         sprintf(vbuf, "%u", max_no + 1);
         ConcNameAndVersion(vless, vbuf, vfile);
         strcpy(afile, vless);

src/gcarray.c

@@ -99,23 +99,25 @@ struct hashtable {
 LispPTR aref1(LispPTR array, int index) {
   LispPTR retval = 0;
   LispPTR base;
-  struct arrayheader *array_np;
+  short typenumber;
+  struct arrayheader *actarray;
 
-  array_np = (struct arrayheader *)NativeAligned4FromLAddr(array);
+  actarray = (struct arrayheader *)NativeAligned4FromLAddr(array);
-  if (index >= array_np->totalsize) {
+  if (index >= actarray->totalsize) {
     printf("Invalid index in GC's AREF1:  0x%x\n", index);
-    printf(" Array size limit:  0x%x\n", array_np->totalsize);
+    printf(" Array size limit:  0x%x\n", actarray->totalsize);
     printf(" Array ptr: 0x%x\n", array);
-    printf(" Array native ptr: %p\n", (void *)array_np);
+    printf(" Array 68K ptr: %p\n", (void *)actarray);
-    printf("base:     0x%x\n", array_np->base);
+    printf("base:     0x%x\n", actarray->base);
-    printf("offset:   0x%x\n", array_np->offset);
+    printf("offset:   0x%x\n", actarray->offset);
-    printf("type #:   0x%x\n", array_np->typenumber);
+    printf("type #:   0x%x\n", actarray->typenumber);
-    printf("fill ptr: 0x%x\n", array_np->fillpointer);
+    printf("fill ptr: 0x%x\n", actarray->fillpointer);
     error("index out of range in GC's AREF1.");
   }
-  index += array_np->offset;
+  index += actarray->offset;
-  base = array_np->base;
+  typenumber = actarray->typenumber;
-  switch (array_np->typenumber) {
+  base = actarray->base;
+  switch (typenumber) {
     case 3: /* unsigned 8bits */
       retval = (GETBYTE(((char *)NativeAligned2FromLAddr(base)) + index)) & 0x0ff;
       retval |= S_POSITIVE;
@@ -124,9 +126,7 @@ LispPTR aref1(LispPTR array, int index) {
       retval = (GETWORD(((DLword *)NativeAligned2FromLAddr(base)) + index)) & 0x0ffff;
       retval |= S_POSITIVE;
       break;
-  case 38: /* pointer 32 bits */
+    case 38: retval = (*(((LispPTR *)NativeAligned4FromLAddr(base)) + index)); break;
-    retval = (*(((LispPTR *)NativeAligned4FromLAddr(base)) + index));
-    break;
     default: error("Not Implemented in gc's aref1 (other types)");
   }
   return (retval);

src/gcfinal.c

@@ -50,7 +50,7 @@
 #include "gccodedefs.h"   // for reclaimcodeblock
 #include "gcdata.h"       // for DELREF, REC_GCLOOKUP
 #include "gchtfinddefs.h" // for htfind, rec_htfind
-#include "gcfinaldefs.h"  // for checkarrayblock
+#include "gcfinaldefs.h"  // for arrayblockmerger, checkarrayblock, deleteblock
 #include "lispemul.h"     // for LispPTR, NIL, T, POINTERMASK, DLword, ATOM_T
 #include "llstkdefs.h"    // for decusecount68k
 #include "lspglob.h"      // for FreeBlockBuckets_word, ArrayMerging_word
@@ -69,16 +69,13 @@
 #endif /* NEVER */
 
 #define min(a, b) (((a) > (b)) ? (b) : (a))
-#define Trailer(ldatum, datum68) ((ldatum) + DLWORDSPER_CELL * ((datum68)->arlen - ARRAYBLOCKTRAILERCELLS))
+#define Trailer(ldatum, datum68) ((ldatum) + 2 * ((datum68)->arlen - ARRAYBLOCKTRAILERCELLS))
 #define BucketIndex(n) min(integerlength(n), MAXBUCKETINDEX)
 #define FreeBlockChainN(n) ((POINTERMASK & *FreeBlockBuckets_word) + 2 * BucketIndex(n))
 
-/*
- * Declaration of buffer must be identical layout to Lisp BUFFER datatype in PMAP.
- */
 #ifndef BYTESWAP
 #ifdef BIGVM
-struct buffer {
+struct buf {
   LispPTR filepage;
   LispPTR vmempage;
   LispPTR buffernext;
@@ -89,7 +86,7 @@ struct buffer {
   unsigned sysnext : 28;
 };
 #else
-struct buffer {
+struct buf {
   LispPTR filepage;
   LispPTR vmempage;
   LispPTR buffernext;
@@ -102,7 +99,7 @@ struct buffer {
 #endif /* BIGVM */
 #else
 #ifdef BIGVM
-struct buffer {
+struct buf {
   LispPTR filepage;
   LispPTR vmempage;
   LispPTR buffernext;
@@ -113,7 +110,7 @@ struct buffer {
   unsigned noreference : 1;
 };
 #else
-struct buffer {
+struct buf {
   LispPTR filepage;
   LispPTR vmempage;
   LispPTR buffernext;
@@ -126,32 +123,24 @@ struct buffer {
 #endif /* BIGVM */
 #endif /* BYTESWAP */
 
-static int integerlength(unsigned int n) {
+/************* The following procedure is common !! **************************/
-  int p = 0;
 
-  if (n <= 2) return (n); /* easy case */
+int integerlength(unsigned int n) {
-  if (n >= 65536) {
+  int cnt;
-    n >>= 16;
+  if (n <= 2)
-    p += 16;
+    return (n);
+  else {
+    cnt = 1;
+    do {
+      cnt++;
+      n = (n >> 1);
+    } while (n != 1);
+    return (cnt);
   }
-  if (n >= 256) {
-    n >>= 8;
-    p += 8;
-  }
-  if (n >= 16) {
-    n >>= 4;
-    p += 4;
-  }
-  if (n >= 4) {
-    n >>= 2;
-    p += 2;
-  }
-  if (n >= 2) {
-    p += 1;
-  }
-  return (p + 1);
 }
 
+/************* The above procedure is common !! **************************/
+
 /************************************************************************/
 /*									*/
 /*			f i n d p t r s b u f f e r			*/
@@ -162,16 +151,14 @@ static int integerlength(unsigned int n) {
 /*									*/
 /************************************************************************/
 
-static LispPTR findptrsbuffer(LispPTR ptr) {
+LispPTR findptrsbuffer(LispPTR ptr) {
-  LispPTR buf;
+  struct buf *bptr;
-  struct buffer *buf_np;
+  bptr = (struct buf *)NativeAligned4FromLAddr(*System_Buffer_List_word);
-  buf = *System_Buffer_List_word;
+  while (LAddrFromNative(bptr) != NIL) {
-  while (buf != NIL) {
+    if (ptr == bptr->vmempage)
-    buf_np = (struct buffer *)NativeAligned4FromLAddr(buf);
+      return (LAddrFromNative(bptr));
-    if (ptr == buf_np->vmempage) {
+    else
-      return (buf);
+      bptr = (struct buf *)NativeAligned4FromLAddr(bptr->sysnext);
-    }
-    buf = buf_np->sysnext;
   }
   return (NIL);
 }
@@ -188,13 +175,13 @@ static LispPTR findptrsbuffer(LispPTR ptr) {
 /************************************************************************/
 
 LispPTR releasingvmempage(LispPTR ptr) {
-  LispPTR buffer = findptrsbuffer(ptr);
+  struct buf *bptr;
-  struct buffer *buffer_np;
+  LispPTR bufferptr = findptrsbuffer(ptr);
 
-  if (buffer == NIL) return (NIL); /* Not in use, OK to reclaim it */
+  if (bufferptr == NIL) return (NIL); /* Not in use, OK to reclaim it */
 
-  buffer_np = (struct buffer *)NativeAligned4FromLAddr(buffer);
+  bptr = (struct buf *)NativeAligned4FromLAddr(bufferptr);
-  buffer_np->noreference = T; /* Mark the buffer free to use ?? */
+  bptr->noreference = T; /* Mark the buffer free to use ?? */
   return (ATOM_T);
 }
 
@@ -205,9 +192,10 @@ LispPTR releasingvmempage(LispPTR ptr) {
 /*	Given an array block, do consistency checks on it.		*/
 /*									*/
 /************************************************************************/
+
 LispPTR checkarrayblock(LispPTR base, LispPTR free, LispPTR onfreelist) {
-  struct arrayblock *base_np, *trailer_np;
+  struct arrayblock *bbase, *btrailer;
-  struct arrayblock *fwd_np, *bkwd_np, *rbase;
+  struct arrayblock *bfwd, *bbwd, *rbase;
   LispPTR fbl;
   LispPTR *rover, *tmprover;
 #ifdef ARRAYCHECK
@@ -216,51 +204,38 @@ LispPTR checkarrayblock(LispPTR base, LispPTR free, LispPTR onfreelist) {
   if (*Array_Block_Checking_word != NIL)
 #endif
   {
-    base_np = (struct arrayblock *)NativeAligned4FromLAddr(base);
+    bbase = (struct arrayblock *)NativeAligned4FromLAddr(base);
-    trailer_np = (struct arrayblock *)NativeAligned4FromLAddr(Trailer(base, base_np));
+    btrailer = (struct arrayblock *)NativeAligned4FromLAddr(Trailer(base, bbase));
-#if 0
+    if (bbase->password != ARRAYBLOCKPASSWORD) {
-    printf("cblock: 0x%x free: %x onfreelist: %x pw: %x arlen %d\n",
-           base, free, onfreelist, base_np->password, base_np->arlen);
-#endif
-    if (base_np->password != ARRAYBLOCKPASSWORD) {
       printarrayblock(base);
       error("ARRAYBLOCK password wrong\n");
-      return(T);
+    } else if (bbase->inuse == free) {
-    } else if (base_np->inuse == free) {
       printarrayblock(base);
       error("ARRAYBLOCK INUSE bit set wrong\n");
-      return(T);
+    } else if (btrailer->password != ARRAYBLOCKPASSWORD) {
-    } else if (trailer_np->password != ARRAYBLOCKPASSWORD) {
       printarrayblock(base);
       error("ARRAYBLOCK trailer password wrong\n");
-      return(T);
+    } else if (bbase->arlen != btrailer->arlen) {
-    } else if (base_np->arlen != trailer_np->arlen) {
       printarrayblock(base);
       error("ARRAYBLOCK Header and Trailer length don't match\n");
-      return(T);
+    } else if (btrailer->inuse == free)
-    } else if (trailer_np->inuse == free)
     /* This is not original source.(in original,
-       trailer_np -> base_np) maybe, this is correction. */
+       btrailer -> bbase) maybe, this is correction. */
     {
       printarrayblock(base);
       error("ARRAYBLOCK Trailer INUSE bit set wrong\n");
-      return(T);
+    } else if (!onfreelist || (bbase->arlen < MINARRAYBLOCKSIZE))
-    } else if (!onfreelist || (base_np->arlen < MINARRAYBLOCKSIZE))
       return (NIL);
     /* Remaining tests only for free list. */
-    fwd_np = (struct arrayblock *)NativeAligned4FromLAddr(base_np->fwd);
+    bfwd = (struct arrayblock *)NativeAligned4FromLAddr(bbase->fwd);
-    bkwd_np = (struct arrayblock *)NativeAligned4FromLAddr(base_np->bkwd);
+    bbwd = (struct arrayblock *)NativeAligned4FromLAddr(bbase->bkwd);
-    if ((bkwd_np->fwd != base) || (fwd_np->bkwd != base)) {
+    if ((bbwd->fwd != base) || (bfwd->bkwd != base)) {
       error("ARRAYBLOCK links fouled\n");
-      return(T);
     } else {
-      fbl = FreeBlockChainN(base_np->arlen);
+      fbl = FreeBlockChainN(bbase->arlen);
       rover = tmprover = (LispPTR *)NativeAligned4FromLAddr(fbl);
       /* GETBASEPTR */
-      if ((*rover & POINTERMASK) == NIL) {
+      if ((*rover & POINTERMASK) == NIL) error("Free Block's bucket empty\n");
-        error("Free Block's bucket empty\n");
-        return(T);
-      }
       do {
         if ((*rover & POINTERMASK) == base) return (NIL);
         checkarrayblock((*rover & POINTERMASK), T, NIL);
@@ -279,38 +254,32 @@ LispPTR checkarrayblock(LispPTR base, LispPTR free, LispPTR onfreelist) {
 /*									*/
 /*									*/
 /************************************************************************/
-/*
+
- * Removes "base", a block from the free list and
+LispPTR deleteblock(LispPTR base) {
- * adjusts the forward and backward pointers of the blocks behind and
+  struct arrayblock *bbase, *fbbase, *bbbase;
- * ahead of the deleted block.
+  LispPTR fwd, bkwd, fbl, freeblocklsp;
- * The forward and backward pointers of this deleted block are left
+  LispPTR *freeblock;
- * dangling - as in the Lisp implementation. Also does not affect the
+  bbase = (struct arrayblock *)NativeAligned4FromLAddr(base);
- * inuse bit in header and trailer.
+  if ((bbase->arlen >= MINARRAYBLOCKSIZE) && (bbase->fwd != NIL)) {
- */
+    fwd = bbase->fwd;
-static void deleteblock(LispPTR base) {
+    fbbase = (struct arrayblock *)NativeAligned4FromLAddr(fwd);
-  struct arrayblock *base_np, *f_np, *b_np;
+    bkwd = bbase->bkwd;
-  LispPTR f, b, fbl, freeblock;
+    bbbase = (struct arrayblock *)NativeAligned4FromLAddr(bkwd);
-  LispPTR *fbl_np;
+    fbl = FreeBlockChainN(bbase->arlen);
-  base_np = (struct arrayblock *)NativeAligned4FromLAddr(base);
+    freeblock = (LispPTR *)NativeAligned4FromLAddr(fbl);
-  if ((base_np->arlen >= MINARRAYBLOCKSIZE) && (base_np->fwd != NIL)) {
+    freeblocklsp = POINTERMASK & *freeblock;
-    f = base_np->fwd;
+    if (base == fwd) {
-    f_np = (struct arrayblock *)NativeAligned4FromLAddr(f);
+      if (base == freeblocklsp)
-    b = base_np->bkwd;
+        *freeblock = NIL;
-    b_np = (struct arrayblock *)NativeAligned4FromLAddr(b);
-    fbl = FreeBlockChainN(base_np->arlen);
-    fbl_np = (LispPTR *)NativeAligned4FromLAddr(fbl);
-    freeblock = POINTERMASK & *fbl_np;
-    if (base == f) {
-      if (base == freeblock)
-        *fbl_np = NIL;
       else
         error("GC error:deleting last list # FREEBLOCKLIST\n");
-      return;
+      return (NIL);
-    } else if (base == freeblock)
+    } else if (base == freeblocklsp)
-      *fbl_np = f;
+      *freeblock = fwd;
-    f_np->bkwd = b;
+    fbbase->bkwd = bkwd;
-    b_np->fwd = f;
+    bbbase->fwd = fwd;
   }
+  return (NIL);
 }
 
 /************************************************************************/
@@ -320,53 +289,34 @@ static void deleteblock(LispPTR base) {
 /*									*/
 /*									*/
 /************************************************************************/
-/*
- * Links a block onto the free list for a particular size range.
- * The free list is maintained as a doubly linked circular list accessed
- * from the block pointed to by the free list bucket for the size.
- * If there are no blocks in the free list bucket then the forward and
- * backward pointers of the newly added block point to the block itself.
- */
-static LispPTR linkblock(LispPTR base) {
-  struct arrayblock *base_np, *freeblock_np, *tail_np;
-  LispPTR fbl, freeblock;
-  LispPTR *fbl_np;
 
-  if (*FreeBlockBuckets_word == NIL)
+LispPTR linkblock(LispPTR base) {
-    return (base);
+  struct arrayblock *bbase, *fbbase, *tmpbase;
-
+  LispPTR fbl, freeblocklsp;
-  base_np = (struct arrayblock *)NativeAligned4FromLAddr(base);
+  LispPTR *freeblock;
-  if (base_np->arlen < MINARRAYBLOCKSIZE) {
+  if (*FreeBlockBuckets_word != NIL) {
+    bbase = (struct arrayblock *)NativeAligned4FromLAddr(base);
+    if (bbase->arlen < MINARRAYBLOCKSIZE)
       checkarrayblock(base, T, NIL);
-    return (base);
+    else {
-  }
+      fbl = FreeBlockChainN(bbase->arlen);
-
+      freeblock = (LispPTR *)NativeAligned4FromLAddr(POINTERMASK & fbl);
-  /* lisp pointer to bucket for size */
+      freeblocklsp = POINTERMASK & (*freeblock);
-  fbl = FreeBlockChainN(base_np->arlen);
+      if (freeblocklsp == NIL) {
-  /* native pointer to bucket */
+        bbase->fwd = base;
-  fbl_np = (LispPTR *)NativeAligned4FromLAddr(POINTERMASK & fbl);
+        bbase->bkwd = base;
-  /* lisp pointer to first free block on chain */
-  freeblock = POINTERMASK & (*fbl_np);
-  if (freeblock == NIL) { /* no blocks already in chain */
-    base_np->fwd = base;
-    base_np->bkwd = base;
       } else {
-    /* set up new block to be first free block on the chain */
+        fbbase = (struct arrayblock *)NativeAligned4FromLAddr(freeblocklsp);
-    freeblock_np = (struct arrayblock *)NativeAligned4FromLAddr(freeblock);
+        bbase->fwd = freeblocklsp;
-    /* link new block forward to free block */
+        bbase->bkwd = fbbase->bkwd;
-    base_np->fwd = freeblock;
+        tmpbase = (struct arrayblock *)NativeAligned4FromLAddr(fbbase->bkwd);
-    /* new block's backward link becomes free block's backward link  */
+        tmpbase->fwd = base;
-    base_np->bkwd = freeblock_np->bkwd;
+        fbbase->bkwd = base;
-    /* get the tail location (backward pointer of freelist head) */
+      }
-    tail_np = (struct arrayblock *)NativeAligned4FromLAddr(freeblock_np->bkwd);
+      *freeblock = base;
-    /* set its forward pointer to new block */
+      checkarrayblock(base, T, T);
-    tail_np->fwd = base;
+    }
-    /* and the update the free block's backward link to new block */
-    freeblock_np->bkwd = base;
   }
-  /* new block becomes the head of the free list */
-  *fbl_np = base;
-  checkarrayblock(base, T, T); /* free, and on free list */
   return (base);
 }
 
@@ -380,26 +330,17 @@ static LispPTR linkblock(LispPTR base) {
 
 LispPTR makefreearrayblock(LispPTR block, DLword length) {
   LispPTR trailer;
-  struct arrayblock *block_np, *trailer_np;
+  struct arrayblock *bbase;
-  struct abdum *flags_np;
+  struct abdum *dbase;
-  block_np = (struct arrayblock *)NativeAligned4FromLAddr(block);
+  bbase = (struct arrayblock *)NativeAligned4FromLAddr(block);
-  /* this is an appropriate place to test whether the block that
+  dbase = (struct abdum *)WORDPTR(bbase);
-     is about to be freed contains words that look like valid
+  dbase->abflags = FREEARRAYFLAGWORD;
-     array header/trailer pairs as data.  This may result in
+  bbase->arlen = length;
-     false positives, but could help if there's a real smash happening.
+  trailer = Trailer(block, bbase);
-  */
+  bbase = (struct arrayblock *)NativeAligned4FromLAddr(trailer);
-  /* struct abdum's abflags is a DLword and does not account for
+  dbase = (struct abdum *)WORDPTR(bbase);
-     the BYTESWAP setup (as arrayblock does), so use WORDPTR to
+  dbase->abflags = FREEARRAYFLAGWORD;
-     pick the correct word of the cell
+  bbase->arlen = length;
-  */
-  flags_np = (struct abdum *)WORDPTR(block_np);
-  flags_np->abflags = FREEARRAYFLAGWORD;
-  block_np->arlen = length;
-  trailer = Trailer(block, block_np);
-  trailer_np = (struct arrayblock *)NativeAligned4FromLAddr(trailer);
-  flags_np = (struct abdum *)WORDPTR(trailer_np);
-  flags_np->abflags = FREEARRAYFLAGWORD;
-  trailer_np->arlen = length;
   return (block);
 }
 
@@ -410,13 +351,13 @@ LispPTR makefreearrayblock(LispPTR block, DLword length) {
 /*									*/
 /*									*/
 /************************************************************************/
-static LispPTR arrayblockmerger(LispPTR base, LispPTR nbase) {
+LispPTR arrayblockmerger(LispPTR base, LispPTR nbase) {
   DLword arlens, narlens, secondbite, minblocksize, shaveback;
-  struct arrayblock *base_np, *nbase_np;
+  struct arrayblock *bbase, *bnbase;
-  base_np = (struct arrayblock *)NativeAligned4FromLAddr(base);
+  bbase = (struct arrayblock *)NativeAligned4FromLAddr(base);
-  nbase_np = (struct arrayblock *)NativeAligned4FromLAddr(nbase);
+  bnbase = (struct arrayblock *)NativeAligned4FromLAddr(nbase);
-  arlens = base_np->arlen;
+  arlens = bbase->arlen;
-  narlens = nbase_np->arlen;
+  narlens = bnbase->arlen;
   secondbite = MAXARRAYBLOCKSIZE - arlens;
   /* There are three cases for merging the blocks
    * (1) the total size of the two blocks is less than max:
@@ -426,7 +367,7 @@ static LispPTR arrayblockmerger(LispPTR base, LispPTR nbase) {
    * (3) creating a max size block leaves a non-viable leftover block
    *     move the boundary to make a big block and a minimum size leftover block
    */
-  if (base + (DLWORDSPER_CELL * arlens) != nbase) {
+  if (base + (2 * arlens) != nbase) {
     error("Attempt to merge non-adjacent blocks in array space\n");
   }
   if (narlens > secondbite) { /* (2) or (3) */
@@ -440,7 +381,7 @@ static LispPTR arrayblockmerger(LispPTR base, LispPTR nbase) {
       arlens += shaveback;
       secondbite += shaveback;
     }
-    linkblock(makefreearrayblock(nbase + DLWORDSPER_CELL * secondbite, narlens));
+    linkblock(makefreearrayblock(nbase + 2 * secondbite, narlens));
     narlens = 0;
   }
   return (linkblock(makefreearrayblock(base, arlens + narlens)));
@@ -454,34 +395,18 @@ static LispPTR arrayblockmerger(LispPTR base, LispPTR nbase) {
 /*									*/
 /************************************************************************/
 
-/*
- * merges this block into the block behind it, unless there are
- * disqualifying conditions:
- *     merging is turned off or
- *     this is the first block in array space or
- *     this is the first block in the 2nd array space or
- *     the block behind it is in use
- * in which case it is linked onto the freelist (fwd and backward pointers)
- * and added to the free block chain by size.
- * If it can be merged, 
- */
 LispPTR mergebackward(LispPTR base) {
   LispPTR pbase;
-  struct arrayblock *ptrailer_np;
+  struct arrayblock *ptrailer;
 
   if (base == NIL)
     return (NIL);
-  /* back up to get the trailer of the previous block */
+  ptrailer = (struct arrayblock *)NativeAligned4FromLAddr(base - ARRAYBLOCKTRAILERWORDS);
-  ptrailer_np = (struct arrayblock *)NativeAligned4FromLAddr(base - ARRAYBLOCKTRAILERWORDS);
-  /* check that there are no disqualifying conditions for merging with previous block */
   if ((*ArrayMerging_word == NIL) ||
-           ((base == *ArraySpace_word) || ((base == *ArraySpace2_word) || (ptrailer_np->inuse == T))))
+           ((base == *ArraySpace_word) || ((base == *ArraySpace2_word) || (ptrailer->inuse == T))))
     return (linkblock(base));
-  /* back up to the header of the previous block */
+  pbase = base - 2 * ptrailer->arlen;
-  pbase = base - DLWORDSPER_CELL * ptrailer_np->arlen;
-  /* check that it is free, but skip free list checks */
   checkarrayblock(pbase, T, NIL);
-  /* remove it from the free list */
   deleteblock(pbase);
   return (arrayblockmerger(pbase, base));
 }
@@ -496,17 +421,17 @@ LispPTR mergebackward(LispPTR base) {
 
 LispPTR mergeforward(LispPTR base) {
   LispPTR nbase, nbinuse;
-  struct arrayblock *base_np, *nbase_np;
+  struct arrayblock *bbase, *bnbase;
   if (*ArrayMerging_word == NIL) return NIL;
   if (base == NIL) return NIL;
   if (checkarrayblock(base, T, T)) return NIL;
 
-  base_np = (struct arrayblock *)NativeAligned4FromLAddr(base);
+  bbase = (struct arrayblock *)NativeAligned4FromLAddr(base);
-  nbase = base + DLWORDSPER_CELL * (base_np->arlen);
+  nbase = base + 2 * (bbase->arlen);
   if (nbase == *ArrayFrLst_word || nbase == *ArrayFrLst2_word) return NIL;
 
-  nbase_np = (struct arrayblock *)NativeAligned4FromLAddr(nbase);
+  bnbase = (struct arrayblock *)NativeAligned4FromLAddr(nbase);
-  nbinuse = nbase_np->inuse;
+  nbinuse = bnbase->inuse;
   if (checkarrayblock(nbase, !nbinuse, NIL)) return NIL;
   if (nbinuse) return (NIL);
   deleteblock(nbase);
@@ -521,13 +446,10 @@ LispPTR mergeforward(LispPTR base) {
 /*	Reclaim a block of storage in the array-space heap.		*/
 /*									*/
 /************************************************************************/
-/*
+
- * The pointer passed is to the data of the block, not the array block
- * header.
- */
 LispPTR reclaimarrayblock(LispPTR ptr) {
   LispPTR tmpptr, btrailer;
-  struct arrayblock *base_np;
+  struct arrayblock *base;
   LispPTR *tmpp;
   int reclaim_p;
 
@@ -536,7 +458,7 @@ LispPTR reclaimarrayblock(LispPTR ptr) {
   checkarrayblock(ptr - ARRAYBLOCKHEADERWORDS, NIL, NIL);
 #endif /* ARRAYCHECK */
 
-  base_np = (struct arrayblock *)NativeAligned4FromLAddr(ptr - ARRAYBLOCKHEADERWORDS);
+  base = (struct arrayblock *)NativeAligned4FromLAddr(ptr - ARRAYBLOCKHEADERWORDS);
 #ifdef ARRAYCHECK
   if (HILOC(ptr) < FIRSTARRAYSEGMENT) {
     printarrayblock(ptr - ARRAYBLOCKHEADERWORDS);
@@ -544,11 +466,11 @@ LispPTR reclaimarrayblock(LispPTR ptr) {
         "Bad array block reclaimed [not in array space].\nContinue with 'q' but save state ASAP. "
         "\n");
     return (T);
-  } else if (ARRAYBLOCKPASSWORD != base_np->password) {
+  } else if (ARRAYBLOCKPASSWORD != base->password) {
     printarrayblock(ptr - ARRAYBLOCKHEADERWORDS);
     error("Bad array block reclaimed [password wrong].\nContinue with 'q' but save state ASAP. \n");
     return (T);
-  } else if (base_np->inuse == NIL) {
+  } else if (base->inuse == NIL) {
     printarrayblock(ptr - ARRAYBLOCKHEADERWORDS);
     error(
         "Bad array block reclaimed [block not in use].\nContinue with 'q' but save state ASAP. \n");
@@ -557,15 +479,15 @@ LispPTR reclaimarrayblock(LispPTR ptr) {
 #else
   /* Normal case, just tell the guy something's wrong: */
   if ((HILOC(ptr) < FIRSTARRAYSEGMENT) ||
-      ((ARRAYBLOCKPASSWORD != base_np->password) || (base_np->inuse == NIL))) {
+      ((ARRAYBLOCKPASSWORD != base->password) || (base->inuse == NIL))) {
     error("Bad array block reclaimed--continue with 'q' but save state ASAP. \n");
     return (T);
   }
 #endif /* ARRAYCHECK */
 
-  switch (base_np->gctype) {
+  switch (base->gctype) {
     case PTRBLOCK_GCT: {
-      btrailer = (ptr - 2) + DLWORDSPER_CELL * (base_np->arlen - ARRAYBLOCKTRAILERCELLS);
+      btrailer = (ptr - 2) + 2 * (base->arlen - ARRAYBLOCKTRAILERCELLS);
       tmpptr = ptr;
       do {
         tmpp = (LispPTR *)NativeAligned4FromLAddr(tmpptr);
@@ -582,7 +504,7 @@ LispPTR reclaimarrayblock(LispPTR ptr) {
       /* default:   No Action */
   }
   if (reclaim_p == T)
-    mergeforward(mergebackward(makefreearrayblock(ptr - ARRAYBLOCKHEADERWORDS, base_np->arlen)));
+    mergeforward(mergebackward(makefreearrayblock(ptr - ARRAYBLOCKHEADERWORDS, base->arlen)));
   return (T);
 }
 
@@ -614,62 +536,31 @@ LispPTR reclaimstackp(LispPTR ptr) /* This is the entry function */
 /************************************************************************/
 
 void printarrayblock(LispPTR base) {
-  struct arrayblock *base_np, *trailer_np, *ptrailer_np;
+  struct arrayblock *bbase, *btrailer, *ptrailer;
   LispPTR *addr;
+
   LispPTR pbase, nbase;
 
-  base_np = (struct arrayblock *)NativeAligned4FromLAddr(base);
+  bbase = (struct arrayblock *)NativeAligned4FromLAddr(base);
-  trailer_np = (struct arrayblock *)NativeAligned4FromLAddr(Trailer(base, base_np));
+  btrailer = (struct arrayblock *)NativeAligned4FromLAddr(Trailer(base, bbase));
-  ptrailer_np = (struct arrayblock *)NativeAligned4FromLAddr(base - ARRAYBLOCKTRAILERWORDS);
+  ptrailer = (struct arrayblock *)NativeAligned4FromLAddr(base - ARRAYBLOCKTRAILERWORDS);
 
-  nbase = base + DLWORDSPER_CELL * base_np->arlen;
+  nbase = base + 2 * bbase->arlen;
-  pbase = base - DLWORDSPER_CELL * ptrailer_np->arlen;
+  pbase = base - 2 * ptrailer->arlen;
 
   printf("This array block: 0x%x.  Previous: 0x%x.  Next: 0x%x.\n", base, pbase, nbase);
-  printf("        password: 0x%x     gctype: 0x%x   in use: %d\n", base_np->password,
+  printf("          Length: %d cells.\n\n", bbase->arlen);
-         base_np->gctype, base_np->inuse);
-  if (!base_np->inuse)
-    printf("      Free list: fwd 0x%x bkwd 0x%x\n", base_np->fwd, base_np->bkwd);
-  printf("  Header  Length: %d cells.\n\n", base_np->arlen);
-  printf(" Trailer  Length: %d cells.\n\n", trailer_np->arlen);
 
-  addr = ((LispPTR *)base_np) - 20;
+  addr = ((LispPTR *)bbase) - 20;
-  for (; addr < (LispPTR *)base_np; addr++) printf("%16p (0x%8x) %8x\n", (void *)addr, LAddrFromNative(addr), *addr);
+  for (; addr < (LispPTR *)bbase; addr++) printf("%16p %8x\n", (void *)addr, *addr);
-  printf("%16p (0x%8x) %8x <- array header\n", (void *)addr, LAddrFromNative(addr), *addr);
+  printf("%16p %8x <- array header\n", (void *)addr, *addr);
   addr++;
-  for (; addr < (LispPTR *)base_np + 20; addr++) printf("%16p (0x%8x) %8x\n", (void *)addr, LAddrFromNative(addr), *addr);
+  for (; addr < (LispPTR *)bbase + 20; addr++) printf("%16p %8x\n", (void *)addr, *addr);
   printf(". . .\n");
 
-  addr = ((LispPTR *)trailer_np) - 20;
+  addr = ((LispPTR *)btrailer) - 20;
-  for (; addr < (LispPTR *)trailer_np; addr++) printf("%16p (0x%8x) %8x\n", (void *)addr, LAddrFromNative(addr), *addr);
+  for (; addr < (LispPTR *)btrailer; addr++) printf("%16p %8x\n", (void *)addr, *addr);
-  printf("%16p (0x%8x) %8x <- array trailer\n", (void *)addr, LAddrFromNative(addr), *addr);
+  printf("%16p %8x <- array trailer\n", (void *)addr, *addr);
   addr++;
-  for (; addr < (LispPTR *)trailer_np + 20; addr++) printf("%16p (0x%8x) %8x\n", (void *)addr, LAddrFromNative(addr), *addr);
+  for (; addr < (LispPTR *)btrailer + 20; addr++) printf("%16p %8x\n", (void *)addr, *addr);
-}
-
-static void printfreeblockchainhead(int index)
-{
-  LispPTR fbl, freeblock;
-  LispPTR *fbl_np;
-
-  fbl = POINTERMASK & ((*FreeBlockBuckets_word) + (DLWORDSPER_CELL * index));
-  fbl_np = (LispPTR *)NativeAligned4FromLAddr(fbl);
-  /* lisp pointer to free block on chain */
-  freeblock = POINTERMASK & (*fbl_np);
-  if (freeblock == NIL) { /* no blocks in chain */
-    printf("Free block chain (bucket %d): NIL\n", index);
-  } else {
-    printf("Free block chain(bucket %d): 0x%x\n", index, freeblock);
-  }
-}
-
-void printfreeblockchainn(int arlen)
-{
-  if (arlen >= 0) {
-    printfreeblockchainhead(BucketIndex(arlen));
-    return;
-  } else
-    for (int i = 0; i <= MAXBUCKETINDEX; i++) {
-      printfreeblockchainhead(i);
-    }
 }

src/initkbd.c

@@ -71,6 +71,8 @@ extern DspInterface currentdsp;
 extern int LispKbdFd;
 int LispKbdFd = -1;
 
+extern int runtime_debug_level;
+
 extern fd_set LispReadFds;
 
 extern DLword *EmMouseX68K;
@@ -375,6 +377,20 @@ static u_char *make_X_keymap(void) {
     table[xcode - 7] = code;
   }
 
+  if (runtime_debug_level > 0) {
+    printf("*********************************************************************\n");
+    printf("(DEFINE-FILE-INFO \036PACKAGE \"INTERLISP\" \036READTABLE \"XCL\" \036 BASE 10)\n");
+    printf("(SETQ XGetKeyboardMappingTable '(\n");
+    for (i = 0; i < codecount * symspercode; i += symspercode) {
+      printf("(%d (", minkey + (i / symspercode));
+      for (int j = 0; j < symspercode; j++) {
+        printf("    #X%lx", (unsigned long)mapping[i+j]);
+      }
+      printf(" ))\n");
+    }
+    printf("\n))\nSTOP\n");
+    printf("*********************************************************************\n");
+  }
 #ifdef DEBUG
   printf("\n\n\tXGetKeyboardMapping table\n\n");
   for (i = 0; i < codecount * symspercode; i += symspercode) {

src/main.c

@@ -226,6 +226,8 @@ int save_argc;
 char **save_argv;
 int display_max = 65536 * 16 * 2;
 
+long runtime_debug_level = 0;
+
 /* diagnostic flag for sysout dumping */
 extern unsigned maxpages;
 
@@ -345,6 +347,7 @@ int main(int argc, char *argv[])
 {
   int i;
   char *envname;
+  char *rtdebug;
   extern int TIMER_INTERVAL;
   extern fd_set LispReadFds;
   long tmpint;
@@ -677,6 +680,14 @@ int main(int argc, char *argv[])
   //
   //
 
+  if ((rtdebug = getenv("LDERUNTIMEDEBUG")) != NULL) {
+      errno = 0;
+      runtime_debug_level = strtol(rtdebug, (char **)NULL, 10);
+      if (errno != 0) {
+        runtime_debug_level = 0; // default to OFF if erroneous value
+    }
+  }
+  
 
 /* Sanity checks. */
 #ifdef DOS

src/uraid.c

@@ -168,7 +168,6 @@ static const char *URaid_summary2 =
     "\n-- Memory display commands\n\
 a litatom\t\tDisplays the top-level value of the litatom\n\
 B Xaddress\t\tPrint the contents of the arrayblock at that address.\n\
-F [size]\t\tPrint the head of the array free list chain for given size, or all\n\
 d litatom\t\tDisplays the definition cell for the litatom\n\
 M\t\t\tDisplays TOS,CSP,PVAR,IVAR,PC\n\
 m func1 func2\t\tMOVD func1 to func2\n\
@@ -202,7 +201,6 @@ l [type]\t\tDisplays backtrace for specified type of stack. (k|m|r|g|p|u|<null>)
 \n-- Memory display commands\n\
 a litatom\t\tDisplays the top-level value of the litatom\n\
 B Xaddress\t\tDisplays the contents of the arrayblock at that address.\n\
-F [size]\t\tPrint the head of the array free list chain for given size, or all\n\
 d litatom\t\tDisplays the definition cell of the litatom\n\
 M\t\t\tDisplays TOS,CSP,PVAR,IVAR,PC\n\
 m func1 func2\t\tMoves definition of func1 to func2 (MOVD)\n\
@@ -469,26 +467,6 @@ LispPTR uraid_commands(void) {
     }
     break;
 
-    case 'F': { /* print array block free list head(s) */
-      long size;
-      if (URaid_argnum != 1 && URaid_argnum != 2) {
-        printf("FREE-BLOCK-CHAIN: F [block-size (cells)]\n");
-        return (T);
-      }
-      if (URaid_argnum == 1) {
-        size = -1;
-      } else {
-        errno = 0;
-        size = (LispPTR)strtol(URaid_arg1, &endpointer, 0);
-        if (errno != 0 || *endpointer != '\0') {
-          printf("Arg not number\n");
-          return (T);
-        }
-      }
-      printfreeblockchainn(size);
-    }
-    break;
-
     case 'd': /* DEFCELL */
       if (URaid_argnum != 2) {
         printf("GETD: d litatom\n");