_ADDING EXTENSIONS TO LISP_
by
Jonathan Amsterdam

Listing 1.

(defmacro for (var-from-to &rest body)
  (let ((var (first var-from-to))
	(from (second var-from-to))
	(to (third var-from-to)))
    `(prog (,var)
	   (setq ,var ,from)
	 loop
	   (cond ((> ,var ,to) (go end)))
	   ,@body
	   (setq ,var (+ ,var 1))
	   (go loop)
	 end)))

----------------------------------------------------------------
Listing 2.

(defmacro for (var-from-to &rest body)
  (let ((var (first var-from-to))
	(from (second var-from-to))
	(to (third var-from-to)))
    (cond
     ((and (numberp from) (numberp to) (< (- to from) 2))
      ;; If from and to are both numbers, and they differ by at most 1...
      (cond ((< (- to from) 0)
	     ;; they differ by < 0, hence there's no loop to generate
	     nil)
	    ((= (- to from) 0)
	     ;; they're the same, so just a single iteration
	     `(let ((,var ,from))
		,@body))
	    (t 
	     ;; else, they differ by one: so two iterations
	     `(let ((,var ,from))
		,@body
		(setq ,var ,to)
		,@body))))
     (t ;; the general case
      `(prog (,var)
	     (setq ,var ,from)
	   loop
	     (cond ((> ,var ,to) (go end)))
	     ,@body
	     (setq ,var (+ ,var 1))
	     (go loop)
	   end)))))

----------------------------------------------------------------
Listing 3.

(defmacro for (clause &rest body)
  (let* ((code (funcall (get (second clause) 'for-expander) 
			(first clause) (cddr clause)))
	 (init (first code))
	 (test (second code))
	 (update (third code)))
    `(prog ()
	   ,@init
	 loop
	   (cond (,test (go end)))
	   ,@body
	   ,@update
	   (go loop)
	 end)))

----------------------------------------------------------------
Listing 4.

(defmacro for (&rest forms)
  (let* ((do-part (member 'do forms))
	 (body (cdr do-part))
	 (clauses (ldiff forms do-part)) ;clauses = everything before "do"
	 (init nil)
	 (test nil)
	 (update nil))
    (dolist (clause clauses)
      (let ((code (funcall (get (second clause) 'for-expander)
			   (first clause) (cddr clause))))
	(setq init (append init (first code)))
	(push (second code) test)
	(setq update (append update (third code)))))
    (setq test (cons 'or (nreverse test)))
    `(prog ()
	   ,@init
	 loop
	   (cond (,test (go end)))
	   ,@body
	   ,@update
	   (go loop)
	 end)))


----------------------------------------------------------------
Listing 5.

(defmacro defrecord (name &rest components)
    `(progn
       ,@(accessor-macro-defs name components)
       (defun ,(symbol-append 'make- name) ,components
	 (let ((new-record (make-array ,(length components))))
	   ,@(component-setting-list name components)
	   new-record))))
       
(defun component-setting-list (name components)
  (let ((set-list nil))
    (for (comp in components)
	 do
	 (push `(setf (,(accessor-name name comp) new-record) ,comp)
	       set-list))
    set-list))

(defun accessor-macro-defs (name components)
  (let ((def-list nil))
    (for (i from 0 to (- (length components) 1))
	 do
	 (push `(defmacro ,(accessor-name name (nth i components)) (x) 
		  (list 'aref x ,i))
	       def-list))
    def-list))

(defun symbol-append (&rest symbols)
  (intern (apply #'string-append symbols)))

(defun accessor-name (rec-name comp-name)
  (symbol-append rec-name '- comp-name))


Example 1.

(prog (i) 
      (setq i 1) 
    loop 
      (cond ((> i 10) (go end))) 
      (print i) 
      (setq i (+ i 1)) 
      (go loop) 
    end)


Example 2.

(setq i 1)
(while (<= i 10)
  (print i)
  (setq i (+ i 1)))


Example 3.

(defmacro while (test &rest body)
  `(prog ()
       loop
	 (cond ((not ,test) (go end)))
	 ,@body
         (go loop)
       end))


Example 4.

(prog ()
    loop
      (cond ((not (>= i 10)) (go end)))
      (print i)
      (setq i (+ i 1))
      (go loop)
    end)


Example 5.

(for (i 1 10)
  (print i))


Example 6.


(defmacro setf (form value) 
  (setq form (macroexpand form)) 
  (cond 
   ((symbolp form) 
    `(setq ,form ,value)) 
   (t 
    (funcall (get (car form) 'setf-method) form value)))) 


Example 7.

(defun car-setf-method (form value) 
  `(rplaca ,(second form) ,value))


Example 8. 

(defun aref-setf-method (form value) 
  (let ((array (second form)) 
	(indices (cddr form))) 
    `(aset ,array ,value ,@indices)))




Example 9.

(defun num-expander (var from-to) 
  (let ((from (first from-to)) 
	(to (third from-to))) 
    (list `((setq ,var ,from))          ; initialization 
	  (if to 
	      `(> ,var ,to))            ; test 
	  `((setq ,var (1+ ,var))))))   ; update 


Example 10.

(defun list-el-expander (var list) 
  (setq list (car list)) 
  (let ((sublis-var (gensym))) 
    (list `((setq ,sublis-var ,list) 
	    (setq ,var (car ,sublis-var))) ;initialization 
	  `(null ,sublis-var)              ;test 
	  `((setq ,sublis-var (cdr ,sublis-var)) 
	    (setq ,var (car ,sublis-var)))))) ;update 



Example 11.  

(for (i from 0 to (- (length list) 1)) 
     (setf (aref array i) (nth i list))) 



Example 12.

(for (el in list) 
     (i from 0) 
   do (setf (aref array i) el)) 



END OF FILE