diff options
Diffstat (limited to 'third_party/lisp/trivial-backtrace/dev')
| -rw-r--r-- | third_party/lisp/trivial-backtrace/dev/backtrace.lisp | 127 | ||||
| -rw-r--r-- | third_party/lisp/trivial-backtrace/dev/fallback.lisp | 10 | ||||
| -rw-r--r-- | third_party/lisp/trivial-backtrace/dev/map-backtrace.lisp | 105 | ||||
| -rw-r--r-- | third_party/lisp/trivial-backtrace/dev/mucking.lisp | 75 | ||||
| -rw-r--r-- | third_party/lisp/trivial-backtrace/dev/packages.lisp | 13 | ||||
| -rw-r--r-- | third_party/lisp/trivial-backtrace/dev/utilities.lisp | 104 |
6 files changed, 0 insertions, 434 deletions
diff --git a/third_party/lisp/trivial-backtrace/dev/backtrace.lisp b/third_party/lisp/trivial-backtrace/dev/backtrace.lisp deleted file mode 100644 index aa3951e30f9f..000000000000 --- a/third_party/lisp/trivial-backtrace/dev/backtrace.lisp +++ /dev/null @@ -1,127 +0,0 @@ -(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. -") - - diff --git a/third_party/lisp/trivial-backtrace/dev/fallback.lisp b/third_party/lisp/trivial-backtrace/dev/fallback.lisp deleted file mode 100644 index 40a5219824e5..000000000000 --- a/third_party/lisp/trivial-backtrace/dev/fallback.lisp +++ /dev/null @@ -1,10 +0,0 @@ -(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.~%")))) diff --git a/third_party/lisp/trivial-backtrace/dev/map-backtrace.lisp b/third_party/lisp/trivial-backtrace/dev/map-backtrace.lisp deleted file mode 100644 index 43eddda47579..000000000000 --- a/third_party/lisp/trivial-backtrace/dev/map-backtrace.lisp +++ /dev/null @@ -1,105 +0,0 @@ -(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))) \ No newline at end of file diff --git a/third_party/lisp/trivial-backtrace/dev/mucking.lisp b/third_party/lisp/trivial-backtrace/dev/mucking.lisp deleted file mode 100644 index 2be26a5a870e..000000000000 --- a/third_party/lisp/trivial-backtrace/dev/mucking.lisp +++ /dev/null @@ -1,75 +0,0 @@ -(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")) diff --git a/third_party/lisp/trivial-backtrace/dev/packages.lisp b/third_party/lisp/trivial-backtrace/dev/packages.lisp deleted file mode 100644 index 2da49d3d9ba5..000000000000 --- a/third_party/lisp/trivial-backtrace/dev/packages.lisp +++ /dev/null @@ -1,13 +0,0 @@ -(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)) - diff --git a/third_party/lisp/trivial-backtrace/dev/utilities.lisp b/third_party/lisp/trivial-backtrace/dev/utilities.lisp deleted file mode 100644 index b0a249867aa9..000000000000 --- a/third_party/lisp/trivial-backtrace/dev/utilities.lisp +++ /dev/null @@ -1,104 +0,0 @@ -(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))))))) |