buzzard.2 (IOCCC 1992)

// Ursprungsfilen med obfuskerad (avsiktligt tillkrånglad) C-kod:
// https://ioccc.org/1992/buzzard.2.c
//
// En förteckning över de filer som har med bidraget att göra:
// https://ioccc.org/1992/buzzard.2.README
//
// Ledtrådar:
// https://ioccc.org/1992/buzzard.2.hint
//
// Mer ingående information:
// https://ioccc.org/1992/buzzard.2.design
//
// Själva koden har jag inte ändrat på så att funktionen påverkas, men
// skrivit om här och där för att öka läsbarheten.
//
// Jag kastar bort följande:
//
// Preprocessor-makro
// (skriver ut det lite pratigare case ... break istället)
// #define z;break;case
//
// Global variabel
// (ersätter med stack-allokerade variabler)
// int w;

// Vid uppstart av FIRST reserveras plats 0 till 31 i "minnet" för lite
// interna register, och dessa (listan nedan) är de jag sett användas.
//
// 0 -- Pekar ut första ledig plats i ordlistan.
// 1 -- Pekar ut retur-stackens TOS.
// 2 -- Sökning i ordlistan kräver att värdet på denna plats är 0, och
//      att värdet i länk-fältet hos ordlistans första ord är 1.
//      Ordet _read, där sökningen äger rum, kommer då att jämföra den
//      inlästa strängen mot sig själv.  Här hittas också förklaringen
//      till att L initieras till värdet 1.
// 3,4 -- THIRD, temp-variabler _x,_y.  Främst för stack-operationer.
// 5 -- THIRD, temp-variabel för första lediga plats i ordlistan.
// (Plats 6 används varken av FIRST eller THIRD.)
// 7 -- THIRD, andvänds av "_main". (TODO).
// 8,9 -- THIRD, används av "execute" (TODO).

#include <stdio.h>
#include <stdlib.h>
#include <string.h>

// Skriv till nästa lediga plats i ordlistan.  Tänk "c" som i "compile".
#define c m[m[0]++] =

// Sträng-minnet (string storage).
char s[5000];
// Offset till första lediga plats i sträng-minnet.  Initieras till 64
// eftersom sträng-minnet dessutom används som läsbuffert (Op #5).
int t = 64;

// Minnet (main memory).
// Här lagras ordlistan, retur-stacken samt dessutom två adresser i
// minnet.  Dessa två adresser (m a o index in i arrayen) är:
// m[0]: Pekar ut första lediga plats i ordlistan. Initieras till 32.
// m[1]: Retur-stackens TOS (top of stack).  Basen för denna sätts när
//       de inbyggda orden lagts till ordlistan.
// Observera att den första platsen på retur-stacken (m[2]) aldrig
// sätts av Op #2, och att det är viktigt eftersom Op #5 förutsätter
// att m[2] är lika med 0.  Vidare så används utrymmet från index 3
// upp till index 32 till temporära variabler (i gästspråket THIRD),
// _x och _y, och kanske annat utöver det.
int m[20000] = {32};

// Pekar ut det senast tillagda ordet för att skrivas i länk-fältet
// vid nästa kompilering.  Tänk "L" som i "last word" eller "link field".
int L = 1;
// Programräknaren/instruktionspekaren
int I;

// Data-stacken.
int T[500];
// Data-stackens TOS (top of stack).
int f;
// Data-stackens NOS (next on stack), den "verkliga" stack-pekaren.
int *S = T;

// Lägg till ett nytt huvud i ordlistan.  Tänk "a" som i "addera".
void a(int cptr) {
  c L;        // länk till tidigare ord i ordlistan
  L = *m - 1; // detta ord sätts här som det senast tillagda ordet
  c t;        // offset i sträng-minnet
  c cptr;     // kod-pekaren (code pointer)
  scanf("%s", s + t);     // läs in en sträng till offset t i strängminnet
  t += strlen(s + t) + 1; // sätt nytt offset t
}

// Jag registrerar en liten atexit-funktion (stdlib) för att skriva ut
// lite s-expressions som kan vara praktiska vid avlusning.
int rstack_base = 0;
int counts[] = {0,0,0,0, 0,0,0,0, 0,0,0,0, 0,0,0,0,};
void goodbye() {
  char *sep;

  printf("*** AT EXIT ***\n");

  printf(";; Return stack (size is %d).\n(", m[1] - rstack_base);
  sep = "";
  for (int i = 0 ; i < m[1] - rstack_base ; i++) {
    printf("%s%d",sep , m[rstack_base + i]);
    sep=" ";
  }
  printf(")\n");

  printf(";; Primitive call counts.\n(");
  sep = "";
  for (int i = 0 ; i < 16 ; i++) {
    printf("%s%d", sep, counts[i]);
    sep = " ";
  }
  printf(")\n");

  printf(";; Memory slots from 0 below 32.\n(");
  sep = "";
  for (int i = 0 ; i < 32 ; i++) {
    printf("%s%d", sep, m[i]);
    sep = " ";
  }
  printf(")\n");
}

// Jag döper om argumentet x till cptr (som i code pointer).
void r(int cptr) {
  int primitive = m[cptr++];
  counts[primitive]++;
  switch (primitive) {
  case 0: // Intern: "push this integer"
    *++S = f;   // Flytt av TOS till NOS (TOS-registret är nu ledigt).
    f = m[I++]; // Kopiera värdet vid instruktions-pekaren till TOS.
    break;
  case 1: // Intern: "compile a call to this code"
    c cptr;
    break;
  case 2: // Intern: "call this code"
    m[++m[1]] = I; // Spara instruktions-pekaren på retur-stacken.
    I = cptr;         // Sätt instruktions-pekaren.
    break;
  case 3: // :
    // Lägger till ett huvud i ordlistan, med kompilatorn (Op #1) i
    // kodpekar-fältet och anroparen (Op #2) i data-fältet.
    a(1);
    c 2;
    break;
  case 4: // immediate
    // Förutsätts påträffas efter namnet i en kolon-definition.
    // Backar två steg från data-fältet och suddar således ut :'s
    // normala beteende.  Istället skrivs anroparen (Op #2) till
    // kodpekar-fältet.
    *m -= 2;
    c 2;
    break;
  case 5: // _read
    {
      // Läs en blankstegs-separerad text.  De 64 första platserna i
      // "s" är reserverade som läsbuffert.  Om läsningen lyckas,
      // initiera wptr till L. I annat fall, avsluta programmet.
      int wptr = scanf("%s", s) < 1 ? exit(0), 0 : L;
      // Kör snurran såvida inte inläst text överensstämmer med
      // namn-fältet i ordet som anges av wptr.
      while (strcmp(s, &s[m[wptr + 1]]) != 0) {
        // Inte en träff. Prova nästa ord i ordlistan.
        wptr = m[wptr];
      }
      if (wptr - 1) {
        // Ordlistan innehåll ordet.  Exekvera ordet genom att anropa
        // r med ordets kodpekare som argument.
        r(wptr + 2);
      } else {
        // Ordlistan saknar ordet (wptr == 1).  Översatt den lästa
        // strängen till en int.  Notera att atoi returnerar 0 om
        // detta misslyckas.
        c 2;
        c atoi(s);
      }
    }
    break;
    //
    // Resten av operatorerna kräver inga särskilda kommentarer.
    //
  case 6: // @
    f = m[f];
    break;
  case 7: // !
    m[f] = *S--;
    f = *S--;
    break;
  case 8: // -
    f = *S-- - f;
    break;
  case 9: // *
    f *= *S--;
    break;
  case 10: // /
    f = *S-- / f;
    break;
  case 11: // <0
    f = 0 > f;
    break;
  case 12: // exit
    I = m[m[1]--];
    break;
  case 13: // echo
    putchar(f);
    f = *S--;
    break;
  case 14: // key
    *++S = f;
    f = getchar();
    break;
  case 15: // _pick
    f = S[-f];
  }
}

int main() {
  atexit(goodbye);

  a(3); // :
  a(4); // immediate
  a(1); // "compile a call to this code"
  {
    // dptr, pekare till ordets data-fält
    int dptr = *m;
    c 5; // 5, som i _read
    c 2; // 2, som i "call this code"
    I = *m;
    c dptr;
    c I - 1;
  }

  // Jag tar en titt i debuggern på det som hänt hittills.  Först
  // lades tre huvuden till i ordlistan.
  //
  // (gdb) x /3dw m+32
  // 0x555555558120 <m+128>: 1       64      3
  // (gdb) x /3dw m+32+3
  // 0x55555555812c <m+140>: 32      66      4
  // (gdb) x /3dw m+32+3+3
  // 0x555555558138 <m+152>: 35      76      1
  //
  // Det som sen skrivs till data-fältet fungerar som den tolk. 5 är
  // läs, 2 är exekvera.  Sedan följer två pekare tillbaka till nyss
  // nämnda instruktioner, och instruktionspekaren sätts att peka på
  // den första av dom pekarna.  Enkelt, men retur-stacken kommer
  // obönhörligen växa, tills den är full.  Det löses genom att
  // implementera en tolk-rutin på högre nivå.  Om det och mycket
  // annat finns att läsa i filen buzzard.2.design.
  //
  // (gdb) x /4dw m+32+3+3+3
  // 0x555555558144 <m+164>: 5       2       41      42

  {
    // Lägg till resten av de inbyggda orden i ordlistan.
    int primitive = 6;
    while (primitive < 16) {
      a(1);
      c primitive++;
    }
  }

  // (gdb) x /2dw m
  // 0x5555555580a0 <m>:     85      0
  // (gdb) print I
  // $1 = 43

  // Flytta upp retur-stacken till första lediga plats ovanför
  // ordlistan.  Se nästa kommentar.
  m[1] = *m;

  // Detta är för att kunna skriva meddelandet när programmet avslutas.
  rstack_base = m[1];

  // Flytta upp första lediga plats i ordlistan 512 platser, och
  // reservera på så sätt 512 platser för retur-stacken.
  *m += 512;

  // Hepp!
  while (1) {
    r(m[I++]);
  }
}

(defpackage "FIRST"
  (:use "COMMON-LISP"))

(in-package "FIRST")

(defun whitespace-char-p (x)
  (or (char= #\space x)
      (not (graphic-char-p x))))

(defun read-until (test &optional (stream *standard-input*))
  (with-output-to-string (out)
    (loop for c = (peek-char nil stream nil nil)
       while (and c (not (funcall test c)))
       do (write-char (read-char stream) out))))

(defun read-next ()
  (read-until (complement 'whitespace-char-p))
  (let ((result (read-until 'whitespace-char-p)))
    (if (zerop (length result))
        nil
        result)))

;;
;; FIRST
;;

(defvar *symbols*)
(defvar *stack*)
(defvar *mem*)

(defvar *l*)
(defvar *i*)

(defvar *rstack-pointer-max*)
(defvar *rstack-pointer-min*)

(defun 1st-compile (value)
  (setf (aref *mem* (aref *mem* 0)) value)
  (incf (aref *mem* 0)))

(defun 1st-compile-header (code-pointer)
  (1st-compile *l*)
  (setf *l* (1- (aref *mem* 0)))
  (1st-compile (length *symbols*))
  (1st-compile code-pointer)
  (push (read-next) *symbols*)
  (format t "~&1st-compile-header: compiled ~a~%" (car *symbols*)))

(defun 1st-find-word-pointer (name word-pointer)
  (when (< 1 word-pointer)
    (let ((index (aref *mem* (1+ word-pointer))))
      (if (string= name (nth index (reverse *symbols*)))
          word-pointer
          (1st-find-word-pointer name (aref *mem* word-pointer))))))

(defun 1st-nos-tos--tos (fn)
  "Kör funktionen `FN' för stack-effekt ( lhs rhs -- result ).  Poppa
nollor om stacken är tom.  För att THIRD skall kunna ladda behöver det
vara tillåtet, såvitt jag kan bedöma."
  (let ((rhs (or (pop *stack*) 0))
        (lhs (or (pop *stack*) 0)))
    (push (truncate (funcall fn lhs rhs)) *stack*)))

(defun 1st-rstack-push (object)
  (assert (< (aref *mem* 1) *rstack-pointer-max*))
  (setf (aref *mem* (incf (aref *mem* 1))) object))

(defun 1st-rstack-pop ()
  (assert (< *rstack-pointer-min* (aref *mem* 1)))
  (aref *mem* (1+ (decf (aref *mem* 1)))))

(defun 1st-execute (code-pointer)
  (let ((primitive (aref *mem* code-pointer)))
    (incf code-pointer)
    (ecase primitive
      ;; case 0: // Intern: "push this integer"
      (0  (push (aref *mem* *i*) *stack*)
          (incf *i*))
      ;; case 1: // Intern: "compile a call to this code"
      (1  (1st-compile code-pointer))
      ;; case 2: // Intern: "call this code"
      (2  (1st-rstack-push *i*)
          (setf *i* code-pointer))
      ;; case 3: // :
      (3  (1st-compile-header 1)
          (1st-compile 2))
      ;; case 4: // immediate
      (4  (decf (aref *mem* 0) 2)
          (1st-compile 2))
      ;; case 5: // _read
      (5 (let ((str (read-next)))
           (unless str
             ;; Detta ställer antagligen till sådana problem med
             ;; retur-stacken att det blir omöjligt att återuppta
             ;; körning med inmatning från annan ström.
             (error 'end-of-file))
           (let ((word-pointer (1st-find-word-pointer str *l*)))
             (assert (or (numberp word-pointer) (null word-pointer)))
             (if word-pointer
                 (1st-execute (+ 2 word-pointer))
                 (progn
                   (1st-compile 2)
                   (1st-compile (parse-integer str)))))))
      ;; case 6: // @
      (6  (setf (car *stack*) (aref *mem* (car *stack*))))
      ;; case 7: // !
      (7  (setf (aref *mem* (pop *stack*)) (pop *stack*)))
      ;; case 8: // -
      (8  (1st-nos-tos--tos #'-))
      ;; case 9: // *
      (9  (1st-nos-tos--tos #'*))
      ;; case 10: // /
      (10 (1st-nos-tos--tos #'/))
      ;; case 11: // <0
      (11 (setf (car *stack*) (if (< (car *stack*) 0) 1 0)))
      ;; case 12: // exit
      (12 (setf *i* (1st-rstack-pop)))
      ;; case 13: // echo
      (13 (write-char (code-char (pop *stack*))))
      ;; case 14: // key
      (14 (push (char-code (read-char)) *stack*))
      ;; case 15: // _pick
      ;; Utelämnas eftersom att _pick inte används av THIRD.
      )))

(defun 1st-reset ()
  (setf *symbols* nil)
  (setf *stack* nil)
  (setf *mem* (make-array 20000 :initial-element 0))
  (setf (aref *mem* 0) 32)
  (setf *l* 1)
  (setf *i* 0)
  (with-input-from-string
      (*standard-input* ": immediate _read @ ! - * / <0 exit echo key _pick")
    (1st-compile-header 3)
    (1st-compile-header 4)
    (1st-compile-header 1)
    (let ((data-pointer (aref *mem* 0)))
      (1st-compile 5)
      (1st-compile 2)
      (setf *i* (aref *mem* 0))
      (1st-compile data-pointer)
      (1st-compile (1- *i*)))
    (loop for i from 6 below 16 do
         (1st-compile-header 1)
         (1st-compile i)))
  (setf *rstack-pointer-min* (aref *mem* 0))
  (setf (aref *mem* 1) *rstack-pointer-min*)
  (incf (aref *mem* 0) 512)
  (setf *rstack-pointer-max* (aref *mem* 0))
  nil)

(defun 1st-interpret ()
  (handler-case
      (loop
         (let ((i *i*))
           (incf *i*)
           (1st-execute (aref *mem* i))))
    (end-of-file () (format t "<END OF FILE>"))))

(defun 1st-load-file (filename)
  (with-open-file (*standard-input* filename)
    (1st-interpret)))

;;
;; +++ +++ +++ OKEJ. DÅ KÖR VI DET. +++ +++ +++
;;

;; (1st-reset)
;; (1st-interpret) 

;; Eftersom jag lägger till namnen för de inbyggda orden i `1st-reset'
;; så har jag förberett en kopia av "third" där jag tagit bort första
;; raden.  Demo-filerna har jag sedan konkatenerat på.

(defparameter *dir* "/home/guna/r/floatp-ioccc-1992/buzzard.2/")

(defun 1st-load-file* (filename &key (reset-p t))
  (when reset-p (1st-reset))
  (1st-load-file (merge-pathnames filename *dir*)))

(1st-load-file* "first.lisp_third")
(1st-load-file* "first.lisp_third-demo1.th")
(1st-load-file* "first.lisp_third-demo2.th")
(1st-load-file* "first.lisp_third-demo3.th")
(1st-load-file* "first.lisp_third-demo4.th")
(1st-load-file* "first.lisp_third-demo5.th")
(1st-load-file* "first.lisp_third-demo6.th")

;; Alla demo-program utom 3'an kör som de skall.

;; Vid körning av demo3.th får jag: Not an integer string: "endif"
;; Jag kan inte för mitt liv hitta en definitionen av endif och något
;; är fel, för C-implementationen skriver glatt ut:
;; "0 1 2 3 forth 0 5 6 7 8 9"
;; ... vid körning av samma program.

;; Jag observerar att något konstigt händer när ordet primes
;; kompileras.  Jag hade vid tillfället, i `1st-nos-tos--tos', en
;; kontroll på om stackens storlek var mindre än två celler.  Det är
;; tydligt att, när primes defineras, så poppas det från en tom stack.

;;
;; Hjälpmedel för inspektion av tillståndet.
;;

(defun x (address &optional (count 16))
  "Examine (main memory)."
  (subseq *mem* address (+ address count)))

(defun x-rstack ()
  "Examine (return stack)."
  (values
   (subseq *mem* 85 (aref *mem* 1))
   (- (aref *mem* 1) 85)))

(defun find-word-name (word-pointer)
  ";; (find-word-name (1st-find-word-pointer \"_read\" *l*))"
  (nth (aref *mem* (1+ word-pointer)) (reverse *symbols*)))