;;;; Locatives: C-style pointers in Common Lisp

;;; This a Common Lisp source file. Download it and load it
;;; into a Lisp Image.  The file and the output are intended
;;; to be read side-by-side.

;;; The C computer programming language has pointers. One
;;; can take the address of variable and pass it to a
;;; function. This allows the function to reach out, back
;;; into the calling environment, like Carrie reaching out
;;; of her grave, and change the value of the variable.

;;; This has alarming implications for memory management.
;;; Once raw machine addresses have escaped into the wild
;;; malloc and free dare not move anything, so it is not
;;; possible to have memory mangement routines that compact
;;; the live space. If ones machine has 4kbyte pages and
;;; one ends up with a thin scattering of 256 bytes chunks
;;; of data, one could take a factor of sixteen hit on on
;;; memory utilisation. If that pushes the machine into
;;; paging, you will take a performance hit of not more than
;;; 10000 times.

;;; Common Lisp is carefully designed so that
;;; implementations may provide compacting garbage
;;; collectors. This would seem to rule out pointers of the
;;; kind present in C.  The price of permitting compacting
;;; garbage collection is a level of indirection, so that
;;; the garbage collector can adjust pointers when it moves
;;; things. In practice, this extra level of indirection is
;;; usually present anyway, such as when a function is
;;; passed a CLOS object and changes the value of of a slot.
;;; C programmers often create Christmas trees of pointers
;;; to structures of pointers to structures ... Common Lisp
;;; programmers do essentially the same thing (though more
;;; conveniently) and may not realise that the apparently
;;; essential ingredient, pointers, is only implicitly
;;; present in the language. 

;;; Although creating C-style pointers in Common Lisp is of
;;; no practical importance, the fact that it would appear
;;; to be impossible makes it an intriguing intellectual
;;; challenge.  Obviously one is going to use macros, but
;;; this is the kind of fundamental addition to a
;;; programming language that looks on the face of it to be
;;; beyond the power of source-to-source transformations. I
;;; posted some code on comp.lang.lisp that created C-style
;;; pointers to variables.  It was very limited. For
;;; example, it could not point to the third element of an
;;; array.

;;; Lars Brinkhof and Paul Foley have told me how to
;;; implement locatives - things that can point to any kind
;;; of place, just like a C-style pointer. Their code made
;;; me run away and hide under the bed.  This is my attempt
;;; to sneak up on the code, and overcome my fear of
;;; get-setf-expansion

;;; The basic idea is to use closures

(defvar *read*)
(defvar *write*)

(let (variable) ;create a pointer to this variable
  (setf *read* (lambda()variable)
	*write* (lambda(data)(setf variable data))))

(funcall *write* 73)
(format t "Calling *read*, result is ~A~%"
	(funcall *read*))

;;; We can set about packaging this
;;; The first step is to put the two closures
;;; together in a cons.

(defvar *read/write*)

(let (variable)
  (setf *read/write*
	(cons (lambda()variable)
	      (lambda(data)(setf variable data)))))

(funcall (cdr *read/write*) 351)
(format t "Calling reader from *read/write*~%~
           Result is ~A~%"
	(funcall (car *read/write*)))

;;; Pressing on, we can wrap (cons ... ) in a 
;;; macro, so we can conveniently use the code
;;; in various places

(defmacro addr(variable-name)
  `(cons (lambda() ,variable-name)
	 (lambda(data)(setf ,variable-name data))))

(let (&x &y)
  (let (x y)
    (setf &x (addr x)
	  &y (addr y)))
  (funcall (cdr &x) "Ecks")
  (funcall (cdr &y) "Why")
  (format t "X=~A, Y=~A~%"
	  (funcall (car &x))
	  (funcall (car &y))))

;;; This is taking shape very nicely.
;;; Let us tidy up the funcalls with a function

(defun data (read-write-cons)
  (funcall (car read-write-cons)))

(defun (setf data) (value read-write-cons)
  (funcall (cdr read-write-cons) value))

(let (addr-x addr-y)
  (let ((x 5)(y 7))
    (setf addr-x (addr x)
	  addr-y (addr y)))
  (psetf (data addr-x)(+ (data addr-x)
			 (data addr-y))
	 (data addr-y)(* (data addr-x)
			 (data addr-y)))
  (format t "Adding and multiplying makes X=~A and Y=~A~%"
	  (data addr-x)
	  (data addr-y)))

;;; It looks as though we are done
;;; now we can translate C code
;;; &x = (addr x), *x = (data x)

;;; The trouble is, we have a multiple evaluation bug.

(let ((a #(a b c d e f g))
      (i 2))
  (let ((pointer (addr (aref a (incf i)))))
    (dotimes (j 3)
      (format t "Multiple evaluation bug -> ~A~%"
	      (data pointer)))))

;;; The multiple evaluation problem goes
;;; away if we introduce temporary variables

(let ((a #(a b c d e f g))
      (i 2))
  (let ((temp (incf i)))
    (let ((pointer (addr (aref a temp))))
      (dotimes (j 3)
	(format t "Multiple eval bug cured -> ~A~%"
	  (data pointer))))))

;;; but that will not do. In place of
#|
(macroexpand '(addr (aref a (incf a))))
=>
(CONS (LAMBDA () (AREF A (INCF A)))
      (LAMBDA (DATA)
        (SETF (AREF A (INCF A)) DATA)))
|#
;;; we want to have
#|
(macroexpand '(addr (aref a (incf a))))
=>
(let ((temp (incf a)))
  (cons (lambda ()(aref a temp))
	(lambda (data)
	  (setf (aref a temp) data))))
|#
;;; At first sight we are stuck.
;;; Our macro ADDR would have to analyse the
;;; form it was given, decide what forms
;;; need to be evaluated and saved in temporary
;;; variables, and construct setter and getter
;;; forms to access the place without side-effects.
;;; That is a lot of work. Fortunately
;;; get-setf-expansion does it all for us.


(defmacro addr(access-form-with-side-effects)
  (multiple-value-bind (temporary-variables
			once-only-forms
			;; to allow for multiples
			;; values get-setf-expansion
			;; returns a list of one element
			list-of-store-variable
			setter
			getter)
     (get-setf-expansion access-form-with-side-effects)
  `(let* ,(mapcar (function list)
		  temporary-variables
		  once-only-forms)
     (cons (lambda() ,getter)
	   (lambda(data)
	     (let ((,(car list-of-store-variable)
		   data))
	       ,setter))))))
	
(let ((a #(a b c d e f g))
      (i 2))
  (let ((pointer (addr (aref a (incf i)))))
    (dotimes (j 3)
      (format t "Multiple eval bug free -> ~A~%"
	      (data pointer)))))

;;; Lars Brinkhoff 
;;; http://www.hexapodia.net/pipermail/small-cl-src/2004-June/000016.html)
;;; Jeff Dalton 
;;; http://groups.google.com/groups?q=jeff+Dalton+get-setf-expansion&hl=en&lr=&ie=UTF-8&selm=x2zox3zao2.fsf%40todday.aiai.ed.ac.uk&rnum=1
;;; and Paul Foley (email)
;;; all have sophisticated versions of this code.

;;; One nice touch that I've missed is that lambda and let 
;;; are the same underneath, so I need not say
#|
(lambda(data)
  (let ((,(car list-of-store-variable)
	 data))
    ,setter))
|#
;;; it should be simply
#|
(lambda ,list-of-store-variable ,setter)
|#
(defmacro addr(variable-name)
  (multiple-value-bind (temporary-variables
			once-only-forms
			;; to allow for multiples
			;; values get-setf-expansion
			;; returns a list of one element
			list-of-store-variable
			setter
			getter)
     (get-setf-expansion variable-name)
  `(let* ,(mapcar (function list)
		  temporary-variables
		  once-only-forms)
     (cons (lambda() ,getter)
	   (lambda ,list-of-store-variable
	     ,setter)))))

(print (macroexpand '(addr (aref a (incf i)(decf j)))))
#| =>
(LET* ((#:G888 A)
       (#:G887 (INCF I))
       (#:G886 (DECF J)))
  (CONS
   (LAMBDA ()
     (AREF #:G888 #:G887 #:G886))
   (LAMBDA (#:G885)
     (COMMON-LISP::%ASET #:G888
                         #:G887
                         #:G886
                         #:G885))))
|#
;;; I don't know whether I've frightened my readers, but now
;;; feel much more confident about get-setf-expansion. I'm
;;; also very glad that I've created a web page about it. I
;;; do not think that I am actually going to use this
;;; frequently enough to avoid forgetting the details, so I
;;; will come back to this webpage myself to refresh my
;;; memory.