;; An attempt to create a minimal linear stack machine, inspired by Henry
;; Baker's Linear Lisp machine.

(module linear mzscheme

  ;; Suppose we have a set of primitive functions (think + - * / for
  ;; now), what are the primitives necessary to create a conservative
  ;; stack machine, which can use these function to compute operations
  ;; on ATOMs according to the following rules:

  ;; * The machine stores all data in a binary tree of pairs.

  ;; * Each half of a pair is either:
  ;;     - an ATOM
  ;;     - another PAIR
  ;;     - NULL
  
  ;; * PAIRS are never created nor distroyed. Each operation on the
  ;;   tree conserves the number of pairs.

  ;; * ATOMS are thought of as abstract. They might be nonlinear
  ;;   objects, numbers or any kind of substructure not accessible by
  ;;   the machine.
  

  ;; All conservative operations on a tree can be represented by
  ;; cyclic permutation of pointers. This includes NULL
  ;; pointers. ATOMS behave as NULL pointers.

  ;; However, not all such permutations are legal, since they can lead
  ;; to cyclic structures. In order to have only legal structures, I
  ;; will try to construct a set of operations from a simple set of
  ;; basic ops.

  ;; The legal operations are subtree swaps. If one node is in the
  ;; subtree of the other, this operation is meaningless.

  ;; The basic operations we use are fetch and store from a subtree,
  ;; swap with 'traveral program' parameters, and a numeric node
  ;; address swap.
  
  (define-syntax @
    (syntax-rules (a d)
      ((_ r ()) r)
      ((_ r (a . x)) (@ (car r) x))
      ((_ r (d . x)) (@ (cdr r) x))))
     
  (define-syntax !
    (syntax-rules (a d)
      ((_ r (a) v)     (set-car! r v))
      ((_ r (d) v)     (set-cdr! r v))
      ((_ r (a . x) v) (! (car r) x v))
      ((_ r (d . x) v) (! (cdr r) x v))))

  (define-syntax _swap
    (syntax-rules ()
      ((_ r x y)
       (let ((_x (@ r x))
             (_y (@ r y)))
         (! r x _y)
         (! r y _x)))))

  (define-syntax (swap stx)
    (define (addr->a/d addr)
      (when (< addr 1)
        (error 'invalid-address
               "swap: invalid-address: ~a" addr))
      (let next ((p '())
                 (a addr))
        (if (= 1 a) p
            (next (cons
                   (if (zero? (bitwise-and a 1)) 'a 'd) p)
                  (arithmetic-shift a -1)))))
    (syntax-case stx ()
      ((_ r x y)
       #`(_swap r
                #,(addr->a/d (syntax-object->datum #'x))
                #,(addr->a/d (syntax-object->datum #'y))))))



  ;; With a 2-stack system (D . F) with D rooted at 2 and F at 3, the
  ;; primitives are:

  ;; F  = 3
  ;; D  = 2
  ;; D+ = 5
  ;; D0 = 4
  ;; D1 = 10
  ;; D0a = 8  \ (car of D0)
  ;; D0d = 9  \ (cdr of D0)

  ;; Assume the free list contains a list of NULL, then allocating a
  ;; new top cell is just

  ;;  : free>   (D F) (D+ F) ;
  
  ;; To make a DROP disassembles its argument list we need the
  ;; following.

  ;;  : >free   (D+ F) (D F) ;
  ;;  : swap    (D0 D1) ;
  ;;  : uncons  (D0d D+) (D0 D+)
  ;;  : drop    null? if >free ; then uncons drop drop ;

  ;; From this the inverse of uncons follows

  ;;  : cons    (D0 D+) (D0d D+) ;

  ;; Note that cons is conservative, in the sense that it does not use
  ;; any cells on the free list.


  

)