Declares correct size for scratch version string storage

These are used in many places so code bloat can be reduced by using procedures.

.github/workflows/Dockerfile_maiko

@@ -18,8 +18,17 @@ COPY . ${INSTALL_LOCATION}
 # Build maiko
 RUN cd ${INSTALL_LOCATION}/bin \
     && ./makeright x cleanup \
-    && ./makeright x
-RUN cd ${INSTALL_LOCATION}/bin \
+    && ./makeright x \
     && 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,7 +224,13 @@ jobs:
           RELEASE_TAG: ${{ steps.tag.outputs.release_tag }}
         run: |
           mkdir -p /tmp/release_tars
-          for OSARCH in "linux.x86_64:linux_amd64" "linux.aarch64:linux_arm64" "linux.armv7l:linux_arm_v7" ;    \
+          for OSARCH in                                                                \
+                        "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                                                       \
@@ -246,6 +252,8 @@ 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

@@ -0,0 +1,29 @@
+# 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

@@ -0,0 +1,29 @@
+# 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

@@ -0,0 +1,25 @@
+# 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

@@ -0,0 +1,27 @@
+# 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

@@ -0,0 +1,25 @@
+# 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

@@ -0,0 +1,28 @@
+# 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 [ $? == 0 ]; then
+    if [ $? -eq 0 ]; then
 	if [ ! -z "$(git status --porcelain)" ]; then
             MAIKO_REV="$(git rev-parse --short HEAD)-dirty"
 	else

bin/osversion

@@ -8,11 +8,14 @@ case "$os" in
         *-*-solaris2*)	        echo sunos5 ;;
         alpha-dec-osf1)		echo osf1 ;;
 	*-apple-darwin*)	echo darwin ;;
-        *-*-linux*)		echo linux ;;
+        *-*-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,14 +2,10 @@
 #define GCFINALDEFS_H 1
 #include "lispemul.h" /* for LispPTR, DLword */
 void printarrayblock(LispPTR base);
-int integerlength(unsigned int n);
-LispPTR findptrsbuffer(LispPTR ptr);
+void printfreeblockchainn(int arlen);
 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];				\
+	char		lv_ver_buf[VERSIONLEN + 3];			\
 									\
 	lv_cp = pathname;						\
 	lv_vp = NULL;							\

inc/locfile.h

@@ -8,10 +8,14 @@
 /*	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 */
 
@@ -63,6 +67,9 @@
         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 */
 
 /************************************************************************/
 /*									*/
@@ -79,65 +86,65 @@
 /*									*/
 /************************************************************************/
 #ifndef BYTESWAP
-#define	LispStringToCString(Lisp, C, MaxLen)				\
-  do {									\
-    OneDArray	*lf_arrayp;						\
-    char	*lf_base, *lf_dp;						\
-    short	*lf_sbase;							\
-    size_t		 lf_length;						\
-    lf_arrayp = (OneDArray *)NativeAligned4FromLAddr(Lisp);		\
-    lf_length = min(MaxLen, lf_arrayp->fillpointer);			\
-    switch(lf_arrayp->typenumber)						\
-      {									\
-	case THIN_CHAR_TYPENUMBER:					\
-		lf_base = ((char *)(NativeAligned2FromLAddr(lf_arrayp->base)))  	\
-		       + ((int)(lf_arrayp->offset));			\
-		strncpy(C, lf_base, lf_length);				\
-		(C)[lf_length] = '\0';					\
-		break;							\
-									\
-	case FAT_CHAR_TYPENUMBER:					\
-		lf_sbase = ((short *)(NativeAligned2FromLAddr(lf_arrayp->base)))	\
-		       + ((int)(lf_arrayp->offset));			\
-                lf_dp = C;						\
-		for(size_t lf_i=0;lf_i<(lf_length);lf_i++)		\
-		  *lf_dp++ = (char)(*lf_sbase++);			\
-		*lf_dp = '\0';						\
-		break;							\
-	default:							\
-		error("LispStringToCString: Not a character array.\n");	\
-      }									\
- } while (0)
+static inline void LispStringToCString(LispPTR Lisp, char *C, size_t MaxLen)
+{
+    OneDArray	*lf_arrayp;
+    char	*lf_base, *lf_dp;
+    short	*lf_sbase;
+    size_t		 lf_length;
+    lf_arrayp = (OneDArray *)NativeAligned4FromLAddr(Lisp);
+    lf_length = min(MaxLen, lf_arrayp->fillpointer);
+    switch(lf_arrayp->typenumber)
+      {
+	case THIN_CHAR_TYPENUMBER:
+		lf_base = ((char *)(NativeAligned2FromLAddr(lf_arrayp->base)))
+		       + ((int)(lf_arrayp->offset));
+		strncpy(C, lf_base, lf_length);
+		(C)[lf_length] = '\0';
+		break;
+
+	case FAT_CHAR_TYPENUMBER:
+		lf_sbase = ((short *)(NativeAligned2FromLAddr(lf_arrayp->base)))
+		       + ((int)(lf_arrayp->offset));
+                lf_dp = C;
+		for(size_t lf_i=0;lf_i<(lf_length);lf_i++)
+		  *lf_dp++ = (char)(*lf_sbase++);
+		*lf_dp = '\0';
+		break;
+	default:
+		error("LispStringToCString: Not a character array.\n");
+      }
+}
 #else  /* BYTESWAP == T CHANGED-BY-TAKE */
-#define	LispStringToCString(Lisp, C, MaxLen)				\
-  do {									\
-    OneDArray	*lf_arrayp;						\
-    char	*lf_base, *lf_dp;						\
-    short	*lf_sbase;							\
-    size_t 	lf_length;						\
-    lf_arrayp = (OneDArray *)(NativeAligned4FromLAddr(Lisp));			\
-    lf_length = min(MaxLen, lf_arrayp->fillpointer);			\
-    switch(lf_arrayp->typenumber)						\
-      {									\
-	case THIN_CHAR_TYPENUMBER:					\
-		lf_base = ((char *)(NativeAligned2FromLAddr(lf_arrayp->base)))  	\
-		       + ((int)(lf_arrayp->offset));			\
-		StrNCpyFromLispToC(C , lf_base , lf_length );		\
-		(C)[lf_length] = '\0';					\
-		break;							\
-									\
-	case FAT_CHAR_TYPENUMBER:					\
-		lf_sbase = ((short *)(NativeAligned2FromLAddr(lf_arrayp->base)))	\
-		       + ((int)(lf_arrayp->offset));			\
-                lf_dp = C;						\
-		for(size_t lf_ii=0;lf_ii<(lf_length);lf_ii++,lf_sbase++)  \
-                    *lf_dp++ = (char)(GETWORD(lf_sbase));               \
-		*lf_dp = '\0';						\
-		break;							\
-	default:							\
-		error("LispStringToCString: Not a character array.\n");	\
-      }									\
-  } while (0)
+static inline void LispStringToCString(LispPTR Lisp, char *C, size_t MaxLen)
+{
+    OneDArray	*lf_arrayp;
+    char	*lf_base, *lf_dp;
+    short	*lf_sbase;
+    size_t 	lf_length;
+    lf_arrayp = (OneDArray *)(NativeAligned4FromLAddr(Lisp));
+    lf_length = min(MaxLen, lf_arrayp->fillpointer);
+    switch(lf_arrayp->typenumber)
+      {
+	case THIN_CHAR_TYPENUMBER:
+		lf_base = ((char *)(NativeAligned2FromLAddr(lf_arrayp->base)))
+		       + ((int)(lf_arrayp->offset));
+		StrNCpyFromLispToC(C , lf_base , lf_length );
+		(C)[lf_length] = '\0';
+		break;
+
+	case FAT_CHAR_TYPENUMBER:
+		lf_sbase = ((short *)(NativeAligned2FromLAddr(lf_arrayp->base)))
+		       + ((int)(lf_arrayp->offset));
+                lf_dp = C;
+		for(size_t lf_ii=0;lf_ii<(lf_length);lf_ii++,lf_sbase++)
+                    *lf_dp++ = (char)(GETWORD(lf_sbase));
+		*lf_dp = '\0';
+		break;
+	default:
+		error("LispStringToCString: Not a character array.\n");
+      }
+}
 
 #endif /* BYTESWAP */
 
@@ -189,10 +196,6 @@ 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) : \
@@ -293,7 +296,7 @@ do  {				\
 	goto truetag;	/* NOLINT(bugprone-macro-parentheses) */	\
   } while (0)
 
-/*		
+/*
  * Name:	LispVersionToUnixVersion
  *
  * Argument:	char	*pathname
@@ -328,17 +331,13 @@ do  {				\
 #endif /* DOS */
 
 
-/*		
+/*
  * Name:	UnixVersionToLispVersion
  *
- * Argument:	char	*pathname
- *				UNIX syntax pathname.
- *		int	vlessp
- *				If 0, versionless file is converted to version 1.
+ * Argument:	char *pathname  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:
@@ -350,67 +349,25 @@ do  {				\
  * version field will append a semicolon and it might make the routine be
  * confused.
  * The file which has not a valid version field, that is ".~##~" form, is
- * dealt with as version 1. 
+ * dealt with as version 1.
  */
 
-#define UnixVersionToLispVersion(pathname, vlessp) do {				\
-										\
-	char	*start;							\
-	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 {						\
-				lf_cp++;						\
-			}							\
-		}								\
-										\
-		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)
+#define UnixVersionToLispVersion(pathname, vlessp)                      \
+  do {                                                                  \
+    char *n_end;                                                        \
+    char *v_start;                                                      \
+    int	v_len;                                                          \
+                                                                        \
+    if (!parse_file_version(pathname, 1, &n_end, &v_start, &v_len)) {   \
+      if (!vlessp) strcat(pathname, ";1");                              \
+    } else {                                                            \
+      *n_end++ = ';';                                                   \
+      while (v_len-- > 0) *n_end++ = *v_start++;                        \
+      *n_end = '\0';                                                    \
+    }                                                                   \
+  }  while (0)
 
-/*		
+/*
  * Name:	ConcDirAndName
  *
  * Argument:	char	*dir	The name of the directory.
@@ -428,45 +385,45 @@ do  {				\
  *
  */
 
-#define ConcDirAndName(dir, name, fname) do {					\
-									\
-	char	*lf_cp1, *lf_cp2;					\
-									\
-	lf_cp1 = dir;							\
-	lf_cp2 = dir;							\
-									\
-	while (*lf_cp2 != '\0') {						\
-		switch (*lf_cp2) {						\
-									\
-		      case '/':						\
-			lf_cp1 = lf_cp2;					\
-			lf_cp2++;						\
-			break;						\
-									\
-		      default:						\
-			lf_cp2++;						\
-			break;						\
-		}							\
-	}								\
-	if (lf_cp1 == (lf_cp2 - 1)) {						\
-                if (lf_cp1 == (dir)) {					\
-			/* dir is a root directory. */			\
-			strcpy(fname, "/");				\
-			strcat(fname, name);				\
-		} else {						\
-			/* The trail directory is included. */		\
-			strcpy(fname, dir);				\
-			strcat(fname, name);				\
-		}							\
-	} else {							\
-		/* The trail directory is not included */		\
-		strcpy(fname, dir);					\
-		strcat(fname, "/");					\
-		strcat(fname, name);					\
-	}								\
-  } while (0)
+static inline void ConcDirAndName(char *dir, char *name, char *fname)
+{
+  char	*lf_cp1, *lf_cp2;
 
-/*		
+  lf_cp1 = dir;
+  lf_cp2 = dir;
+
+  while (*lf_cp2 != '\0') {
+    switch (*lf_cp2) {
+
+    case '/':
+      lf_cp1 = lf_cp2;
+      lf_cp2++;
+      break;
+
+    default:
+      lf_cp2++;
+      break;
+    }
+  }
+  if (lf_cp1 == (lf_cp2 - 1)) {
+    if (lf_cp1 == (dir)) {
+      /* dir is a root directory. */
+      strcpy(fname, "/");
+      strcat(fname, name);
+    } else {
+      /* The trail directory is included. */
+      strcpy(fname, dir);
+      strcat(fname, name);
+    }
+  } else {
+    /* The trail directory is not included */
+    strcpy(fname, dir);
+    strcat(fname, "/");
+    strcat(fname, name);
+  }
+}
+
+/*
  * Name:	ConcNameAndVersion
  *
  * Argument:	char	*name	The root file name.
@@ -481,20 +438,24 @@ do  {				\
  *
  * 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
+ *
  */
 
-#define ConcNameAndVersion(name, ver, rname) do {				\
-	if (*(ver) != '\0') {						\
-		strcpy(rname, name);					\
-		strcat(rname, ".~");					\
-		strcat(rname, ver);					\
-		strcat(rname, "~");					\
-	} else {							\
-		strcpy(rname, name);					\
-	}								\
-} while (0)
+static inline void ConcNameAndVersion(char *name, char *ver, char *rname)
+{
+	if (*ver != '\0') {
+		strcpy(rname, name);
+		strcat(rname, ".~");
+		strcat(rname, ver);
+		strcat(rname, "~");
+	} else {
+		strcpy(rname, name);
+	}
+}
 
-#define	 VERSIONLEN		16
+#define	 VERSIONLEN		10
 
 #define	MAXVERSION		999999999
 
@@ -542,7 +503,7 @@ do  {				\
 			*(lf_cp-1) = '\0';					\
 		}							\
   } while (0)
-		
+
 #define	ChangeToVersionless(pathname) do {			\
 		char	*lf_cp;			\
 		if( (lf_cp=strrchr(pathname, ';')) != 0)	\
@@ -576,9 +537,9 @@ do  {				\
 		TIMEOUT(lf_rval=rename(x, y));		\
 		if(lf_rval == -1){				\
 			switch(errno){			\
-			case 2:				\
+			case ENOENT:				\
 				return(1);		\
-			case 18:			\
+			case EXDEV:			\
 				*Lisp_errno = errno;	\
 				return(0);		\
 			default:			\
@@ -601,20 +562,78 @@ do  {				\
 /*
  * For file name length check
  */
-#define FNAMETOOLONG	200
 
-#define FileNameTooLong(val) do {				\
-	*Lisp_errno = FNAMETOOLONG;			\
+#define FileNameTooLong(val) do {			\
+	*Lisp_errno = ENAMETOOLONG;                     \
 	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,13 +38,23 @@
 #  define MAIKO_OS_DETECTED 1
 #endif
 
-#ifdef __linux__
+#if defined(__linux__) && !defined(__wsl1__)
 #  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 2000
+#define URMAXFXNUM 4096
 #define URMAXCOMM 512
 #define URSCAN_ALINK 0
 #define URSCAN_CLINK 1

src/dsk.c

@@ -3246,6 +3246,7 @@ 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
@@ -3570,6 +3571,7 @@ 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);
@@ -3578,6 +3580,7 @@ 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
@@ -3926,6 +3929,7 @@ 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
@@ -4018,6 +4022,7 @@ 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);
@@ -4081,6 +4086,7 @@ 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
@@ -4297,6 +4303,7 @@ 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,35 +99,35 @@ struct hashtable {
 LispPTR aref1(LispPTR array, int index) {
   LispPTR retval = 0;
   LispPTR base;
-  short typenumber;
-  struct arrayheader *actarray;
+  struct arrayheader *array_np;
 
-  actarray = (struct arrayheader *)NativeAligned4FromLAddr(array);
-  if (index >= actarray->totalsize) {
+  array_np = (struct arrayheader *)NativeAligned4FromLAddr(array);
+  if (index >= array_np->totalsize) {
     printf("Invalid index in GC's AREF1:  0x%x\n", index);
-    printf(" Array size limit:  0x%x\n", actarray->totalsize);
+    printf(" Array size limit:  0x%x\n", array_np->totalsize);
     printf(" Array ptr: 0x%x\n", array);
-    printf(" Array 68K ptr: %p\n", (void *)actarray);
-    printf("base:     0x%x\n", actarray->base);
-    printf("offset:   0x%x\n", actarray->offset);
-    printf("type #:   0x%x\n", actarray->typenumber);
-    printf("fill ptr: 0x%x\n", actarray->fillpointer);
+    printf(" Array native ptr: %p\n", (void *)array_np);
+    printf("base:     0x%x\n", array_np->base);
+    printf("offset:   0x%x\n", array_np->offset);
+    printf("type #:   0x%x\n", array_np->typenumber);
+    printf("fill ptr: 0x%x\n", array_np->fillpointer);
     error("index out of range in GC's AREF1.");
   }
-  index += actarray->offset;
-  typenumber = actarray->typenumber;
-  base = actarray->base;
-  switch (typenumber) {
-    case 3: /* unsigned 8bits */
-      retval = (GETBYTE(((char *)NativeAligned2FromLAddr(base)) + index)) & 0x0ff;
-      retval |= S_POSITIVE;
-      break;
-    case 4: /* unsigned 16bits */
-      retval = (GETWORD(((DLword *)NativeAligned2FromLAddr(base)) + index)) & 0x0ffff;
-      retval |= S_POSITIVE;
-      break;
-    case 38: retval = (*(((LispPTR *)NativeAligned4FromLAddr(base)) + index)); break;
-    default: error("Not Implemented in gc's aref1 (other types)");
+  index += array_np->offset;
+  base = array_np->base;
+  switch (array_np->typenumber) {
+  case 3: /* unsigned 8 bits */
+    retval = (GETBYTE(((char *)NativeAligned2FromLAddr(base)) + index)) & 0x0ff;
+    retval |= S_POSITIVE;
+    break;
+  case 4: /* unsigned 16 bits */
+    retval = (GETWORD(((DLword *)NativeAligned2FromLAddr(base)) + index)) & 0x0ffff;
+    retval |= S_POSITIVE;
+    break;
+  case 38: /* pointer 32 bits */
+    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 arrayblockmerger, checkarrayblock, deleteblock
+#include "gcfinaldefs.h"  // for checkarrayblock
 #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,13 +69,16 @@
 #endif /* NEVER */
 
 #define min(a, b) (((a) > (b)) ? (b) : (a))
-#define Trailer(ldatum, datum68) ((ldatum) + 2 * ((datum68)->arlen - ARRAYBLOCKTRAILERCELLS))
+#define Trailer(ldatum, datum68) ((ldatum) + DLWORDSPER_CELL * ((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 buf {
+struct buffer {
   LispPTR filepage;
   LispPTR vmempage;
   LispPTR buffernext;
@@ -86,7 +89,7 @@ struct buf {
   unsigned sysnext : 28;
 };
 #else
-struct buf {
+struct buffer {
   LispPTR filepage;
   LispPTR vmempage;
   LispPTR buffernext;
@@ -99,7 +102,7 @@ struct buf {
 #endif /* BIGVM */
 #else
 #ifdef BIGVM
-struct buf {
+struct buffer {
   LispPTR filepage;
   LispPTR vmempage;
   LispPTR buffernext;
@@ -110,7 +113,7 @@ struct buf {
   unsigned noreference : 1;
 };
 #else
-struct buf {
+struct buffer {
   LispPTR filepage;
   LispPTR vmempage;
   LispPTR buffernext;
@@ -123,24 +126,32 @@ struct buf {
 #endif /* BIGVM */
 #endif /* BYTESWAP */
 
-/************* The following procedure is common !! **************************/
+static int integerlength(unsigned int n) {
+  int p = 0;
 
-int integerlength(unsigned int n) {
-  int cnt;
-  if (n <= 2)
-    return (n);
-  else {
-    cnt = 1;
-    do {
-      cnt++;
-      n = (n >> 1);
-    } while (n != 1);
-    return (cnt);
+  if (n <= 2) return (n); /* easy case */
+  if (n >= 65536) {
+    n >>= 16;
+    p += 16;
   }
+  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			*/
@@ -151,14 +162,16 @@ int integerlength(unsigned int n) {
 /*									*/
 /************************************************************************/
 
-LispPTR findptrsbuffer(LispPTR ptr) {
-  struct buf *bptr;
-  bptr = (struct buf *)NativeAligned4FromLAddr(*System_Buffer_List_word);
-  while (LAddrFromNative(bptr) != NIL) {
-    if (ptr == bptr->vmempage)
-      return (LAddrFromNative(bptr));
-    else
-      bptr = (struct buf *)NativeAligned4FromLAddr(bptr->sysnext);
+static LispPTR findptrsbuffer(LispPTR ptr) {
+  LispPTR buf;
+  struct buffer *buf_np;
+  buf = *System_Buffer_List_word;
+  while (buf != NIL) {
+    buf_np = (struct buffer *)NativeAligned4FromLAddr(buf);
+    if (ptr == buf_np->vmempage) {
+      return (buf);
+    }
+    buf = buf_np->sysnext;
   }
   return (NIL);
 }
@@ -175,13 +188,13 @@ LispPTR findptrsbuffer(LispPTR ptr) {
 /************************************************************************/
 
 LispPTR releasingvmempage(LispPTR ptr) {
-  struct buf *bptr;
-  LispPTR bufferptr = findptrsbuffer(ptr);
+  LispPTR buffer = findptrsbuffer(ptr);
+  struct buffer *buffer_np;
 
-  if (bufferptr == NIL) return (NIL); /* Not in use, OK to reclaim it */
+  if (buffer == NIL) return (NIL); /* Not in use, OK to reclaim it */
 
-  bptr = (struct buf *)NativeAligned4FromLAddr(bufferptr);
-  bptr->noreference = T; /* Mark the buffer free to use ?? */
+  buffer_np = (struct buffer *)NativeAligned4FromLAddr(buffer);
+  buffer_np->noreference = T; /* Mark the buffer free to use ?? */
   return (ATOM_T);
 }
 
@@ -192,10 +205,9 @@ LispPTR releasingvmempage(LispPTR ptr) {
 /*	Given an array block, do consistency checks on it.		*/
 /*									*/
 /************************************************************************/
-
 LispPTR checkarrayblock(LispPTR base, LispPTR free, LispPTR onfreelist) {
-  struct arrayblock *bbase, *btrailer;
-  struct arrayblock *bfwd, *bbwd, *rbase;
+  struct arrayblock *base_np, *trailer_np;
+  struct arrayblock *fwd_np, *bkwd_np, *rbase;
   LispPTR fbl;
   LispPTR *rover, *tmprover;
 #ifdef ARRAYCHECK
@@ -204,38 +216,51 @@ LispPTR checkarrayblock(LispPTR base, LispPTR free, LispPTR onfreelist) {
   if (*Array_Block_Checking_word != NIL)
 #endif
   {
-    bbase = (struct arrayblock *)NativeAligned4FromLAddr(base);
-    btrailer = (struct arrayblock *)NativeAligned4FromLAddr(Trailer(base, bbase));
-    if (bbase->password != ARRAYBLOCKPASSWORD) {
+    base_np = (struct arrayblock *)NativeAligned4FromLAddr(base);
+    trailer_np = (struct arrayblock *)NativeAligned4FromLAddr(Trailer(base, base_np));
+#if 0
+    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");
-    } else if (bbase->inuse == free) {
+      return(T);
+    } else if (base_np->inuse == free) {
       printarrayblock(base);
       error("ARRAYBLOCK INUSE bit set wrong\n");
-    } else if (btrailer->password != ARRAYBLOCKPASSWORD) {
+      return(T);
+    } else if (trailer_np->password != ARRAYBLOCKPASSWORD) {
       printarrayblock(base);
       error("ARRAYBLOCK trailer password wrong\n");
-    } else if (bbase->arlen != btrailer->arlen) {
+      return(T);
+    } else if (base_np->arlen != trailer_np->arlen) {
       printarrayblock(base);
       error("ARRAYBLOCK Header and Trailer length don't match\n");
-    } else if (btrailer->inuse == free)
+      return(T);
+    } else if (trailer_np->inuse == free)
     /* This is not original source.(in original,
-       btrailer -> bbase) maybe, this is correction. */
+       trailer_np -> base_np) maybe, this is correction. */
     {
       printarrayblock(base);
       error("ARRAYBLOCK Trailer INUSE bit set wrong\n");
-    } else if (!onfreelist || (bbase->arlen < MINARRAYBLOCKSIZE))
+      return(T);
+    } else if (!onfreelist || (base_np->arlen < MINARRAYBLOCKSIZE))
       return (NIL);
     /* Remaining tests only for free list. */
-    bfwd = (struct arrayblock *)NativeAligned4FromLAddr(bbase->fwd);
-    bbwd = (struct arrayblock *)NativeAligned4FromLAddr(bbase->bkwd);
-    if ((bbwd->fwd != base) || (bfwd->bkwd != base)) {
+    fwd_np = (struct arrayblock *)NativeAligned4FromLAddr(base_np->fwd);
+    bkwd_np = (struct arrayblock *)NativeAligned4FromLAddr(base_np->bkwd);
+    if ((bkwd_np->fwd != base) || (fwd_np->bkwd != base)) {
       error("ARRAYBLOCK links fouled\n");
+      return(T);
     } else {
-      fbl = FreeBlockChainN(bbase->arlen);
+      fbl = FreeBlockChainN(base_np->arlen);
       rover = tmprover = (LispPTR *)NativeAligned4FromLAddr(fbl);
       /* GETBASEPTR */
-      if ((*rover & POINTERMASK) == NIL) error("Free Block's bucket empty\n");
+      if ((*rover & POINTERMASK) == NIL) {
+        error("Free Block's bucket empty\n");
+        return(T);
+      }
       do {
         if ((*rover & POINTERMASK) == base) return (NIL);
         checkarrayblock((*rover & POINTERMASK), T, NIL);
@@ -254,32 +279,38 @@ LispPTR checkarrayblock(LispPTR base, LispPTR free, LispPTR onfreelist) {
 /*									*/
 /*									*/
 /************************************************************************/
-
-LispPTR deleteblock(LispPTR base) {
-  struct arrayblock *bbase, *fbbase, *bbbase;
-  LispPTR fwd, bkwd, fbl, freeblocklsp;
-  LispPTR *freeblock;
-  bbase = (struct arrayblock *)NativeAligned4FromLAddr(base);
-  if ((bbase->arlen >= MINARRAYBLOCKSIZE) && (bbase->fwd != NIL)) {
-    fwd = bbase->fwd;
-    fbbase = (struct arrayblock *)NativeAligned4FromLAddr(fwd);
-    bkwd = bbase->bkwd;
-    bbbase = (struct arrayblock *)NativeAligned4FromLAddr(bkwd);
-    fbl = FreeBlockChainN(bbase->arlen);
-    freeblock = (LispPTR *)NativeAligned4FromLAddr(fbl);
-    freeblocklsp = POINTERMASK & *freeblock;
-    if (base == fwd) {
-      if (base == freeblocklsp)
-        *freeblock = NIL;
+/*
+ * Removes "base", a block from the free list and
+ * adjusts the forward and backward pointers of the blocks behind and
+ * ahead of the deleted block.
+ * The forward and backward pointers of this deleted block are left
+ * dangling - as in the Lisp implementation. Also does not affect the
+ * inuse bit in header and trailer.
+ */
+static void deleteblock(LispPTR base) {
+  struct arrayblock *base_np, *f_np, *b_np;
+  LispPTR f, b, fbl, freeblock;
+  LispPTR *fbl_np;
+  base_np = (struct arrayblock *)NativeAligned4FromLAddr(base);
+  if ((base_np->arlen >= MINARRAYBLOCKSIZE) && (base_np->fwd != NIL)) {
+    f = base_np->fwd;
+    f_np = (struct arrayblock *)NativeAligned4FromLAddr(f);
+    b = base_np->bkwd;
+    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 (NIL);
-    } else if (base == freeblocklsp)
-      *freeblock = fwd;
-    fbbase->bkwd = bkwd;
-    bbbase->fwd = fwd;
+      return;
+    } else if (base == freeblock)
+      *fbl_np = f;
+    f_np->bkwd = b;
+    b_np->fwd = f;
   }
-  return (NIL);
 }
 
 /************************************************************************/
@@ -289,34 +320,53 @@ LispPTR 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;
 
-LispPTR linkblock(LispPTR base) {
-  struct arrayblock *bbase, *fbbase, *tmpbase;
-  LispPTR fbl, freeblocklsp;
-  LispPTR *freeblock;
-  if (*FreeBlockBuckets_word != NIL) {
-    bbase = (struct arrayblock *)NativeAligned4FromLAddr(base);
-    if (bbase->arlen < MINARRAYBLOCKSIZE)
-      checkarrayblock(base, T, NIL);
-    else {
-      fbl = FreeBlockChainN(bbase->arlen);
-      freeblock = (LispPTR *)NativeAligned4FromLAddr(POINTERMASK & fbl);
-      freeblocklsp = POINTERMASK & (*freeblock);
-      if (freeblocklsp == NIL) {
-        bbase->fwd = base;
-        bbase->bkwd = base;
-      } else {
-        fbbase = (struct arrayblock *)NativeAligned4FromLAddr(freeblocklsp);
-        bbase->fwd = freeblocklsp;
-        bbase->bkwd = fbbase->bkwd;
-        tmpbase = (struct arrayblock *)NativeAligned4FromLAddr(fbbase->bkwd);
-        tmpbase->fwd = base;
-        fbbase->bkwd = base;
-      }
-      *freeblock = base;
-      checkarrayblock(base, T, T);
-    }
+  if (*FreeBlockBuckets_word == NIL)
+    return (base);
+
+  base_np = (struct arrayblock *)NativeAligned4FromLAddr(base);
+  if (base_np->arlen < MINARRAYBLOCKSIZE) {
+    checkarrayblock(base, T, NIL);
+    return (base);
   }
+
+  /* lisp pointer to bucket for size */
+  fbl = FreeBlockChainN(base_np->arlen);
+  /* native pointer to bucket */
+  fbl_np = (LispPTR *)NativeAligned4FromLAddr(POINTERMASK & fbl);
+  /* 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 */
+    freeblock_np = (struct arrayblock *)NativeAligned4FromLAddr(freeblock);
+    /* link new block forward to free block */
+    base_np->fwd = freeblock;
+    /* new block's backward link becomes free block's backward link  */
+    base_np->bkwd = freeblock_np->bkwd;
+    /* get the tail location (backward pointer of freelist head) */
+    tail_np = (struct arrayblock *)NativeAligned4FromLAddr(freeblock_np->bkwd);
+    /* set its forward pointer to new block */
+    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);
 }
 
@@ -330,17 +380,26 @@ LispPTR linkblock(LispPTR base) {
 
 LispPTR makefreearrayblock(LispPTR block, DLword length) {
   LispPTR trailer;
-  struct arrayblock *bbase;
-  struct abdum *dbase;
-  bbase = (struct arrayblock *)NativeAligned4FromLAddr(block);
-  dbase = (struct abdum *)WORDPTR(bbase);
-  dbase->abflags = FREEARRAYFLAGWORD;
-  bbase->arlen = length;
-  trailer = Trailer(block, bbase);
-  bbase = (struct arrayblock *)NativeAligned4FromLAddr(trailer);
-  dbase = (struct abdum *)WORDPTR(bbase);
-  dbase->abflags = FREEARRAYFLAGWORD;
-  bbase->arlen = length;
+  struct arrayblock *block_np, *trailer_np;
+  struct abdum *flags_np;
+  block_np = (struct arrayblock *)NativeAligned4FromLAddr(block);
+  /* this is an appropriate place to test whether the block that
+     is about to be freed contains words that look like valid
+     array header/trailer pairs as data.  This may result in
+     false positives, but could help if there's a real smash happening.
+  */
+  /* struct abdum's abflags is a DLword and does not account for
+     the BYTESWAP setup (as arrayblock does), so use WORDPTR to
+     pick the correct word of the cell
+  */
+  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);
 }
 
@@ -351,13 +410,13 @@ LispPTR makefreearrayblock(LispPTR block, DLword length) {
 /*									*/
 /*									*/
 /************************************************************************/
-LispPTR arrayblockmerger(LispPTR base, LispPTR nbase) {
+static LispPTR arrayblockmerger(LispPTR base, LispPTR nbase) {
   DLword arlens, narlens, secondbite, minblocksize, shaveback;
-  struct arrayblock *bbase, *bnbase;
-  bbase = (struct arrayblock *)NativeAligned4FromLAddr(base);
-  bnbase = (struct arrayblock *)NativeAligned4FromLAddr(nbase);
-  arlens = bbase->arlen;
-  narlens = bnbase->arlen;
+  struct arrayblock *base_np, *nbase_np;
+  base_np = (struct arrayblock *)NativeAligned4FromLAddr(base);
+  nbase_np = (struct arrayblock *)NativeAligned4FromLAddr(nbase);
+  arlens = base_np->arlen;
+  narlens = nbase_np->arlen;
   secondbite = MAXARRAYBLOCKSIZE - arlens;
   /* There are three cases for merging the blocks
    * (1) the total size of the two blocks is less than max:
@@ -367,7 +426,7 @@ 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 + (2 * arlens) != nbase) {
+  if (base + (DLWORDSPER_CELL * arlens) != nbase) {
     error("Attempt to merge non-adjacent blocks in array space\n");
   }
   if (narlens > secondbite) { /* (2) or (3) */
@@ -381,7 +440,7 @@ LispPTR arrayblockmerger(LispPTR base, LispPTR nbase) {
       arlens += shaveback;
       secondbite += shaveback;
     }
-    linkblock(makefreearrayblock(nbase + 2 * secondbite, narlens));
+    linkblock(makefreearrayblock(nbase + DLWORDSPER_CELL * secondbite, narlens));
     narlens = 0;
   }
   return (linkblock(makefreearrayblock(base, arlens + narlens)));
@@ -395,18 +454,34 @@ 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;
+  struct arrayblock *ptrailer_np;
 
   if (base == NIL)
     return (NIL);
-  ptrailer = (struct arrayblock *)NativeAligned4FromLAddr(base - ARRAYBLOCKTRAILERWORDS);
+  /* back up to get the trailer of the previous block */
+  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->inuse == T))))
+           ((base == *ArraySpace_word) || ((base == *ArraySpace2_word) || (ptrailer_np->inuse == T))))
     return (linkblock(base));
-  pbase = base - 2 * ptrailer->arlen;
+  /* back up to the header of the previous block */
+  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));
 }
@@ -421,17 +496,17 @@ LispPTR mergebackward(LispPTR base) {
 
 LispPTR mergeforward(LispPTR base) {
   LispPTR nbase, nbinuse;
-  struct arrayblock *bbase, *bnbase;
+  struct arrayblock *base_np, *nbase_np;
   if (*ArrayMerging_word == NIL) return NIL;
   if (base == NIL) return NIL;
   if (checkarrayblock(base, T, T)) return NIL;
 
-  bbase = (struct arrayblock *)NativeAligned4FromLAddr(base);
-  nbase = base + 2 * (bbase->arlen);
+  base_np = (struct arrayblock *)NativeAligned4FromLAddr(base);
+  nbase = base + DLWORDSPER_CELL * (base_np->arlen);
   if (nbase == *ArrayFrLst_word || nbase == *ArrayFrLst2_word) return NIL;
 
-  bnbase = (struct arrayblock *)NativeAligned4FromLAddr(nbase);
-  nbinuse = bnbase->inuse;
+  nbase_np = (struct arrayblock *)NativeAligned4FromLAddr(nbase);
+  nbinuse = nbase_np->inuse;
   if (checkarrayblock(nbase, !nbinuse, NIL)) return NIL;
   if (nbinuse) return (NIL);
   deleteblock(nbase);
@@ -446,10 +521,13 @@ 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;
+  struct arrayblock *base_np;
   LispPTR *tmpp;
   int reclaim_p;
 
@@ -458,7 +536,7 @@ LispPTR reclaimarrayblock(LispPTR ptr) {
   checkarrayblock(ptr - ARRAYBLOCKHEADERWORDS, NIL, NIL);
 #endif /* ARRAYCHECK */
 
-  base = (struct arrayblock *)NativeAligned4FromLAddr(ptr - ARRAYBLOCKHEADERWORDS);
+  base_np = (struct arrayblock *)NativeAligned4FromLAddr(ptr - ARRAYBLOCKHEADERWORDS);
 #ifdef ARRAYCHECK
   if (HILOC(ptr) < FIRSTARRAYSEGMENT) {
     printarrayblock(ptr - ARRAYBLOCKHEADERWORDS);
@@ -466,11 +544,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->password) {
+  } else if (ARRAYBLOCKPASSWORD != base_np->password) {
     printarrayblock(ptr - ARRAYBLOCKHEADERWORDS);
     error("Bad array block reclaimed [password wrong].\nContinue with 'q' but save state ASAP. \n");
     return (T);
-  } else if (base->inuse == NIL) {
+  } else if (base_np->inuse == NIL) {
     printarrayblock(ptr - ARRAYBLOCKHEADERWORDS);
     error(
         "Bad array block reclaimed [block not in use].\nContinue with 'q' but save state ASAP. \n");
@@ -479,15 +557,15 @@ LispPTR reclaimarrayblock(LispPTR ptr) {
 #else
   /* Normal case, just tell the guy something's wrong: */
   if ((HILOC(ptr) < FIRSTARRAYSEGMENT) ||
-      ((ARRAYBLOCKPASSWORD != base->password) || (base->inuse == NIL))) {
+      ((ARRAYBLOCKPASSWORD != base_np->password) || (base_np->inuse == NIL))) {
     error("Bad array block reclaimed--continue with 'q' but save state ASAP. \n");
     return (T);
   }
 #endif /* ARRAYCHECK */
 
-  switch (base->gctype) {
+  switch (base_np->gctype) {
     case PTRBLOCK_GCT: {
-      btrailer = (ptr - 2) + 2 * (base->arlen - ARRAYBLOCKTRAILERCELLS);
+      btrailer = (ptr - 2) + DLWORDSPER_CELL * (base_np->arlen - ARRAYBLOCKTRAILERCELLS);
       tmpptr = ptr;
       do {
         tmpp = (LispPTR *)NativeAligned4FromLAddr(tmpptr);
@@ -504,7 +582,7 @@ LispPTR reclaimarrayblock(LispPTR ptr) {
       /* default:   No Action */
   }
   if (reclaim_p == T)
-    mergeforward(mergebackward(makefreearrayblock(ptr - ARRAYBLOCKHEADERWORDS, base->arlen)));
+    mergeforward(mergebackward(makefreearrayblock(ptr - ARRAYBLOCKHEADERWORDS, base_np->arlen)));
   return (T);
 }
 
@@ -536,31 +614,62 @@ LispPTR reclaimstackp(LispPTR ptr) /* This is the entry function */
 /************************************************************************/
 
 void printarrayblock(LispPTR base) {
-  struct arrayblock *bbase, *btrailer, *ptrailer;
+  struct arrayblock *base_np, *trailer_np, *ptrailer_np;
   LispPTR *addr;
-
   LispPTR pbase, nbase;
 
-  bbase = (struct arrayblock *)NativeAligned4FromLAddr(base);
-  btrailer = (struct arrayblock *)NativeAligned4FromLAddr(Trailer(base, bbase));
-  ptrailer = (struct arrayblock *)NativeAligned4FromLAddr(base - ARRAYBLOCKTRAILERWORDS);
+  base_np = (struct arrayblock *)NativeAligned4FromLAddr(base);
+  trailer_np = (struct arrayblock *)NativeAligned4FromLAddr(Trailer(base, base_np));
+  ptrailer_np = (struct arrayblock *)NativeAligned4FromLAddr(base - ARRAYBLOCKTRAILERWORDS);
 
-  nbase = base + 2 * bbase->arlen;
-  pbase = base - 2 * ptrailer->arlen;
+  nbase = base + DLWORDSPER_CELL * base_np->arlen;
+  pbase = base - DLWORDSPER_CELL * ptrailer_np->arlen;
 
   printf("This array block: 0x%x.  Previous: 0x%x.  Next: 0x%x.\n", base, pbase, nbase);
-  printf("          Length: %d cells.\n\n", bbase->arlen);
+  printf("        password: 0x%x     gctype: 0x%x   in use: %d\n", base_np->password,
+         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 *)bbase) - 20;
-  for (; addr < (LispPTR *)bbase; addr++) printf("%16p %8x\n", (void *)addr, *addr);
-  printf("%16p %8x <- array header\n", (void *)addr, *addr);
+  addr = ((LispPTR *)base_np) - 20;
+  for (; addr < (LispPTR *)base_np; addr++) printf("%16p (0x%8x) %8x\n", (void *)addr, LAddrFromNative(addr), *addr);
+  printf("%16p (0x%8x) %8x <- array header\n", (void *)addr, LAddrFromNative(addr), *addr);
   addr++;
-  for (; addr < (LispPTR *)bbase + 20; addr++) printf("%16p %8x\n", (void *)addr, *addr);
+  for (; addr < (LispPTR *)base_np + 20; addr++) printf("%16p (0x%8x) %8x\n", (void *)addr, LAddrFromNative(addr), *addr);
   printf(". . .\n");
 
-  addr = ((LispPTR *)btrailer) - 20;
-  for (; addr < (LispPTR *)btrailer; addr++) printf("%16p %8x\n", (void *)addr, *addr);
-  printf("%16p %8x <- array trailer\n", (void *)addr, *addr);
+  addr = ((LispPTR *)trailer_np) - 20;
+  for (; addr < (LispPTR *)trailer_np; addr++) printf("%16p (0x%8x) %8x\n", (void *)addr, LAddrFromNative(addr), *addr);
+  printf("%16p (0x%8x) %8x <- array trailer\n", (void *)addr, LAddrFromNative(addr), *addr);
   addr++;
-  for (; addr < (LispPTR *)btrailer + 20; addr++) printf("%16p %8x\n", (void *)addr, *addr);
+  for (; addr < (LispPTR *)trailer_np + 20; addr++) printf("%16p (0x%8x) %8x\n", (void *)addr, LAddrFromNative(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/uraid.c

@@ -168,6 +168,7 @@ 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\
@@ -201,6 +202,7 @@ 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\
@@ -467,6 +469,26 @@ 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");