GARBAGE COLLECTOR IN LISP

From the book LISP From Nothing

A simple Deutch/Schorr/Waite mark & sweep garbage collector for LISP.

;;; CONS / GC ALGORITHM IN LISP
;;; USING DEUTSCH/SCHORR/WAITE GRAPH MARKER
;;;
;;; NILS M HOLM, 2020
;;;
;;; IN THE PUBLIC DOMAIN
;;;
;;; WHERE THERE IS NO PUBLIC DOMAIN, THE
;;; CREATIVE COMMONS ZERO (CC0) LICENSE APPLIES

(SETQ MARK
  (LAMBDA (N)
    (LABEL
      ((P NIL)  ; PARENT
       (X NIL)  ; TEMPORARY
       (LOOP (LAMBDA (N)
         (COND
           ((*MARKP N)
             (COND
               ((EQ NIL P))
               ((*TRAVP P)
                  (SETQ X (*CDR P))
                  (*RPLACD P (*CAR P))
                  (*RPLACA P N)
                  (*SETTRAV P NIL)
                  (LOOP X))
               (T (SETQ X P)
                  (SETQ P (*CDR X))
                  (*RPLACD X N)
                  (LOOP X))))
           ((*ATOMP N)
              (SETQ X (*CDR N))
              (*RPLACD N P)
              (SETQ P N)
              (*SETMARK P T)
              (LOOP X))
           (T (SETQ X (*CAR N))
              (*RPLACA N P)
              (SETQ P N)
              (*SETMARK P T)
              (*SETTRAV P T)
              (LOOP X))))))
      (LOOP N))))

(SETQ *FRELIS
  (*NEXT (*NEXT (*NEXT (*NEXT
    (*NEXT (*NEXT (*NEXT (*NEXT
      (*NEXT (*NEXT *POOL)))))))))))

(SETQ *ROOTLIM (*NEXT *FRELIS))

(SETQ GC
  (LAMBDA ()
    (LABEL
      ((MARK-ROOTS
        (LAMDBA (N)
          (COND ((EQ N *ROOTLIM))
                (T (MARK N)
                   (MARK-ROOTS (*NEXT N))))))
       (COLLECT-FREE
         (LAMBDA (N)
           (COND ((EQ N *LIMIT))
                 ((*MARKP N)
                    (*SETMARK N NIL)
                    (COLLECT-FREE (*NEXT N)))
                 (T (*RPLACD N (*CAR *FRELIS))
                    (*RPLACA *FREELIS N)
                    (COLLECT-FREE (*NEXT N)))))))
      (*RPLACA *FRELIS NIL)
      (MARK-ROOTS *POOL)
      (COLLECT-FREE *ROOTLIM)))))

(SETQ CONS3
  (LAMBDA (A D AT)
    (COND ((EQ NIL (*CAR *FRELIS))
            (GC)
            (COND ((EQ NIL (*CAR *FRELIS)))
                    (*HALT "OUT OF CELLS"))))
    (LABEL ((N (*CAR *FRELIS)))
      (COND (AT (*SETATOM N T))
            (T  (*SETATOM N NIL)))
      (*RPLACA *FRELIS (*CDR (*CAR *FRELIS))))
      (*RPLACA N A)
      (*RPLACD N D)))

(SETQ CONS 
  (LAMBDA (A D)
    (CONS3 A D NIL)))