Power-Programmierung/CD1.mdf/magazine/drdobbs/1988/10/lspext.lst

Lisp/Scheme | 1988-10-31 | 5KB | 250 lines

_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