re: do loop for 1.6 XScheme

[Shawn McLean <news!mclean@think.com>]

Help yourself.  Also included is a defsetf clone. -shawn

;;; (c) Copyright 1989, Shawn Mclean
;;; All rights reserved
;;; Permission is granted for unrestricted non-commercial use
;;; created: Tue 3-28-1989 22:32
;;; XScheme - Version 0.16
;;; commonlisp compatibility macros and functions

;;;
;;; macros
;;;

(macro defmacro 
  (lambda (form)
    (let* ((name (cadr form)) (form (cddr form))
           (arglist (car form)) (form (cdr form))
           (body (car form)))
    (put name '%arglist arglist)
      `(macro ,name
         (lambda (form)
           (apply (lambda ,arglist ,body) (cdr form)))))))

;;;
;;; lists
;;;

(macro first (lambda (form) `(car ,(cadr form))))
(macro second (lambda (form) `(cadr ,(cadr form))))
(macro third (lambda (form) `(caddr ,(cadr form))))
(macro fourth (lambda (form) `(cadddr ,(cadr form))))
(macro fifth (lambda (form) `(caddddr ,(cadr form))))
(macro nth (lambda (form) `(list-ref ,(cadr form) ,(caddr form))))

(macro push
  (lambda (form)
    (let ((item (cadr form))
          (list (caddr form)))
      `(set! ,list (cons ,item ,list)))))

(macro pop 
  (lambda (form)
    (let ((list (cadr form))
          (item (gensym 'item)))
      `(let ((,item (car ,list)))
         (set! ,list (cdr ,list))
         ,item))))

;;;
;;; loops
;;;

(macro do
  (lambda (form)
    (let (locals test body exits inits updates)
      (set! locals (reverse (cadr form)))
      (set! form (cddr form))
      (set! test (car form))
      (set! form (cdr form))
      (set! body form)
      (set! exits (cdr test))
      (set! test (list 'not (car test)))
      (while locals
        (let* ((local (car locals))
               (var (if (list? local) (car local) local))
               (init (cadr local))
               (update (caddr local)))
          (push (list var init) inits)
          (if update (push `(set! ,var ,update) updates))
          (set! locals (cdr locals))))
      `(let ,inits (while ,test ,@body ,@updates) ,@exits))))

(macro do*
  (lambda (form)
    (let (locals test body exits inits updates)
      (set! locals (reverse (cadr form)))
      (set! form (cddr form))
      (set! test (car form))
      (set! form (cdr form))
      (set! body form)
      (set! exits (cdr test))
      (set! test (list 'not (car test)))
      (while locals
        (let* ((local (car locals))
               (var (if (list? local) (car local) local))
               (init (cadr local))
               (update (caddr local)))
          (push (list var init) inits)
          (if update (push `(set! ,var ,update) updates))
          (set! locals (cdr locals))))
      `(let* ,inits (while ,test ,@body ,@updates) ,@exits))))

(macro dotimes
  (lambda (form)
    (let* ((control (cadr form))
           (body (cddr form))
           (var (car control))
           (limit (cadr control)))
      `(let ((,var 0))
         (while (< ,var ,limit) ,@body (set! ,var (1+ ,var)))))))

(macro dolist
  (lambda (form)
    (let* ((control (cadr form))
           (body (cddr form))
           (item (car control))
           (list (cadr control))
           (items (gensym 'items)))
      `(let ((,items ,list))
         (while (not (null? ,items))
           (set! ,item (car ,items))
           ,@body
           (set! ,items (cdr ,items)))))))

;;;
;;; debugger
;;;
;;; Is this the way to do this?

(define break
  (lambda args
    (display "break: ") (dolist (arg (cdr args)) (display arg))
    (let ((env (environment-bindings (the-environment))))
      (dolist (binding env)
        (map display (car binding) ":	" (cdr binding))
        (newline))
      (read))))

;;;
;;; string conversions
;;; not common lisp

(define integer->string
  (lambda (integer)
    (let ((done nil) (integer-string nil))
      (while (not done)
        (push (integer->char (+ (char->integer #\0) (remainder integer 10)))
              integer-string)
        (set! integer (quotient integer 10))
        (set! done (= integer 0)))
      (list->string integer-string))))
       

;;;
;;; general accessor
;;;
;;; This is a defsetf clone that works on global functions.  A modifier
;;; function is first defined with defset, and following set will invert a
;;; reference.  For example:
;;;
;;; (set (car foo) 'bar) => (set-car! foo 'bar)
;;;
;;; If anything, this saves you from typing !'s all over the place.  set
;;; will accept one or pairs of auguments.

(macro set
  (lambda (pairs)
    (if (odd? (length (cdr pairs)))
        (error "odd number of arguments to set")
        (do* ((place (cdr pairs) (cdr place))
             (value (cdr place) (cdr place))
             (assignments nil))
            ((null? place)
             (if (cdr assignments)
                 `(begin ,@(reverse assignments))
	         (car assignments)))
          (set! assignments (cons (general-set (car place) (car value))
                                  assignments))
          (set! place (cdr place))))))

(define general-set
  (lambda (place value)
    (if (list? place)
        ((get (car place) 'set) (cadr place) value)
        `(set! ,place ,value))))

(defmacro defset (function lambda-list values form)
  (let ((set-function `(lambda (,@lambda-list ,@values) ,form)))
   `(begin (put ',function 'set ,set-function) ',function)))

(defset car (list) (value) `(set-car! ,list ,value))
(defset cdr (list) (value) `(set-cdr! ,list ,value))