rem和mod的區別
[CLisp]有限狀態機練習

Common Lisp常用輔助工具

λ posted @ 2011年12月12日 21:09 in Mixture with tags lisp package , 5628 阅读

全是《Common Lisp: An Introduction to Symbolic Computing》介紹的,使用方法自己找去吧。

使用方法?

(load "文件路徑")

SDRAW:畫出cons cell的結構

;;; -*- Mode: Lisp -*-
;;;
;;; SDRAW - draws cons cell structures.
;;;
;;; From the book "Common Lisp:  A Gentle Introduction to
;;;      Symbolic Computation" by David S. Touretzky.  
;;; The Benjamin/Cummings Publishing Co., 1990.
;;;
;;; This is the generic version; it will work in any legal Common Lisp.
;;; Revised to include support for circular structures.
;;; Revised again, August, 2003, to work with ANSI Common Lisp and Allegro v6.
;;;
;;; User-level routines:
;;;   (sdraw obj)  - draws obj on the display
;;;   (sdraw-loop) - puts the user in a read-eval-draw loop
;;;   (scrawl obj) - interactively crawl around obj
;;;
;;; Variables:
;;;   *sdraw-print-circle*    If bound, overrides *print-circle*.
;;;   *sdraw-leading-arrow*   Initially nil.  Set to t to get leading arrows.
;;;

(defpackage :sdraw
  (:use :common-lisp)
  (:export sdraw sdraw-loop scrawl *sdraw-print-circle* *sdraw-leading-arrow*))

(in-package :sdraw)

(export '(sdraw::sdraw sdraw::sdraw-loop sdraw::scrawl
	  sdraw::*sdraw-print-circle* sdraw::*sdraw-leading-arrow*))

(shadowing-import  '(sdraw::sdraw sdraw::sdraw-loop sdraw::scrawl
		     sdraw::*sdraw-print-circle*
		     sdraw::*sdraw-leading-arrow*)
		   (find-package :common-lisp-user))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; The parameters below are in units of characters (horizontal)
;;; and lines (vertical).  They apply to all versions of SDRAW,
;;; but their values may change if cons cells are being drawn as
;;; bit maps rather than as character sequences.

(defparameter *sdraw-display-width* 79.)
(defparameter *sdraw-horizontal-atom-cutoff* 79.)
(defparameter *sdraw-horizontal-cons-cutoff* 65.)

(defparameter *etc-string* "etc.")
(defparameter *etc-spacing* 4.)

(defparameter *inter-atom-h-spacing* 3.)
(defparameter *cons-atom-h-arrow-length* 9.)
(defparameter *inter-cons-v-arrow-length* 3.)
(defparameter *cons-v-arrow-offset-threshold* 2.)
(defparameter *cons-v-arrow-offset-value* 1.)
(defparameter *leading-arrow-length* 4)

(defparameter *sdraw-num-lines* 25)
(defparameter *sdraw-vertical-cutoff* 22.)

(defvar *sdraw-leading-arrow* nil)
(defvar *sdraw-print-circle*)
(defvar *sdraw-circular-switch*)
(defvar *circ-detected* nil)
(defvar *circ-label-counter* 0)
(defparameter *circ-hash-table* (make-hash-table :test #'eq :size 20))

(defvar *line-endings* (make-array *sdraw-num-lines*))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; SDRAW and subordinate definitions.

(defun sdraw (obj &aux (*circ-detected* nil))
  (let ((*sdraw-circular-switch*
	 (if (boundp '*sdraw-print-circle*) *sdraw-print-circle*
	     *print-circle*))
	(start-col (if *sdraw-leading-arrow* *leading-arrow-length* 0)))
    (init-struct1 start-col)
    (clrhash *circ-hash-table*)
    (let* ((first-layout (struct1 obj 0 start-col 0 nil))
	   (second-layout (when *circ-detected*
			    (init-struct1 start-col)
			    (struct1 obj 0 start-col 0 t))))
      (draw-structure (or second-layout first-layout))
      (values))))



(defun init-struct1 (start-col)
  (setf *circ-label-counter* 0)
  (fill *line-endings* most-negative-fixnum)
  (struct-record-position 0 (- start-col *inter-atom-h-spacing*)))

(defun never-seen? (obj)
  (null (gethash obj *circ-hash-table*)))

(defun seen-twice? (obj)
  (numberp (gethash obj *circ-hash-table*)))

(defun needs-label? (obj)
  (zerop (gethash obj *circ-hash-table*)))



(defun struct1 (obj row root-col adj second-pass)
  (cond ((>= row *sdraw-vertical-cutoff*) (struct-process-etc row root-col adj))
	((not second-pass)
	 (enter-in-hash-table obj)
	 (struct-first-pass obj row root-col adj))
	(t (struct-second-pass obj row root-col adj))))

(defun enter-in-hash-table (obj)
  (unless (or (not *sdraw-circular-switch*)
	      (numberp obj)
	      (and (symbolp obj) (symbol-package obj)))
    (cond ((never-seen? obj) (setf (gethash obj *circ-hash-table*) t))
	  (t (setf (gethash obj *circ-hash-table*) 0)
	     (setf *circ-detected* t)))))

(defun struct-first-pass (obj row root-col adj)
  (if (seen-twice? obj)
      (struct-process-circ-reference obj row root-col adj)
      (if (atom obj)
	  (struct-unlabeled-atom (format nil "~S" obj) row root-col adj)
	  (struct-unlabeled-cons obj row root-col adj nil))))

(defun struct-second-pass (obj row root-col adj)
  (cond ((not (seen-twice? obj))
	 (if (atom obj)
	     (struct-unlabeled-atom (format nil "~S" obj) row root-col adj)
	     (struct-unlabeled-cons obj row root-col adj t)))
	((needs-label? obj)
	 (if (atom obj)
	     (struct-label-atom obj row root-col adj)
	     (struct-label-cons obj row root-col adj)))
	(t (struct-process-circ-reference obj row root-col adj))))


;;; Handle the simplest case:  an atom or cons with no #n= label.

(defun struct-unlabeled-atom (atom-string row root-col adj)
  (let* ((start-col (struct-find-start row root-col adj))
	 (end-col (+ start-col adj (length atom-string))))
    (cond ((< end-col *sdraw-horizontal-atom-cutoff*)
	   (struct-record-position row end-col)
	   (list 'atom row (+ start-col adj) atom-string))
	  (t (struct-process-etc row root-col adj)))))

(defun struct-unlabeled-cons (obj row root-col adj second-pass)
  (let* ((cons-start (struct-find-start row root-col adj))
	 (car-structure
	  (struct1 (car obj)
		   (+ row *inter-cons-v-arrow-length*)
		   cons-start adj second-pass))
	 (start-col (third car-structure)))
    (if (>= start-col *sdraw-horizontal-cons-cutoff*)
	(struct-process-etc row root-col adj)
	(progn
	  (struct-record-position row (- (+ start-col
					    *cons-atom-h-arrow-length*)
					 adj *inter-atom-h-spacing*))
	  (list 'cons row start-col car-structure
		(struct1 (cdr obj) row (+ start-col *cons-atom-h-arrow-length*)
			 0 second-pass))))))

(defun struct-process-etc (row root-col adj)
  (let ((start-col (struct-find-start row root-col adj)))
    (struct-record-position
      row
      (+ start-col adj (length *etc-string*) *etc-spacing*))
    (list 'msg row (+ start-col adj) *etc-string*)))




;;; Handle objects that need to be labeled with #n=.
;;; Called only on the second pass.

(defun struct-label-atom (obj row root-col adj)
  (assign-label obj)
  (let* ((circ-string (format nil "#~S=" (gethash obj *circ-hash-table*)))
	 (newadj (struct-find-adj row root-col adj (length circ-string)))
	 (atom-string (format nil "~S" obj))
	 (start-col (struct-find-start row root-col adj))
	 (end-col (+ start-col newadj (length atom-string))))
    (cond ((< end-col *sdraw-horizontal-atom-cutoff*)
	   (struct-record-position row end-col)
	   (list 'atom row (+ start-col newadj) atom-string circ-string))
	  (t (struct-process-etc row root-col adj)))))

(defun struct-label-cons (obj row root-col adj)
  (assign-label obj)
  (let* ((string (format nil "#~S=" *circ-label-counter*))
	 (newadj (struct-find-adj row root-col adj (length string)))
	 (cons-start (struct-find-start row root-col adj))
	 (car-structure
	  (struct1 (car obj)
		   (+ row *inter-cons-v-arrow-length*)
		   cons-start newadj t))
	 (start-col (third car-structure)))
    (if (>= start-col *sdraw-horizontal-cons-cutoff*)
	(struct-process-etc row root-col adj)
	(progn
	  (struct-record-position row (- (+ start-col
					    *cons-atom-h-arrow-length*)
					 adj *inter-atom-h-spacing*))
	  (list 'cons row start-col car-structure
		(struct1 (cdr obj) row
			 (+ start-col *cons-atom-h-arrow-length*) 0 t)
		string)))))

(defun assign-label (obj)
  (setf (gethash obj *circ-hash-table*)
	(incf *circ-label-counter*)))


;;; Handle circular references by displaying them as #n#.
;;; When called on the first pass, this function always uses a label of 0.
;;; It will get the label right on the second pass.

(defun struct-process-circ-reference (obj row root-col adj)
  (let ((start-col (struct-find-start row root-col adj))
	(string (format nil "#~S#" (gethash obj *circ-hash-table*))))
    (struct-record-position
      row
      (+ (+ start-col adj) (length string)))
    (list 'msg row (+ start-col adj) string)))



;;; Support functions.

(defun struct-find-start (row root-col adj)
  (max root-col
       (- (+ *inter-atom-h-spacing* (aref *line-endings* row)) adj)))

(defun struct-find-adj (row col adj size)
  (let* ((line-end (max 0 (+ *inter-atom-h-spacing*
			     (aref *line-endings* row))))
	 (newadj (- line-end (- col (max size adj)))))
    (max adj (min (max newadj 0) size))))

(defun struct-record-position (row end-col)
  (setf (aref *line-endings* row) end-col))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; SDRAW-LOOP and subordinate definitions.

(defparameter *sdraw-loop-prompt-string* "S> ")

(defun sdraw-loop ()
  "Read-eval-print loop using sdraw to display results."
  (format t "~&Type any Lisp expression, or :ABORT to exit.~%~%")
  (sdl1))

(defun sdl1 ()
  (loop
    (format t "~&~A" *sdraw-loop-prompt-string*)
    (force-output t)
    (let ((form (read)))
      (setf +++ ++
            ++  +
            +   -
            -   form)
      (if (eq form :abort) (return-from sdl1))
      (let ((result (eval form)))
        (setf /// //
              //  /
              /   (list result)
              *** **
              **  *
              *   result)
        (display-sdl-result *)))))

(defun display-sdl-result (result)
  (sdraw result)
  (let* ((*print-circle* (if (boundp '*sdraw-print-circle*)
			     *sdraw-print-circle*
		             *print-circle*))
	 (*print-length* nil)
	 (*print-level* nil)
	 (*print-pretty* #+cmu t #-cmu nil)
	 (full-text (format nil "Result:  ~S" result))
	 (text (if (> (length full-text)
		      *sdraw-display-width*)
		   (concatenate 'string
		     (subseq full-text 0 (- *sdraw-display-width* 4))
		     "...)")
		   full-text)))
    (if (consp result)
        (format t "~%~A~%" text))
    (terpri)))

(defun display-sdl-error (error)
  (format t "~A~%~%" error))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; SCRAWL and subordinate definitions.

(defparameter *scrawl-prompt-string* "SCRAWL> ")
(defvar *scrawl-object* nil)
(defvar *scrawl-current-obj*)
(defvar *extracting-sequence* nil)

(defun scrawl (obj)
  "Read-eval-print loop to travel through list"
  (format t "~&Crawl through list:  'H' for help, 'Q' to quit.~%~%")
  (setf *scrawl-object* obj)
  (scrawl-start-cmd)
  (scrawl1))

(defun scrawl1 ()
  (loop
    (format t "~&~A" *scrawl-prompt-string*)
    (force-output t)
    (let ((command (read-uppercase-char)))
      (case command
	(#\A (scrawl-car-cmd))
	(#\D (scrawl-cdr-cmd))
	(#\B (scrawl-back-up-cmd))
	(#\S (scrawl-start-cmd))
	(#\H (display-scrawl-help))
	(#\Q (return))
	(t (display-scrawl-error))))))

(defun scrawl-car-cmd ()
  (cond ((consp *scrawl-current-obj*)
	 (push 'car *extracting-sequence*)
	 (setf *scrawl-current-obj* (car *scrawl-current-obj*)))
	(t (format t
	     "~&Can't take CAR or CDR of an atom.  Use B to back up.~%")))
  (display-scrawl-result))

(defun scrawl-cdr-cmd ()
  (cond ((consp *scrawl-current-obj*)
	 (push 'cdr *extracting-sequence*)
	 (setf *scrawl-current-obj* (cdr *scrawl-current-obj*)))
	(t (format t
	     "~&Can't take CAR or CDR of an atom.  Use B to back up.~%")))
  (display-scrawl-result))

(defun scrawl-back-up-cmd ()
  (cond (*extracting-sequence*
	 (pop *extracting-sequence*)
	 (setf *scrawl-current-obj*
	       (extract-obj *extracting-sequence* *scrawl-object*)))
	(t (format t "~&Already at beginning of object.")))
  (display-scrawl-result))

(defun scrawl-start-cmd ()
  (setf *scrawl-current-obj* *scrawl-object*)
  (setf *extracting-sequence* nil)
  (display-scrawl-result))

(defun extract-obj (seq obj)
  (reduce #'funcall
	  seq
	  :initial-value obj
	  :from-end t))

(defun get-car/cdr-string ()
  (if (null *extracting-sequence*)
      (format nil "'~S" *scrawl-object*)
      (format nil "(c~Ar '~S)"
	      (map 'string #'(lambda (x)
			       (ecase x
				 (car #\a)
				 (cdr #\d)))
		   *extracting-sequence*)
	      *scrawl-object*)))

(defun display-scrawl-result (&aux (*print-length* nil)
				   (*print-level* nil)
				   (*print-pretty* #+cmu t #-cmu nil)
				   (*print-circle* t))
  (let* ((extract-string (get-car/cdr-string))
	 (text (if (> (length extract-string) *sdraw-display-width*)
		   (concatenate 'string
		    (subseq extract-string 0
			    (- *sdraw-display-width* 4))
		    "...)")
		   extract-string)))
    (sdraw *scrawl-current-obj*)
    (format t "~&~%~A~%~%" text)))

(defun display-scrawl-help ()
  (format t "~&Legal commands:  A)car   D)cdr  B)back up~%")
  (format t "~&                 S)start Q)quit H)help~%"))

(defun display-scrawl-error ()
  (format t "~&Illegal command.~%")
  (display-scrawl-help))

(defun read-uppercase-char ()
  (let ((response (read-line)))
    (and (plusp (length response))
	 (char-upcase (char response 0)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; The following definitions are specific to the tty implementation.

(defparameter *cons-string* "[*|*]")
(defparameter *cons-cell-flatsize* 5.)
(defparameter *cons-h-arrowshaft-char* #\-)
(defparameter *cons-h-arrowhead-char* #\>)
(defparameter *cons-v-line* "|")
(defparameter *cons-v-arrowhead* "v")

(defvar *textline-array* (make-array *sdraw-num-lines*))
(defvar *textline-lengths* (make-array *sdraw-num-lines*))

(eval-when (eval load)
  (dotimes (i *sdraw-num-lines*)
    (setf (aref *textline-array* i)
	  (make-string *sdraw-display-width*))))

(defun char-blt (row start-col string)
  (let ((spos (aref *textline-lengths* row))
	(line (aref *textline-array* row)))
    (do ((i spos (1+ i)))
	((>= i start-col))
      (setf (aref line i) #\Space))
    (replace line string :start1 start-col)
    (setf (aref *textline-lengths* row)
	  (+ start-col (length string)))))

(defun draw-structure (directions)
  (fill *textline-lengths* 0.)
  (when *sdraw-leading-arrow* (draw-leading-arrow))
  (follow-directions directions)
  (dump-display))

(defun draw-leading-arrow ()
  (do ((i 0 (1+ i)))
      ((>= (1+ i) *leading-arrow-length*)
       (char-blt 0 i (string *cons-h-arrowhead-char*)))
    (char-blt 0 i (string *cons-h-arrowshaft-char*))))

(defun follow-directions (dirs &optional is-car)
  (ecase (car dirs)
    (cons (draw-cons dirs))
    ((atom msg) (draw-msg dirs is-car))))

(defun draw-cons (obj)
  (let* ((row (second obj))
	 (col (third obj))
	 (car-component (fourth obj))
	 (cdr-component (fifth obj))
	 (string (sixth obj))
	 (line (aref *textline-array* row))
	 (h-arrow-start (+ col *cons-cell-flatsize*))
	 (h-arrowhead-col (1- (third cdr-component)))
	 (cdr-string? (if (eq 'cons (first cdr-component))
			  (sixth cdr-component)
			  (fifth cdr-component))))
    (if cdr-string? (decf h-arrowhead-col (length cdr-string?)))
    (char-blt row (- col (length string))
	      (if string (concatenate 'string string *cons-string*)
		  *cons-string*))
    (do ((i h-arrow-start (1+ i)))
	((>= i h-arrowhead-col))
      (setf (aref line i) *cons-h-arrowshaft-char*))
    (setf (aref line h-arrowhead-col) *cons-h-arrowhead-char*)
    (setf (aref *textline-lengths* row) (1+ h-arrowhead-col))
    (char-blt (+ row 1) (+ col 1) *cons-v-line*)
    (char-blt (+ row 2) (+ col 1) *cons-v-arrowhead*)
    (follow-directions car-component t)
    (follow-directions cdr-component)))

(defun draw-msg (obj is-car)
  (let* ((row (second obj))
	 (col (third obj))
	 (string (fourth obj))
	 (circ-string (fifth obj)))
    (if circ-string (setf string (concatenate 'string circ-string string)))
    (char-blt row
	      (+ (- col (length circ-string))
		 (if (and is-car
			  (<= (length string)
			      *cons-v-arrow-offset-threshold*))
		     *cons-v-arrow-offset-value*
		     0))
	      string)))

(defun dump-display ()
  (terpri)
  (dotimes (i *sdraw-num-lines*)
    (let ((len (aref *textline-lengths* i)))
      (if (plusp len)
	  (format t "~&~A"
		  (subseq (aref *textline-array* i) 0 len))
	  (return nil))))
  (terpri))

DTRACE:跟蹤S-expression的執行過程

;;; -*- Mode: Lisp; Package: DTRACE -*-

;;; DTRACE is a portable alternative to the Common Lisp TRACE and UNTRACE
;;; macros.  It offers a more detailed display than most tracing tools.
;;;
;;; From the book "Common Lisp:  A Gentle Introduction to
;;;      Symbolic Computation" by David S. Touretzky.  
;;; The Benjamin/Cummings Publishing Co., 1990.
;;;
;;; This is the generic version.  It should work in any legal Common Lisp.
;;; Revised August, 2003, to work with ANSI Common Lisp and Allegro v6.
;;;
;;; User-level routines:
;;;   DTRACE  - same syntax as TRACE
;;;   DUNTRACE - same syntax as UNTRACE

(defpackage :dtrace
  (:use :common-lisp)
  (:export dtrace duntrace
	   *dtrace-print-length* *dtrace-print-level*
	   *dtrace-print-circle* *dtrace-print-pretty*
	   *dtrace-print-array*))

(in-package :dtrace)	    

(eval-when (eval load)
  (shadowing-import '(dtrace duntrace) (find-package :common-lisp-user)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; DTRACE and subordinate routines.

(defparameter *dtrace-print-length* 7)
(defparameter *dtrace-print-level*  4)
(defparameter *dtrace-print-circle* t)
(defparameter *dtrace-print-pretty* nil)
(defparameter *dtrace-print-array* *print-array*)

(defvar *traced-functions* nil)
(defvar *trace-level* 0)

(defmacro dtrace (&rest function-names)
  "Turns on detailed tracing for specified functions.  Undo with DUNTRACE."
  (if (null function-names)
      (list 'quote *traced-functions*)
      (list 'quote (mapcan #'dtrace1 function-names))))

(defun dtrace1 (name)
  (unless (symbolp name)
    (format *error-output* "~&~S is an invalid function name." name)
    (return-from dtrace1 nil))
  (unless (fboundp name)
    (format *error-output* "~&~S undefined function." name)
    (return-from dtrace1 nil))
  (eval `(untrace ,name))	;; if they're tracing it, undo their trace
  (duntrace1 name)		;; if we're tracing it, undo our trace
  (when (special-operator-p name)
    (format *error-output*
	    "~&Can't trace ~S because it's a special form." name)
    (return-from dtrace1 nil))
  (if (macro-function name)
      (trace-macro name)
      (trace-function name))
  (setf *traced-functions* (nconc *traced-functions* (list name)))
  (list name))

;;; The functions below reference DISPLAY-xxx routines that can be made
;;; implementation specific for fancy graphics.  Generic versions of
;;; these routines are defined later in this file.

(defmacro with-dtrace-printer-settings (&body body)
  `(let ((*print-length* *dtrace-print-length*)
	 (*print-level* *dtrace-print-level*)
	 (*print-circle* *dtrace-print-circle*)
	 (*print-pretty* *dtrace-print-pretty*)
	 (*print-array* *dtrace-print-array*))
     ,@body))

(defun trace-function (name)
  (let* ((formal-arglist (fetch-arglist name))
	 (old-defn (symbol-function name))
	 (new-defn
	  #'(lambda (&rest argument-list)
	      (let ((result nil))
		(display-function-entry name)
		(let ((*trace-level* (1+ *trace-level*)))
		  (with-dtrace-printer-settings
		   (show-function-args argument-list formal-arglist))
		  (setf result (multiple-value-list
				(apply old-defn argument-list))))
		(display-function-return name result)
		(values-list result)))))
    (setf (get name 'original-definition) old-defn)
    (setf (get name 'traced-definition) new-defn)
    (setf (get name 'traced-type) 'defun)
    (setf (symbol-function name) new-defn)))

(defun trace-macro (name)
  (let* ((formal-arglist (fetch-arglist name))
	 (old-defn (macro-function name))
	 (new-defn
	  #'(lambda (macro-args env)
	      (let ((result nil))
		(display-function-entry name 'macro)
		(let ((*trace-level* (1+ *trace-level*)))
		  (with-dtrace-printer-settings
		   (show-function-args macro-args formal-arglist))
		  (setf result (funcall old-defn macro-args env)))
	(display-function-return name (list result) 'macro)
		(values result)))))
    (setf (get name 'original-definition) old-defn)
    (setf (get name 'traced-definition) new-defn)
    (setf (get name 'traced-type) 'defmacro)
    (setf (macro-function name) new-defn)))

(defun show-function-args (actuals formals &optional (argcount 0))
  (cond ((null actuals) nil)
	((null formals) (handle-args-numerically actuals argcount))
	(t (case (first formals)
	     (&optional (show-function-args
			 actuals (rest formals) argcount))
	     (&rest (show-function-args
		     (list actuals) (rest formals) argcount))
	     (&key (handle-keyword-args actuals))
	     (&aux (show-function-args actuals nil argcount))
	     (t (handle-one-arg (first actuals) (first formals))
		(show-function-args (rest actuals)
				    (rest formals)
				    (1+ argcount)))))))

(defun handle-args-numerically (actuals argcount)
  (dolist (x actuals)
    (incf argcount)
    (display-arg-numeric x argcount)))

(defun handle-one-arg (val varspec)
  (cond ((atom varspec) (display-one-arg val varspec))
	(t (display-one-arg val (first varspec))
	   (if (third varspec)
	       (display-one-arg t (third varspec))))))

(defun handle-keyword-args (actuals)
  (cond ((null actuals))
	((keywordp (first actuals))
	 (display-one-arg (second actuals) (first actuals))
	 (handle-keyword-args (rest (rest actuals))))
	(t (display-one-arg actuals "Extra args:"))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; DUNTRACE and subordinate routines.

(defmacro duntrace (&rest function-names)
  "Turns off tracing for specified functions.  
   With no args, turns off all tracing."
  (setf *trace-level* 0)  ;; safety precaution
  (list 'quote
	(mapcan #'duntrace1 (or function-names *traced-functions*))))

(defun duntrace1 (name)
  (unless (symbolp name)
    (format *error-output* "~&~S is an invalid function name." name)
    (return-from duntrace1 nil))
  (setf *traced-functions* (delete name *traced-functions*))
  (let ((orig-defn (get name 'original-definition 'none))
	(traced-defn (get name 'traced-definition))
	(traced-type (get name 'traced-type 'none)))
    (unless (or (eq orig-defn 'none)
		(not (fboundp name))
		(not (equal traced-defn  ;; did it get redefined?
			 (ecase traced-type
			   (defun (symbol-function name))
			   (defmacro (macro-function name))))))
      (ecase traced-type
	(defun (setf (symbol-function name) orig-defn))
	(defmacro (setf (macro-function name) orig-defn)))))
  (remprop name 'traced-definition)
  (remprop name 'traced-type)
  (remprop name 'original-definition)
  (list name))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Display routines.
;;;
;;; The code below generates vanilla character output for ordinary 
;;; displays.  It can be replaced with special graphics code if the
;;; implementation permits, e.g., on a PC you can use the IBM graphic
;;; character set to draw nicer-looking arrows.  On a color PC you 
;;; can use different colors for arrows, for function names, for 
;;; argument values, and so on.

(defparameter *entry-arrow-string* "----")
(defparameter *vertical-string*    "|   ")
(defparameter *exit-arrow-string*  " \\--")

(defparameter *trace-wraparound* 15)

(defun display-function-entry (name &optional ftype)
  (space-over)
  (draw-entry-arrow)
  (format *trace-output* "Enter ~S" name)
  (if (eq ftype 'macro)
      (format *trace-output* " macro")))

(defun display-one-arg (val name)
  (space-over)
  (format *trace-output*
	  (typecase name
	    (keyword "  ~S ~S")
	    (string  "  ~A ~S")
	    (t "  ~S = ~S"))
	  name val))

(defun display-arg-numeric (val num)
  (space-over)
  (format *trace-output* "  Arg-~D = ~S" num val))

(defun display-function-return (name results &optional ftype)
  (with-dtrace-printer-settings
    (space-over)
    (draw-exit-arrow)
    (format *trace-output* "~S ~A"
	    name
	    (if (eq ftype 'macro) "expanded to" "returned"))
    (cond ((null results))
	  ((null (rest results)) (format *trace-output* " ~S" (first results)))
	  (t (format *trace-output* " values ~{~S, ~}~s"
		     (butlast results)
		     (car (last results)))))))

(defun space-over ()
  (format *trace-output* "~&")
  (dotimes (i (mod *trace-level* *trace-wraparound*))
    (format *trace-output* "~A" *vertical-string*)))

(defun draw-entry-arrow ()
  (format *trace-output* "~A" *entry-arrow-string*))

(defun draw-exit-arrow ()
  (format *trace-output* "~A" *exit-arrow-string*))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; The function FETCH-ARGLIST is implementation dependent.  It 
;;; returns the formal argument list of a function as it would 
;;; appear in a DEFUN or lambda expression, including any lambda
;;; list keywords.  Here are versions of FETCH-ARGLIST for three
;;; Lisp implementations.

;;; Minimal generic version
#-(or lucid allegro gclisp kcl cmu)
  (defun fetch-arglist (fn)
    (declare (ignore fn))
    nil)

;;; Lucid version
#+lucid
  (defun fetch-arglist (fn)
    (system::arglist fn))


#+allegro
  (defun fetch-arglist (fn)
    (excl::arglist fn))

;;; GCLisp 1.1 version
#+gclisp
  (defun fetch-arglist (fn)
    (if (macro-function fn)
	'(&rest "Form =")
	(lambda-list fn)))

;;; KCL version
#+kcl
(defun fetch-arglist (fn)
  (let ((x (symbol-function fn)))
    (cond ((atom x) nil)
	  ((eq (first x) 'macro) (list '&rest "Form ="))
	  (t (third x)))))

;;; CMU Common Lisp version.  This version looks in a symbol's
;;; function cell and knows how to take apart lexical closures
;;; and compiled code objects found there.
#+cmu
  (defun fetch-arglist (x &optional original-x)
    (cond ((symbolp x) (fetch-arglist (symbol-function x) x))
	  ((compiled-function-p x)
	   (read-from-string
	    (lisp::%primitive header-ref x
			      lisp::%function-arg-names-slot)))
	  ((listp x) (case (first x)
		       (lambda (second x))
		       (lisp::%lexical-closure% (fetch-arglist (second x)))
		       (system:macro '(&rest "Form ="))
		       (t '(&rest "Arglist:"))))
	  (t (cerror (format nil
                        "Use a reasonable default argument list for ~S"
		        original-x)
		"Unkown object in function cell of ~S:  ~S" original-x x)
	     '())))

PPMX:用較優美的格式打印出macro的擴展

;;; -*- Mode: Lisp; Package: USER -*-
;;;
;;; PPMX - pretty prints a macro expansion
;;;
;;; From the book "Common Lisp:  A Gentle Introduction to
;;;      Symbolic Computation" by David S. Touretzky.  
;;; The Benjamin/Cummings Publishing Co., 1990.
;;;
;;; Example of use:  (ppmx (incf a))


(defmacro ppmx (form)
  "Pretty prints the macro expansion of FORM."
  `(let* ((exp1 (macroexpand-1 ',form))
	  (exp (macroexpand exp1))
	  (*print-circle* nil))
     (cond ((equal exp exp1)
	    (format t "~&Macro expansion:")
	    (pprint exp))
	   (t (format t "~&First step of expansion:")
	      (pprint exp1)
	      (format t "~%~%Final expansion:")
	      (pprint exp)))
     (format t "~%~%")
     (values)))

;; 這是我自己加上去的,一步步地展開。
(defmacro ppmxs (form &key (depth 1))
  "Progressive prints the macro expansions of FORM."
  `(let ((exp (macroexpand-1 ',form))
         (*print-circle* nil))
     (cond ((equal exp (macroexpand-1 exp))
            (format t "~&The final expansion:")
            (pprint exp))
           (t (format t "~&The ~:R step of expansion:" ,depth)
              (pprint exp)
              (format t "~%~%")
              (ppmxs ,(macroexpand-1 form) :depth (1+ ,depth))))
     (values)))

CLisp內置函數:

  • TRACE:比DTRACE爛一點點
  • INSPECT:查看某個object的信息。
  • DRIBBLE:記錄CLisp的輸入輸出到文件中
  • TIME:統計S-expression執行時間
  • ROOM:查看當前內存使用情況
  • GC:回收垃圾內存
  • BREAK、ERROR、WARN:拋出錯誤信息。

本網站無註明「轉載」的著作均由Jak Wings製作 CC BY-NC-SA 2.5
Creative Commons 保持署名-相同方式分享 2.5

JSC Result Dhaka Boa 说:
Sep 03, 2022 01:22:57 AM

Government of Bangladesh, Secondary and Higher Secondary Education Board has successfully completed those Junior School Certificate and Junior Dakil (Grade-8) annual final examination tests between 2nd to 11th November 2022 at all selected centers across the country along with Dhaka Division, JSC Result Dhaka Board and JSC & JDC Exams 2022 also completed successfully at all district schools of the Dhaka Board. According to the reports, there are a huge number of students are appeared for this Grade 8th standard terminal exams under Dhaka division and they are waiting for JSC Result 2022 Dhaka Board, right now the Secondary and Higher Secondary Education Board Dhaka has conducted the evaluation of answer sheet scripts to calculate subject wise and total marks of the student to announce JSC Result 2022 Dhaka Board.

Gyanodaya SBI 说:
Oct 30, 2022 06:08:56 PM

SBI E Learning: The banking sector requires lots of knowledge to help serve millions of customers visiting the bank each day. The SBI bank ensures all the bank employees are updated and learning to gain new certifications each time. Gyanodaya SBI The State bank of India implemented a new e learning portal where employees can learn new changes and updates in the banking sector.

Relieving Letter For 说:
Dec 23, 2022 05:36:58 PM

A relieving letter is an important document that a candidate must send to a new company when changing employment. This document demonstrates that the prospective applicant fulfilled all of their previous employer’s specified services and responsibilities. Relieving Letter Format The manner of a relieved letter should be professional, and the substance should be brief. Given that the employer’s name is on it, the employer should verify that it is properly drafted.

Emma 说:
Jan 19, 2023 06:53:07 PM

There are many different Common Lisp implementations, each with its own unique set of tools. However, there are also a number of cbd supplements tools that are common to most, if not all, Common Lisp implementations. These tools are known as Common Auxiliary Tools, or CATs. CATs include things like a debugger, a profiler, and a code coverage tool. They are designed to help you development, debug, and optimize your code. While they are not required, they can be extremely helpful, especially when you are first starting out with Common Lisp.

CIBIL score check fr 说:
Jan 21, 2023 11:04:37 PM

CIBIL is an organization and an entity gathers all the consumer’s loan, credit, payment and money related transaction, and this gives a general behavior example and statics allowing to generate a score for each customer also calls as CIBIL score. CIBIL score check free Check CIBIL score is before you try to apply for a home loan, want to buy something new on EMI, or need to request any credit facility for a loan, then the primary thing they would look for is what is your CIBIL score to be precise.

teachersbadi.in 说:
Apr 25, 2023 02:33:20 PM

TeachersBadi is information about education, students and teachers.‘TeachersBadi‘, the name itself discloses the nature of the site. The site is being launched and run by a dedicated Team for teachers, students and educators. We love to share mainly educational information teachersbadi.in and employees, teacher’s related content in the education world. TeachersBadi is information about education, students and teachers.‘TeachersBadi‘, the name itself discloses the nature of the site. The site is being launched and run by a dedicated Team for teachers,


登录 *


loading captcha image...
(输入验证码)
or Ctrl+Enter