Merge commit 'cc026178a94f94fa9c79cedc66cbaf5ab78c21c1' as 'third_party/lisp/trivial-backtrace' r/392

6 files changed, 434 insertions, 0 deletions

diff --git a/third_party/lisp/trivial-backtrace/dev/backtrace.lisp b/third_party/lisp/trivial-backtrace/dev/backtrace.lisp
new file mode 100644
index 000000000000..aa3951e30f9f
--- /dev/null
+++ b/third_party/lisp/trivial-backtrace/dev/backtrace.lisp
@@ -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.
+")
+
+
diff --git a/third_party/lisp/trivial-backtrace/dev/fallback.lisp b/third_party/lisp/trivial-backtrace/dev/fallback.lisp
new file mode 100644
index 000000000000..40a5219824e5
--- /dev/null
+++ b/third_party/lisp/trivial-backtrace/dev/fallback.lisp
@@ -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.~%"))))
diff --git a/third_party/lisp/trivial-backtrace/dev/map-backtrace.lisp b/third_party/lisp/trivial-backtrace/dev/map-backtrace.lisp
new file mode 100644
index 000000000000..43eddda47579
--- /dev/null
+++ b/third_party/lisp/trivial-backtrace/dev/map-backtrace.lisp
@@ -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)))
\ 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
new file mode 100644
index 000000000000..2be26a5a870e
--- /dev/null
+++ b/third_party/lisp/trivial-backtrace/dev/mucking.lisp
@@ -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")) 
diff --git a/third_party/lisp/trivial-backtrace/dev/packages.lisp b/third_party/lisp/trivial-backtrace/dev/packages.lisp
new file mode 100644
index 000000000000..2da49d3d9ba5
--- /dev/null
+++ b/third_party/lisp/trivial-backtrace/dev/packages.lisp
@@ -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))
+
diff --git a/third_party/lisp/trivial-backtrace/dev/utilities.lisp b/third_party/lisp/trivial-backtrace/dev/utilities.lisp
new file mode 100644
index 000000000000..b0a249867aa9
--- /dev/null
+++ b/third_party/lisp/trivial-backtrace/dev/utilities.lisp
@@ -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)))))))