From: peng
Subject: help me understand some codes
Date: Wed, 15 Dec 2004 18:40:24 +0000
Message-ID: <1103139393.d900f5e1f7e8a9edc014a258504fed4d@tng>

(process-prog->-progn (list (third form)))
			      (process-prog->-progn (list (fourth form)))))
		       (otherwise
			 form))
		     (process-prog-> (rest forms))))
	      ((prog->-special-form (first form))
	       (do ((formals (prog->-special-form-args (first form)) (rest
formals))
		    (args args (rest args))
		    (alist (acons 'prog->-tail (rest forms) nil)))
		   (nil)
		 (cond
		   ((and (endp formals) (endp args))
		    (return (sublis alist (prog->-special-form-result (first
form)))))
		   ((endp formals)
		    (prog->-special-form-match-error form))
		   ((eq (first formals) '&rest)
		    (setq formals (rest formals))
		    (cond
		      ((or (endp args) (prog->-atom (first args)))
		       (setq args (cons nil args))
		       (setq alist (acons (first formals) nil alist)))
		      (t
		       (setq alist (acons (first formals)
					  (loop collect (first args)
						until (or (endp (rest args)) (prog->-atom (second args)))
						do (pop args))
					  alist)))))
		   ((endp args)
		    (prog->-special-form-match-error form))
		   ((prog->-atom (first formals))
		    (unless (string= (string (first formals)) (string (first args)))
		      (prog->-special-form-match-error form)))
		   (t
		    (setq alist (acons (first formals) (first args) alist))))))
	      ((member-if #'prog->-atom (rest x))
	       (prog->-too-many->s-error form))
	      (t
	       (let ((inputs (ldiff args x))
		     (outputs (rest x)))
		 (cond
		   ((string= (string (first x)) "->*")
(let ((funarg (prog->*-function-argument
(process-prog-> (rest forms)) outputs)))
(cond
((and (consp funarg)
(eq 'function (first funarg))
(consp (second funarg))
(eq 'lambda (first (second funarg))))
(let ((g (gensym)))
(list
`(flet ((,g ,@(rest (second funarg))))
(declare (dynamic-extent (function ,g)))
,@(prog->*-call form inputs `(function
,g))))))
(t
(prog->*-call form inputs funarg)))))
		   ((null outputs)
		    (prog->-no-variable-error form))
		   ((string= (string (first x)) "->")
		    (cond
		      ((null (rest outputs))
(cond
((and (consp (first outputs))
(member (first (first outputs)) '(:values
:list :list*)))
(list `(mvlet ((,(first outputs) (,(first
form) ,@inputs)))
,@(process-prog-> (rest forms)))))
(t
		         (list `(let ((,(first outputs) (,(first form) ,@inputs)))
				  ,@(process-prog-> (rest forms)))))))
		      (t
		       (list `(multiple-value-bind ,outputs
				  (,(first form) ,@inputs)
				,@(process-prog-> (rest forms)))))))
		   ((string= (string (first x)) "->NONNIL")
		    (cond
		      ((null (rest outputs))
(cond
((and (consp (first outputs))
(member (first (first outputs)) '(:values
:list :list*)))
(list `(mvlet ((,(first outputs) (,(first
form) ,@inputs)))
(when ,(first outputs)
,@(process-prog-> (rest
forms))))))
(t
		         (list `(let ((,(first outputs) (,(first form) ,@inputs)))
(when ,(first outputs)
				    ,@(process-prog-> (rest forms))))))))
		      (t
		       (list `(multiple-value-bind ,outputs
				  (,(first form) ,@inputs)
(when ,(first outputs)
				  ,@(process-prog-> (rest forms))))))))
		   ((rest outputs)
		    (prog->-too-many-variables-error form))
		   ((string= (string (first x)) "->STACK")
		    (list `(let ((,(first outputs) (,(first form) ,@inputs)))
(declare (dynamic-extent ,(first
outputs)))
			     ,@(process-prog-> (rest forms)))))
		   ((string= (string (first x)) "->PROGV")
		    (list `(let ((!prog->temp1! (list (,(first form) ,@inputs)))
(!prog->temp2! (list ,(first
outputs))))
(declare (dynamic-extent !prog->temp1!
!prog->temp2!))
(progv !prog->temp2! !prog->temp1!
,@(process-prog-> (rest forms))))))
		   (t
		    (prog->-unrecognized->-atom (first x) form)))))))))))))

(defun prog->*-call (form inputs funarg)
(cond
((prog->*-function-second-form-p (first form))
(list `(,(first form) ,(first inputs) ,funarg ,@(rest inputs))))
(t
(list `(,(first form) ,funarg ,@inputs)))))

(defun wrap-progn (forms &optional no-simplification)
(cond
((and (null forms)
	  (not no-simplification))
nil)
((and (null (rest forms))
	  (not no-simplification))
(first forms))
(t
(cons 'progn forms))))

(defun wrap-block (name forms &optional no-simplification)
(cond
((and (null forms)
	  (not no-simplification))
nil)
(t
(list* 'block name forms))))

(defun process-prog->-progn (forms)
(wrap-progn (process-prog-> forms)))

(defun process-prog->-block (forms)
(wrap-block 'prog-> (process-prog-> forms)))

(defmacro unnamed-prog-> (&body forms)
(process-prog->-progn forms))

(defmacro prog-> (&body forms)
(process-prog->-block forms))

;;; progc.lisp EOF



--
peng
------------------------------------------------------------------------
Posted via http://www.codecomments.com
------------------------------------------------------------------------