From f2bf026b07c92aa96f97aa8b719e9ea0b9a0721e Mon Sep 17 00:00:00 2001
From: Nick Briggs <nicholas.h.briggs@gmail.com>
Date: Sat, 19 Jul 2025 17:50:55 -0700
Subject: [PATCH] Adds URaid F command to print array block free list heads

---
 inc/gcfinaldefs.h |  1 +
 src/gcfinal.c     | 27 +++++++++++++++++++++++++++
 src/uraid.c       | 22 ++++++++++++++++++++++
 3 files changed, 50 insertions(+)

diff --git a/inc/gcfinaldefs.h b/inc/gcfinaldefs.h
index 198b9bf..26d409f 100644
--- a/inc/gcfinaldefs.h
+++ b/inc/gcfinaldefs.h
@@ -2,6 +2,7 @@
 #define GCFINALDEFS_H 1
 #include "lispemul.h" /* for LispPTR, DLword */
 void printarrayblock(LispPTR base);
+void printfreeblockchainn(int arlen);
 LispPTR releasingvmempage(LispPTR ptr);
 LispPTR checkarrayblock(LispPTR base, LispPTR free, LispPTR onfreelist);
 LispPTR makefreearrayblock(LispPTR block, DLword length);
diff --git a/src/gcfinal.c b/src/gcfinal.c
index 67e288b..97825e5 100644
--- a/src/gcfinal.c
+++ b/src/gcfinal.c
@@ -610,3 +610,30 @@ void printarrayblock(LispPTR base) {
   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);
+    }
+}
diff --git a/src/uraid.c b/src/uraid.c
index 31ea76d..fda8717 100644
--- a/src/uraid.c
+++ b/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");