From: peng
Subject: help me understand some codes
Date: Wed, 15 Dec 2004 18:28:08 +0000
Message-ID: <1103139382.cdc6cf1381de4d49ef101f2a697a049e@tng>

(in-package :mes)

;;; changed convention:
;;; function argument for ->* is now first instead of last argument
;;; this allows rest, optional, and keyword arguments

(defparameter *prog->*-function-second-forms*
	      '(funcall apply))

(defparameter *prog->-special-forms*
'(
;; (pattern . forms)

((dolist list-form &rest l ->* var)
(dolist (var list-form . l)
(unnamed-prog-> . prog->-tail)))
((dotails list-form &rest l ->* var)
(dotails (var list-form . l)
(unnamed-prog-> . prog->-tail)))
((dopairs list-form &rest l ->* var1 var2)
(dopairs (var1 var2 list-form . l)
(unnamed-prog-> . prog->-tail)))
((dotimes count-form &rest l ->* var)
(dotimes (var count-form . l)
(unnamed-prog-> . prog->-tail)))
((identity form -> var)
(let ((var form))
(unnamed-prog-> . prog->-tail)))

;; ((pttp::with-n-m-subgoals n m ->*)
;;  (pttp::with-n-m-subgoals n m (unnamed-prog-> . prog->-tail)))
))

(defun prog->*-function-second-form-p (fn)
(member fn *prog->*-function-second-forms*))

(defun prog->-special-form (fn)
(assoc fn *prog->-special-forms* :key #'first))

(defun prog->-special-form-pattern (fn)
(car (prog->-special-form fn)))

(defun prog->-special-form-args (fn)
(rest (prog->-special-form-pattern fn)))

(defun prog->-special-form-result (fn)
(cdr (prog->-special-form fn)))

(defun prog->-special-form-match-error (form)
(error "~S doesn't match prog-> special form ~S."
	 form (prog->-special-form-pattern (first form))))

(defun prog->-no-variable-error (form)
(error "No variable to assign value to in (prog-> ... ~S ...)."
	 form))

(defun prog->-too-many-variables-error (form)
(error "More than one variable to assign value to in (prog-> ... ~S
...)."
	 form))

(defun prog->-too-many->s-error (form)
(error "More than one -> in (prog-> ... ~S ...)." form))

(defun prog->-unrecognized->-atom (atom form)
(error "Unrecognized operation ~S in (prog-> ... ~S ...)."
	 atom form))

(defun prog->-atom (x)
(and (symbolp x)
(>= (length (string x)) 2)
(string= x "->" :end1 2)))

(defun prog->*-function-argument (forms args)
(cond
((and (null (rest forms))
	  (consp (first forms))
	  (eq (caar forms) 'funcall)
	  (equal (cddar forms) args))
(cadar forms))
((and (null (rest forms))
	  (consp (first forms))
	  (not (#-(or lucid (and mcl (not openmcl))) special-operator-p
;;		#-(or allegro lucid) special-form-p
;;		#+allegro cltl1:special-form-p
		#+(and mcl (not openmcl)) special-form-p
		#+lucid lisp:special-form-p
		(caar forms)))
	  (not (macro-function (caar forms)))
	  (equal (cdar forms) args))
`(function ,(caar forms)))
(t
`(function (lambda ,args ,@forms)))))



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