Squashed 'third_party/lisp/trivial-backtrace/' content from commit 43ef7d9
git-subtree-dir: third_party/lisp/trivial-backtrace git-subtree-split: 43ef7d947f4b4de767d0f91f28b50d9c03ad29d6
This commit is contained in:
commit
cc026178a9
19 changed files with 809 additions and 0 deletions
15
.gitignore
vendored
Normal file
15
.gitignore
vendored
Normal file
|
@ -0,0 +1,15 @@
|
||||||
|
# really this is private to my build process
|
||||||
|
make/
|
||||||
|
common-lisp.net
|
||||||
|
.vcs
|
||||||
|
GNUmakefile
|
||||||
|
init-lisp.lisp
|
||||||
|
website/changelog.xml
|
||||||
|
|
||||||
|
|
||||||
|
trivial-backtrace.tar.gz
|
||||||
|
website/output/
|
||||||
|
test-results/
|
||||||
|
lift-local.config
|
||||||
|
*.dribble
|
||||||
|
*.fasl
|
25
COPYING
Normal file
25
COPYING
Normal file
|
@ -0,0 +1,25 @@
|
||||||
|
Copyright (c) 2008-2008 Gary Warren King (gwking@metabang.com)
|
||||||
|
|
||||||
|
Permission is hereby granted, free of charge, to any person obtaining a
|
||||||
|
copy of this software and associated documentation files (the "Software"),
|
||||||
|
to deal in the Software without restriction, including without limitation
|
||||||
|
the rights to use, copy, modify, merge, publish, distribute, sublicense,
|
||||||
|
and/or sell copies of the Software, and to permit persons to whom the
|
||||||
|
Software is furnished to do so, subject to the following conditions:
|
||||||
|
|
||||||
|
The above copyright notice and this permission notice shall be included in
|
||||||
|
all copies or substantial portions of the Software.
|
||||||
|
|
||||||
|
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||||
|
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||||
|
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
|
||||||
|
THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||||
|
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
|
||||||
|
FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
|
||||||
|
DEALINGS IN THE SOFTWARE.
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
Copyright (c) 2005-2007 Dr. Edi Weitz
|
||||||
|
|
||||||
|
BSD style license: http://www.opensource.org/licenses/bsd-license.php
|
127
dev/backtrace.lisp
Normal file
127
dev/backtrace.lisp
Normal file
|
@ -0,0 +1,127 @@
|
||||||
|
(in-package #:trivial-backtrace)
|
||||||
|
|
||||||
|
(defun print-condition (condition stream)
|
||||||
|
"Print `condition` to `stream` using the pretty printer."
|
||||||
|
(format
|
||||||
|
stream
|
||||||
|
"~@<An unhandled error condition has been signalled:~3I ~a~I~:@>~%~%"
|
||||||
|
condition))
|
||||||
|
|
||||||
|
(defun print-backtrace (error &key (output *debug-io*)
|
||||||
|
(if-exists :append)
|
||||||
|
(verbose nil))
|
||||||
|
"Send a backtrace for the error `error` to `output`.
|
||||||
|
|
||||||
|
The keywords arguments are:
|
||||||
|
|
||||||
|
* :output - where to send the output. This can be:
|
||||||
|
|
||||||
|
* a string (which is assumed to designate a pathname)
|
||||||
|
* an open stream
|
||||||
|
* nil to indicate that the backtrace information should be
|
||||||
|
returned as a string
|
||||||
|
|
||||||
|
* if-exists - what to do if output designates a pathname and
|
||||||
|
the pathname already exists. Defaults to :append.
|
||||||
|
|
||||||
|
* verbose - if true, then a message about the backtrace is sent
|
||||||
|
to \\*terminal-io\\*. Defaults to `nil`.
|
||||||
|
|
||||||
|
If the `output` is nil, the returns the backtrace output as a
|
||||||
|
string. Otherwise, returns nil.
|
||||||
|
"
|
||||||
|
(when verbose
|
||||||
|
(print-condition error *terminal-io*))
|
||||||
|
(multiple-value-bind (stream close?)
|
||||||
|
(typecase output
|
||||||
|
(null (values (make-string-output-stream) nil))
|
||||||
|
(string (values (open output :if-exists if-exists
|
||||||
|
:if-does-not-exist :create
|
||||||
|
:direction :output) t))
|
||||||
|
(stream (values output nil)))
|
||||||
|
(unwind-protect
|
||||||
|
(progn
|
||||||
|
(format stream "~&Date/time: ~a" (date-time-string))
|
||||||
|
(print-condition error stream)
|
||||||
|
(terpri stream)
|
||||||
|
(print-backtrace-to-stream stream)
|
||||||
|
(terpri stream)
|
||||||
|
(when (typep stream 'string-stream)
|
||||||
|
(get-output-stream-string stream)))
|
||||||
|
;; cleanup
|
||||||
|
(when close?
|
||||||
|
(close stream)))))
|
||||||
|
|
||||||
|
#+(or mcl ccl)
|
||||||
|
(defun print-backtrace-to-stream (stream)
|
||||||
|
(let ((*debug-io* stream))
|
||||||
|
(ccl:print-call-history :detailed-p nil)))
|
||||||
|
|
||||||
|
#+allegro
|
||||||
|
(defun print-backtrace-to-stream (stream)
|
||||||
|
(with-standard-io-syntax
|
||||||
|
(let ((*print-readably* nil)
|
||||||
|
(*print-miser-width* 40)
|
||||||
|
(*print-pretty* t)
|
||||||
|
(tpl:*zoom-print-circle* t)
|
||||||
|
(tpl:*zoom-print-level* nil)
|
||||||
|
(tpl:*zoom-print-length* nil))
|
||||||
|
(cl:ignore-errors
|
||||||
|
(let ((*terminal-io* stream)
|
||||||
|
(*standard-output* stream))
|
||||||
|
(tpl:do-command "zoom"
|
||||||
|
:from-read-eval-print-loop nil
|
||||||
|
:count t
|
||||||
|
:all t))))))
|
||||||
|
|
||||||
|
#+lispworks
|
||||||
|
(defun print-backtrace-to-stream (stream)
|
||||||
|
(let ((dbg::*debugger-stack*
|
||||||
|
(dbg::grab-stack nil :how-many most-positive-fixnum))
|
||||||
|
(*debug-io* stream)
|
||||||
|
(dbg:*debug-print-level* nil)
|
||||||
|
(dbg:*debug-print-length* nil))
|
||||||
|
(dbg:bug-backtrace nil)))
|
||||||
|
|
||||||
|
#+sbcl
|
||||||
|
;; determine how we're going to access the backtrace in the next
|
||||||
|
;; function
|
||||||
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||||
|
(when (find-symbol "*DEBUG-PRINT-VARIABLE-ALIST*" :sb-debug)
|
||||||
|
(pushnew :sbcl-debug-print-variable-alist *features*)))
|
||||||
|
|
||||||
|
#+sbcl
|
||||||
|
(defun print-backtrace-to-stream (stream)
|
||||||
|
(let (#+:sbcl-debug-print-variable-alist
|
||||||
|
(sb-debug:*debug-print-variable-alist*
|
||||||
|
(list* '(*print-level* . nil)
|
||||||
|
'(*print-length* . nil)
|
||||||
|
sb-debug:*debug-print-variable-alist*))
|
||||||
|
#-:sbcl-debug-print-variable-alist
|
||||||
|
(sb-debug:*debug-print-level* nil)
|
||||||
|
#-:sbcl-debug-print-variable-alist
|
||||||
|
(sb-debug:*debug-print-length* nil))
|
||||||
|
(sb-debug:backtrace most-positive-fixnum stream)))
|
||||||
|
|
||||||
|
#+clisp
|
||||||
|
(defun print-backtrace-to-stream (stream)
|
||||||
|
(system::print-backtrace :out stream))
|
||||||
|
|
||||||
|
#+(or cmucl scl)
|
||||||
|
(defun print-backtrace-to-stream (stream)
|
||||||
|
(let ((debug:*debug-print-level* nil)
|
||||||
|
(debug:*debug-print-length* nil))
|
||||||
|
(debug:backtrace most-positive-fixnum stream)))
|
||||||
|
|
||||||
|
|
||||||
|
;; must be after the defun above or the docstring may be wiped out
|
||||||
|
(setf (documentation 'print-backtrace-to-stream 'function)
|
||||||
|
"Send a backtrace of the current error to stream.
|
||||||
|
|
||||||
|
Stream is assumed to be an open writable file stream or a
|
||||||
|
string-output-stream. Note that `print-backtrace-to-stream`
|
||||||
|
will print a backtrace for whatever the Lisp deems to be the
|
||||||
|
*current* error.
|
||||||
|
")
|
||||||
|
|
||||||
|
|
10
dev/fallback.lisp
Normal file
10
dev/fallback.lisp
Normal file
|
@ -0,0 +1,10 @@
|
||||||
|
(in-package #:trivial-backtrace)
|
||||||
|
|
||||||
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||||
|
(unless (fboundp 'map-backtrace)
|
||||||
|
(defun map-backtrace (func)
|
||||||
|
(declare (ignore func))))
|
||||||
|
|
||||||
|
(unless (fboundp 'print-backtrace-to-stream)
|
||||||
|
(defun print-backtrace-to-stream (stream)
|
||||||
|
(format stream "~&backtrace output unavailable.~%"))))
|
105
dev/map-backtrace.lisp
Normal file
105
dev/map-backtrace.lisp
Normal file
|
@ -0,0 +1,105 @@
|
||||||
|
(in-package #:trivial-backtrace)
|
||||||
|
|
||||||
|
(defstruct frame
|
||||||
|
func
|
||||||
|
source-filename
|
||||||
|
source-pos
|
||||||
|
vars)
|
||||||
|
|
||||||
|
(defstruct var
|
||||||
|
name
|
||||||
|
value)
|
||||||
|
|
||||||
|
(defstruct pos-form-number
|
||||||
|
number)
|
||||||
|
|
||||||
|
(defmethod print-object ((pos-form-number pos-form-number) stream)
|
||||||
|
(cond
|
||||||
|
(*print-readably* (call-next-method))
|
||||||
|
(t
|
||||||
|
(format stream "f~A" (pos-form-number-number pos-form-number)))))
|
||||||
|
|
||||||
|
|
||||||
|
(defvar *trivial-backtrace-frame-print-specials*
|
||||||
|
'((*print-length* . 100)
|
||||||
|
(*print-level* . 20)
|
||||||
|
(*print-lines* . 5)
|
||||||
|
(*print-pretty* . t)
|
||||||
|
(*print-readably* . nil)))
|
||||||
|
|
||||||
|
(defun print-frame (frame stream)
|
||||||
|
(format stream "~A:~@[~A:~] ~A: ~%"
|
||||||
|
(or (ignore-errors (translate-logical-pathname (frame-source-filename frame))) (frame-source-filename frame) "<unknown>")
|
||||||
|
(frame-source-pos frame)
|
||||||
|
(frame-func frame))
|
||||||
|
(loop for var in (frame-vars frame)
|
||||||
|
do
|
||||||
|
(format stream " ~A = ~A~%" (var-name var)
|
||||||
|
(or (ignore-errors
|
||||||
|
(progv
|
||||||
|
(mapcar #'car *trivial-backtrace-frame-print-specials*)
|
||||||
|
(mapcar #'cdr *trivial-backtrace-frame-print-specials*)
|
||||||
|
(prin1-to-string
|
||||||
|
(var-value var))))
|
||||||
|
"<error>"))))
|
||||||
|
|
||||||
|
(defun map-backtrace (function)
|
||||||
|
(impl-map-backtrace function))
|
||||||
|
|
||||||
|
(defun print-map-backtrace (&optional (stream *debug-io*) &rest args)
|
||||||
|
(apply 'map-backtrace
|
||||||
|
(lambda (frame)
|
||||||
|
(print-frame frame stream)) args))
|
||||||
|
|
||||||
|
(defun backtrace-string (&rest args)
|
||||||
|
(with-output-to-string (stream)
|
||||||
|
(apply 'print-map-backtrace stream args)))
|
||||||
|
|
||||||
|
|
||||||
|
#+ccl
|
||||||
|
(defun impl-map-backtrace (func)
|
||||||
|
(ccl::map-call-frames (lambda (ptr)
|
||||||
|
(multiple-value-bind (lfun pc)
|
||||||
|
(ccl::cfp-lfun ptr)
|
||||||
|
(let ((source-note (ccl:function-source-note lfun)))
|
||||||
|
(funcall func
|
||||||
|
(make-frame :func (ccl::lfun-name lfun)
|
||||||
|
:source-filename (ccl:source-note-filename source-note)
|
||||||
|
:source-pos (let ((form-number (ccl:source-note-start-pos source-note)))
|
||||||
|
(when form-number (make-pos-form-number :number form-number)))
|
||||||
|
:vars (loop for (name . value) in (ccl::arguments-and-locals nil ptr lfun pc)
|
||||||
|
collect (make-var :name name :value value)))))))))
|
||||||
|
|
||||||
|
#+sbcl
|
||||||
|
(defun impl-map-backtrace (func)
|
||||||
|
(loop for f = (or sb-debug:*stack-top-hint* (sb-di:top-frame)) then (sb-di:frame-down f)
|
||||||
|
while f
|
||||||
|
do (funcall func
|
||||||
|
(make-frame :func
|
||||||
|
(ignore-errors
|
||||||
|
(sb-di:debug-fun-name
|
||||||
|
(sb-di:frame-debug-fun f)))
|
||||||
|
:source-filename
|
||||||
|
(ignore-errors
|
||||||
|
(sb-di:debug-source-namestring (sb-di:code-location-debug-source (sb-di:frame-code-location f))))
|
||||||
|
:source-pos
|
||||||
|
(ignore-errors ;;; XXX does not work
|
||||||
|
(let ((cloc (sb-di:frame-code-location f)))
|
||||||
|
(unless (sb-di:code-location-unknown-p cloc)
|
||||||
|
(format nil "tlf~Dfn~D"
|
||||||
|
(sb-di:code-location-toplevel-form-offset cloc)
|
||||||
|
(sb-di:code-location-form-number cloc)))))
|
||||||
|
:vars
|
||||||
|
(remove-if 'not
|
||||||
|
(map 'list (lambda(v)
|
||||||
|
(ignore-errors
|
||||||
|
(when (eq :valid
|
||||||
|
(sb-di:debug-var-validity v (sb-di:frame-code-location f)))
|
||||||
|
(make-var :name (sb-di:debug-var-symbol v)
|
||||||
|
:value (sb-di:debug-var-value v f)))))
|
||||||
|
(ignore-errors (sb-di::debug-fun-debug-vars (sb-di:frame-debug-fun f)))))))))
|
||||||
|
|
||||||
|
#-(or ccl sbcl)
|
||||||
|
(defun impl-map-backtrace (func)
|
||||||
|
(declare (ignore func))
|
||||||
|
(warn "unable to map backtrace for ~a" (lisp-implementation-type)))
|
75
dev/mucking.lisp
Normal file
75
dev/mucking.lisp
Normal file
|
@ -0,0 +1,75 @@
|
||||||
|
(in-package #:metabang.gsn)
|
||||||
|
|
||||||
|
#|
|
||||||
|
Need to account for different kinds of links
|
||||||
|
in gsn-nodes-from-json, need to return pairs of node and attributes
|
||||||
|
|
||||||
|
hash-table for nodes to prevent duplicates
|
||||||
|
queue or stack for nodes to expand
|
||||||
|
hash-table for links (triples of A link B?) to handle duplicates
|
||||||
|
|#
|
||||||
|
|
||||||
|
(defgeneric expand-node (context node)
|
||||||
|
)
|
||||||
|
|
||||||
|
(defgeneric find-neighbors (context node)
|
||||||
|
)
|
||||||
|
|
||||||
|
(defgeneric expand-node-p (context node)
|
||||||
|
)
|
||||||
|
|
||||||
|
(defgeneric add-node (context node)
|
||||||
|
)
|
||||||
|
|
||||||
|
(defgeneric add-link (context node neighbor direction)
|
||||||
|
)
|
||||||
|
|
||||||
|
(defgeneric update-node-data (context node data)
|
||||||
|
)
|
||||||
|
|
||||||
|
(defclass abstract-context ()
|
||||||
|
())
|
||||||
|
|
||||||
|
(defclass gsn-context (abstract-context)
|
||||||
|
())
|
||||||
|
|
||||||
|
(defparameter +gsn-root+ "http://socialgraph.apis.google.com/")
|
||||||
|
|
||||||
|
(defmethod expand-node ((context abstract-context) node)
|
||||||
|
(bind (((to from) (find-neighbors context node)))
|
||||||
|
(dolist (neighbor to)
|
||||||
|
(add-node context neighbor)
|
||||||
|
(add-link context node neighbor :to))
|
||||||
|
(dolist (neighbor from)
|
||||||
|
(add-node context neighbor)
|
||||||
|
(add-link context node neighbor :from))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(defmethod find-neighbors ((context gsn-context) node)
|
||||||
|
(bind (((result headers stream)
|
||||||
|
(http-get
|
||||||
|
(format nil "~alookup?edo=1&edi=1&pretty=1&q=~a"
|
||||||
|
+gsn-root+ node)))
|
||||||
|
json)
|
||||||
|
(unwind-protect
|
||||||
|
(setf json (json:decode-json stream))
|
||||||
|
(close strea))
|
||||||
|
(update-node-data context node json)
|
||||||
|
(list (gsn-nodes-from-json json :to)
|
||||||
|
(gsn-nodes-from-json json :from))))
|
||||||
|
|
||||||
|
(gsn-nodes-from-json x :from)
|
||||||
|
|
||||||
|
(defun gsn-test (who)
|
||||||
|
(destructuring-bind (result headers stream)
|
||||||
|
(http-get
|
||||||
|
(format nil "http://socialgraph.apis.google.com/lookup?edo=1&edi=1&pretty=1&q=~a" who))
|
||||||
|
(declare (ignore result headers))
|
||||||
|
(json:decode-json stream)))
|
||||||
|
|
||||||
|
(assoc :nodes_referenced
|
||||||
|
(assoc :nodes (gsn-test "TWITTER.COM/GWKING") :key #'first))
|
||||||
|
|
||||||
|
|
||||||
|
(setf x (gsn-test "TWITTER.COM/GWKING"))
|
13
dev/packages.lisp
Normal file
13
dev/packages.lisp
Normal file
|
@ -0,0 +1,13 @@
|
||||||
|
(in-package #:common-lisp-user)
|
||||||
|
|
||||||
|
(defpackage #:trivial-backtrace
|
||||||
|
(:use #:common-lisp)
|
||||||
|
(:export #:print-backtrace
|
||||||
|
#:print-backtrace-to-stream
|
||||||
|
#:print-condition
|
||||||
|
#:*date-time-format*
|
||||||
|
|
||||||
|
|
||||||
|
#:backtrace-string
|
||||||
|
#:map-backtrace))
|
||||||
|
|
104
dev/utilities.lisp
Normal file
104
dev/utilities.lisp
Normal file
|
@ -0,0 +1,104 @@
|
||||||
|
(in-package #:trivial-backtrace)
|
||||||
|
|
||||||
|
(defparameter *date-time-format* "%Y-%m-%d-%H:%M"
|
||||||
|
"The default format to use when printing dates and times.
|
||||||
|
|
||||||
|
* %% - A '%' character
|
||||||
|
* %d - Day of the month as a decimal number [01-31]
|
||||||
|
* %e - Same as %d but does not print the leading 0 for days 1 through 9
|
||||||
|
[unlike strftime[], does not print a leading space]
|
||||||
|
* %H - Hour based on a 24-hour clock as a decimal number [00-23]
|
||||||
|
*%I - Hour based on a 12-hour clock as a decimal number [01-12]
|
||||||
|
* %m - Month as a decimal number [01-12]
|
||||||
|
* %M - Minute as a decimal number [00-59]
|
||||||
|
* %S - Second as a decimal number [00-59]
|
||||||
|
* %w - Weekday as a decimal number [0-6], where Sunday is 0
|
||||||
|
* %y - Year without century [00-99]
|
||||||
|
* %Y - Year with century [such as 1990]
|
||||||
|
|
||||||
|
This code is borrowed from the `format-date` function in
|
||||||
|
[metatilities-base][].")
|
||||||
|
|
||||||
|
;; modified from metatilities-base
|
||||||
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||||
|
(defmacro generate-time-part-function (part-name position)
|
||||||
|
(let ((function-name
|
||||||
|
(intern
|
||||||
|
(concatenate 'string
|
||||||
|
(symbol-name 'time) "-" (symbol-name part-name))
|
||||||
|
:trivial-backtrace)))
|
||||||
|
`(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||||
|
(defun ,function-name
|
||||||
|
(&optional (universal-time (get-universal-time))
|
||||||
|
(time-zone nil))
|
||||||
|
,(format nil "Returns the ~(~A~) part of the given time." part-name)
|
||||||
|
(nth-value ,position
|
||||||
|
(apply #'decode-universal-time
|
||||||
|
universal-time time-zone))))))
|
||||||
|
|
||||||
|
(generate-time-part-function second 0)
|
||||||
|
(generate-time-part-function minute 1)
|
||||||
|
(generate-time-part-function hour 2)
|
||||||
|
(generate-time-part-function date 3)
|
||||||
|
(generate-time-part-function month 4)
|
||||||
|
(generate-time-part-function year 5)
|
||||||
|
(generate-time-part-function day-of-week 6)
|
||||||
|
(generate-time-part-function daylight-savings-time-p 7))
|
||||||
|
|
||||||
|
(defun date-time-string (&key (date/time (get-universal-time))
|
||||||
|
(format *date-time-format*))
|
||||||
|
(format-date format date/time nil))
|
||||||
|
|
||||||
|
(defun format-date (format date &optional stream time-zone)
|
||||||
|
(declare (ignore time-zone))
|
||||||
|
(let ((format-length (length format)))
|
||||||
|
(format
|
||||||
|
stream "~{~A~}"
|
||||||
|
(loop for index = 0 then (1+ index)
|
||||||
|
while (< index format-length) collect
|
||||||
|
(let ((char (aref format index)))
|
||||||
|
(cond
|
||||||
|
((char= #\% char)
|
||||||
|
(setf char (aref format (incf index)))
|
||||||
|
(cond
|
||||||
|
;; %% - A '%' character
|
||||||
|
((char= char #\%) #\%)
|
||||||
|
|
||||||
|
;; %d - Day of the month as a decimal number [01-31]
|
||||||
|
((char= char #\d) (format nil "~2,'0D" (time-date date)))
|
||||||
|
|
||||||
|
;; %e - Same as %d but does not print the leading 0 for
|
||||||
|
;; days 1 through 9. Unlike strftime, does not print a
|
||||||
|
;; leading space
|
||||||
|
((char= char #\e) (format nil "~D" (time-date date)))
|
||||||
|
|
||||||
|
;; %H - Hour based on a 24-hour clock as a decimal number [00-23]
|
||||||
|
((char= char #\H) (format nil "~2,'0D" (time-hour date)))
|
||||||
|
|
||||||
|
;; %I - Hour based on a 12-hour clock as a decimal number [01-12]
|
||||||
|
((char= char #\I) (format nil "~2,'0D"
|
||||||
|
(1+ (mod (time-hour date) 12))))
|
||||||
|
|
||||||
|
;; %m - Month as a decimal number [01-12]
|
||||||
|
((char= char #\m) (format nil "~2,'0D" (time-month date)))
|
||||||
|
|
||||||
|
;; %M - Minute as a decimal number [00-59]
|
||||||
|
((char= char #\M) (format nil "~2,'0D" (time-minute date)))
|
||||||
|
|
||||||
|
;; %S - Second as a decimal number [00-59]
|
||||||
|
((char= char #\S) (format nil "~2,'0D" (time-second date)))
|
||||||
|
|
||||||
|
;; %w - Weekday as a decimal number [0-6], where Sunday is 0
|
||||||
|
((char= char #\w) (format nil "~D" (time-day-of-week date)))
|
||||||
|
|
||||||
|
;; %y - Year without century [00-99]
|
||||||
|
((char= char #\y)
|
||||||
|
(let ((year-string (format nil "~,2A" (time-year date))))
|
||||||
|
(subseq year-string (- (length year-string) 2))))
|
||||||
|
|
||||||
|
;; %Y - Year with century [such as 1990]
|
||||||
|
((char= char #\Y) (format nil "~D" (time-year date)))
|
||||||
|
|
||||||
|
(t
|
||||||
|
(error "Ouch - unknown formatter '%~c" char))))
|
||||||
|
(t char)))))))
|
35
lift-standard.config
Normal file
35
lift-standard.config
Normal file
|
@ -0,0 +1,35 @@
|
||||||
|
;;; configuration for LIFT tests
|
||||||
|
|
||||||
|
;; settings
|
||||||
|
(:if-dribble-exists :supersede)
|
||||||
|
(:dribble "lift.dribble")
|
||||||
|
(:print-length 10)
|
||||||
|
(:print-level 5)
|
||||||
|
(:print-test-case-names t)
|
||||||
|
|
||||||
|
;; suites to run
|
||||||
|
(trivial-backtrace-test)
|
||||||
|
|
||||||
|
;; report properties
|
||||||
|
(:report-property :title "Trivial-Backtrace | Test results")
|
||||||
|
(:report-property :relative-to trivial-backtrace-test)
|
||||||
|
|
||||||
|
(:report-property :style-sheet "test-style.css")
|
||||||
|
(:report-property :if-exists :supersede)
|
||||||
|
(:report-property :format :html)
|
||||||
|
(:report-property :full-pathname "test-results/test-report.html")
|
||||||
|
(:report-property :unique-name t)
|
||||||
|
(:build-report)
|
||||||
|
|
||||||
|
(:report-property :unique-name t)
|
||||||
|
(:report-property :format :describe)
|
||||||
|
(:report-property :full-pathname "test-results/test-report.txt")
|
||||||
|
(:build-report)
|
||||||
|
|
||||||
|
(:report-property :format :save)
|
||||||
|
(:report-property :full-pathname "test-results/test-report.sav")
|
||||||
|
(:build-report)
|
||||||
|
|
||||||
|
(:report-property :format :describe)
|
||||||
|
(:report-property :full-pathname *standard-output*)
|
||||||
|
(:build-report)
|
5
test/packages.lisp
Normal file
5
test/packages.lisp
Normal file
|
@ -0,0 +1,5 @@
|
||||||
|
(in-package #:common-lisp-user)
|
||||||
|
|
||||||
|
(defpackage #:trivial-backtrace-test
|
||||||
|
(:use #:common-lisp #:lift #:trivial-backtrace))
|
||||||
|
|
4
test/test-setup.lisp
Normal file
4
test/test-setup.lisp
Normal file
|
@ -0,0 +1,4 @@
|
||||||
|
(in-package #:trivial-backtrace-test)
|
||||||
|
|
||||||
|
(deftestsuite trivial-backtrace-test ()
|
||||||
|
())
|
17
test/tests.lisp
Normal file
17
test/tests.lisp
Normal file
|
@ -0,0 +1,17 @@
|
||||||
|
(in-package #:trivial-backtrace-test)
|
||||||
|
|
||||||
|
(deftestsuite generates-backtrace (trivial-backtrace-test)
|
||||||
|
())
|
||||||
|
|
||||||
|
(addtest (generates-backtrace)
|
||||||
|
test-1
|
||||||
|
(let ((output nil))
|
||||||
|
(handler-case
|
||||||
|
(let ((x 1))
|
||||||
|
(let ((y (- x (expt 1024 0))))
|
||||||
|
(declare (optimize (safety 3)))
|
||||||
|
(/ 2 y)))
|
||||||
|
(error (c)
|
||||||
|
(setf output (print-backtrace c :output nil))))
|
||||||
|
(ensure (stringp output))
|
||||||
|
(ensure (plusp (length output)))))
|
22
trivial-backtrace-test.asd
Normal file
22
trivial-backtrace-test.asd
Normal file
|
@ -0,0 +1,22 @@
|
||||||
|
(defpackage #:trivial-backtrace-test-system (:use #:asdf #:cl))
|
||||||
|
(in-package #:trivial-backtrace-test-system)
|
||||||
|
|
||||||
|
(defsystem trivial-backtrace-test
|
||||||
|
:author "Gary Warren King <gwking@metabang.com>"
|
||||||
|
:maintainer "Gary Warren King <gwking@metabang.com>"
|
||||||
|
:licence "MIT Style License; see file COPYING for details"
|
||||||
|
:components ((:module
|
||||||
|
"setup"
|
||||||
|
:pathname "test/"
|
||||||
|
:components ((:file "packages")
|
||||||
|
(:file "test-setup"
|
||||||
|
:depends-on ("packages"))))
|
||||||
|
(:module
|
||||||
|
"test"
|
||||||
|
:pathname "test/"
|
||||||
|
:depends-on ("setup")
|
||||||
|
:components ((:file "tests"))))
|
||||||
|
:depends-on (:lift :trivial-backtrace))
|
||||||
|
|
||||||
|
|
||||||
|
|
35
trivial-backtrace.asd
Normal file
35
trivial-backtrace.asd
Normal file
|
@ -0,0 +1,35 @@
|
||||||
|
(in-package #:common-lisp-user)
|
||||||
|
|
||||||
|
(defpackage #:trivial-backtrace-system (:use #:asdf #:cl))
|
||||||
|
(in-package #:trivial-backtrace-system)
|
||||||
|
|
||||||
|
(defsystem trivial-backtrace
|
||||||
|
:version "1.1.0"
|
||||||
|
:author "Gary Warren King <gwking@metabang.com> and contributors"
|
||||||
|
:maintainer "Gary Warren King <gwking@metabang.com> and contributors"
|
||||||
|
:licence "MIT Style license "
|
||||||
|
:description "trivial-backtrace"
|
||||||
|
:depends-on ()
|
||||||
|
:components
|
||||||
|
((:static-file "COPYING")
|
||||||
|
(:module
|
||||||
|
"setup"
|
||||||
|
:pathname "dev/"
|
||||||
|
:components ((:file "packages")))
|
||||||
|
(:module
|
||||||
|
"dev"
|
||||||
|
:depends-on ("setup")
|
||||||
|
:components ((:file "utilities")
|
||||||
|
(:file "backtrace")
|
||||||
|
(:file "map-backtrace")
|
||||||
|
(:file "fallback" :depends-on ("backtrace" "map-backtrace")))))
|
||||||
|
:in-order-to ((test-op (load-op trivial-backtrace-test)))
|
||||||
|
:perform (test-op :after (op c)
|
||||||
|
(funcall
|
||||||
|
(intern (symbol-name '#:run-tests) :lift)
|
||||||
|
:config :generic)))
|
||||||
|
|
||||||
|
(defmethod operation-done-p
|
||||||
|
((o test-op)
|
||||||
|
(c (eql (find-system 'trivial-backtrace))))
|
||||||
|
(values nil))
|
88
website/source/index.md
Normal file
88
website/source/index.md
Normal file
|
@ -0,0 +1,88 @@
|
||||||
|
{include resources/header.md}
|
||||||
|
|
||||||
|
<div class="contents">
|
||||||
|
<div class="system-links">
|
||||||
|
|
||||||
|
* [Mailing Lists][mailing-list]
|
||||||
|
* [Getting it][downloads]
|
||||||
|
* [Documentation][]
|
||||||
|
* [News][]
|
||||||
|
* [Test results][tr]
|
||||||
|
* [Changelog][]
|
||||||
|
|
||||||
|
</div>
|
||||||
|
<div class="system-description">
|
||||||
|
|
||||||
|
### What it is
|
||||||
|
|
||||||
|
On of the many things that didn't quite get into the Common
|
||||||
|
Lisp standard was how to get a Lisp to output its call stack
|
||||||
|
when something has gone wrong. As such, each Lisp has
|
||||||
|
developed its own notion of what to display, how to display
|
||||||
|
it, and what sort of arguments can be used to customize it.
|
||||||
|
`trivial-backtrace` is a simple solution to generating a
|
||||||
|
backtrace portably. As of {today}, it supports Allegro Common
|
||||||
|
Lisp, LispWorks, ECL, MCL, SCL, SBCL and CMUCL. Its
|
||||||
|
interface consists of three functions and one variable:
|
||||||
|
|
||||||
|
* print-backtrace
|
||||||
|
* print-backtrace-to-stream
|
||||||
|
* print-condition
|
||||||
|
* \*date-time-format\*
|
||||||
|
|
||||||
|
You can probably already guess what they do, but they are
|
||||||
|
described in more detail below.
|
||||||
|
|
||||||
|
{anchor mailing-lists}
|
||||||
|
|
||||||
|
### Mailing Lists
|
||||||
|
|
||||||
|
* [trivial-backtrace-devel][devel-list]: A list for
|
||||||
|
announcements, questions, patches, bug reports, and so
|
||||||
|
on; It's for anything and everything
|
||||||
|
|
||||||
|
### API
|
||||||
|
|
||||||
|
{set-property docs-package trivial-backtrace}
|
||||||
|
{docs print-backtrace}
|
||||||
|
{docs print-backtrace-to-stream}
|
||||||
|
{docs print-condition}
|
||||||
|
{docs *date-time-format*}
|
||||||
|
|
||||||
|
{anchor downloads}
|
||||||
|
|
||||||
|
### Where is it
|
||||||
|
|
||||||
|
A [git][] repository is available using
|
||||||
|
|
||||||
|
git clone http://common-lisp.net/project/trivial-backtrace/trivial-backtrace.git
|
||||||
|
|
||||||
|
The [darcs][] repository is still around but is **not** being updated.
|
||||||
|
The command to get it is below:
|
||||||
|
|
||||||
|
;;; WARNING: out of date
|
||||||
|
darcs get http://common-lisp.net/project/trivial-backtrace/
|
||||||
|
|
||||||
|
trivial-backtrace is also [ASDF installable][asdf-install].
|
||||||
|
Its CLiki home is right [where][cliki-home] you'd expect.
|
||||||
|
|
||||||
|
There's also a handy [gzipped tar file][tarball].
|
||||||
|
|
||||||
|
{anchor news}
|
||||||
|
|
||||||
|
### What is happening
|
||||||
|
|
||||||
|
<dl>
|
||||||
|
<dt>14 May 2009</dt>
|
||||||
|
<dd>Moved to [git][]; John Fremlin adds map-backtrace
|
||||||
|
</dd>
|
||||||
|
|
||||||
|
<dt>1 June 2008</dt>
|
||||||
|
<dd>Release version 1.0
|
||||||
|
</dd>
|
||||||
|
</dl>
|
||||||
|
</div>
|
||||||
|
</div>
|
||||||
|
|
||||||
|
{include resources/footer.md}
|
||||||
|
|
15
website/source/resources/footer.md
Normal file
15
website/source/resources/footer.md
Normal file
|
@ -0,0 +1,15 @@
|
||||||
|
<div id="footer" class="footer">
|
||||||
|
<div id="buttons">
|
||||||
|
<a class="nav" href="http://validator.w3.org/check/referer" title="xhtml1.1"><img src="http://common-lisp.net/project/cl-containers/shared/buttons/xhtml.gif" width="80" height="15" title="valid xhtml button" alt="valid xhtml" /></a>
|
||||||
|
<a class="nav" href="http://common-lisp.net/project/cl-markdown/" title="Mark with CL-Markdown"><img src="http://common-lisp.net/project/cl-containers/shared/buttons/cl-markdown.png" width="80" height="15" title="Made with CL-Markdown" alt="CL-Markdown" /></a>
|
||||||
|
<a class="nav" href="http://www.catb.org/hacker-emblem/" title="hacker"><img src="http://common-lisp.net/project/cl-containers/shared/buttons/hacker.png" width="80" height="15" title="hacker emblem" alt="hacker button" /></a>
|
||||||
|
<a class="nav" href="http://www.lisp.org/" title="Association of Lisp Users"><img src="http://common-lisp.net/project/cl-containers/shared/buttons/lambda-lisp.png" width="80" height="15" title="ALU emblem" alt="ALU button" /></a>
|
||||||
|
<a class="nav" href="http://common-lisp.net/" title="Common-Lisp.net"><img src="http://common-lisp.net/project/cl-containers/shared/buttons/lisp-lizard.png" width="80" height="15" title="Common-Lisp.net" alt="Common-Lisp.net button" /></a>
|
||||||
|
</div>
|
||||||
|
|
||||||
|
### Copyright (c) 2009 - 2011 Gary Warren King (gwking@metabang.com)
|
||||||
|
|
||||||
|
trivial-backtrace has an [MIT style][mit-license] license
|
||||||
|
|
||||||
|
<div id="timestamp">Last updated {today} at {now}</div>
|
||||||
|
</div>
|
19
website/source/resources/header.md
Normal file
19
website/source/resources/header.md
Normal file
|
@ -0,0 +1,19 @@
|
||||||
|
{include shared-links.md}
|
||||||
|
|
||||||
|
{set-property html yes}
|
||||||
|
{set-property style-sheet "styles.css"}
|
||||||
|
{set-property author "Gary Warren King"}
|
||||||
|
{set-property title "trivial-backtrace | watch where you've been"}
|
||||||
|
|
||||||
|
[devel-list]: http://common-lisp.net/cgi-bin/mailman/listinfo/trivial-backtrace-devel
|
||||||
|
[cliki-home]: http://www.cliki.net//trivial-backtrace
|
||||||
|
[tarball]: http://common-lisp.net/project/trivial-backtrace/trivial-backtrace.tar.gz
|
||||||
|
|
||||||
|
<div id="header">
|
||||||
|
<span class="logo"><a href="http://www.metabang.com/" title="metabang.com"><img src="http://common-lisp.net/project/cl-containers/shared/metabang-2.png" title="metabang.com" width="100" alt="Metabang Logo" /></a></span>
|
||||||
|
|
||||||
|
## trivial-backtrace
|
||||||
|
|
||||||
|
#### watch where you've been
|
||||||
|
|
||||||
|
</div>
|
2
website/source/resources/navigation.md
Normal file
2
website/source/resources/navigation.md
Normal file
|
@ -0,0 +1,2 @@
|
||||||
|
<div id="navigation">
|
||||||
|
</div>
|
93
website/website.tmproj
Normal file
93
website/website.tmproj
Normal file
|
@ -0,0 +1,93 @@
|
||||||
|
<?xml version="1.0" encoding="UTF-8"?>
|
||||||
|
<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
|
||||||
|
<plist version="1.0">
|
||||||
|
<dict>
|
||||||
|
<key>currentDocument</key>
|
||||||
|
<string>source/resources/header.md</string>
|
||||||
|
<key>documents</key>
|
||||||
|
<array>
|
||||||
|
<dict>
|
||||||
|
<key>expanded</key>
|
||||||
|
<true/>
|
||||||
|
<key>name</key>
|
||||||
|
<string>source</string>
|
||||||
|
<key>regexFolderFilter</key>
|
||||||
|
<string>!.*/(\.[^/]*|CVS|_darcs|_MTN|\{arch\}|blib|.*~\.nib|.*\.(framework|app|pbproj|pbxproj|xcode(proj)?|bundle))$</string>
|
||||||
|
<key>sourceDirectory</key>
|
||||||
|
<string>source</string>
|
||||||
|
</dict>
|
||||||
|
</array>
|
||||||
|
<key>fileHierarchyDrawerWidth</key>
|
||||||
|
<integer>190</integer>
|
||||||
|
<key>metaData</key>
|
||||||
|
<dict>
|
||||||
|
<key>source/index.md</key>
|
||||||
|
<dict>
|
||||||
|
<key>caret</key>
|
||||||
|
<dict>
|
||||||
|
<key>column</key>
|
||||||
|
<integer>0</integer>
|
||||||
|
<key>line</key>
|
||||||
|
<integer>0</integer>
|
||||||
|
</dict>
|
||||||
|
<key>firstVisibleColumn</key>
|
||||||
|
<integer>0</integer>
|
||||||
|
<key>firstVisibleLine</key>
|
||||||
|
<integer>0</integer>
|
||||||
|
</dict>
|
||||||
|
<key>source/resources/footer.md</key>
|
||||||
|
<dict>
|
||||||
|
<key>caret</key>
|
||||||
|
<dict>
|
||||||
|
<key>column</key>
|
||||||
|
<integer>29</integer>
|
||||||
|
<key>line</key>
|
||||||
|
<integer>9</integer>
|
||||||
|
</dict>
|
||||||
|
<key>firstVisibleColumn</key>
|
||||||
|
<integer>0</integer>
|
||||||
|
<key>firstVisibleLine</key>
|
||||||
|
<integer>0</integer>
|
||||||
|
</dict>
|
||||||
|
<key>source/resources/header.md</key>
|
||||||
|
<dict>
|
||||||
|
<key>caret</key>
|
||||||
|
<dict>
|
||||||
|
<key>column</key>
|
||||||
|
<integer>27</integer>
|
||||||
|
<key>line</key>
|
||||||
|
<integer>3</integer>
|
||||||
|
</dict>
|
||||||
|
<key>firstVisibleColumn</key>
|
||||||
|
<integer>0</integer>
|
||||||
|
<key>firstVisibleLine</key>
|
||||||
|
<integer>0</integer>
|
||||||
|
</dict>
|
||||||
|
<key>source/resources/navigation.md</key>
|
||||||
|
<dict>
|
||||||
|
<key>caret</key>
|
||||||
|
<dict>
|
||||||
|
<key>column</key>
|
||||||
|
<integer>0</integer>
|
||||||
|
<key>line</key>
|
||||||
|
<integer>1</integer>
|
||||||
|
</dict>
|
||||||
|
<key>firstVisibleColumn</key>
|
||||||
|
<integer>0</integer>
|
||||||
|
<key>firstVisibleLine</key>
|
||||||
|
<integer>0</integer>
|
||||||
|
</dict>
|
||||||
|
</dict>
|
||||||
|
<key>openDocuments</key>
|
||||||
|
<array>
|
||||||
|
<string>source/resources/header.md</string>
|
||||||
|
<string>source/index.md</string>
|
||||||
|
<string>source/resources/navigation.md</string>
|
||||||
|
<string>source/resources/footer.md</string>
|
||||||
|
</array>
|
||||||
|
<key>showFileHierarchyDrawer</key>
|
||||||
|
<true/>
|
||||||
|
<key>windowFrame</key>
|
||||||
|
<string>{{615, 0}, {578, 778}}</string>
|
||||||
|
</dict>
|
||||||
|
</plist>
|
Loading…
Reference in a new issue