SHARE
TWEET

Untitled

a guest May 1st, 2018 88 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. ;; KKK.LISP
  2. ;; =============================================================================
  3. ;; - The notion of internal and external symbols is stupid. Dynamic analysis of
  4. ;;   call trees allows for all documentation to be onion-layered according to
  5. ;;   high-or-lowlevel intent. All classes & whatnot belong in the same package,
  6. ;;   or at least a MUCH SMALLER set of packages
  7. ;;
  8. ;; - DEFTYPE, & DEFMETHOD unification. Why is (defmethod ... ((k keyword)) ...)
  9. ;;   invalid?
  10. ;; - single compiler build that includes pattern matching
  11. ;; - truthy predicates
  12. ;; - MACRO GENERATION
  13. ;; - RE-APPLICATION OF ALL REPL FORMS. WHY SAVE AND DIE WHEN YOU CAN SINGLE STEP
  14. ;;   BACKWARDS?
  15. ;; - INFODB SOURCES
  16. ;; - COMMENTS -> DOCSTRINGS
  17. ;; - SELF-DISTILLING SYNTATIC SUGAR
  18. ;; - DATASTRUCTURE CLIMBING,
  19. ;;
  20. ;;   (defvar place nil)
  21. ;;   (setf (getf place :a) "b" ;; repeat ~80k times, so place.length
  22. ;;                             ;; = ~160k & really wants a hashmap
  23. ;;         (loop with v0 = (make-hashmap :count (/ (length place) 2))
  24. ;;               for k in (plist-keys place)
  25. ;;        do (setf (gethash v0 k) (getf place k))))
  26. ;;
  27. ;; what is missing here is the implementation of the GENERIC-FUNCTIONs
  28. ;; SOURCE & LISP + a proggy walker (easy pi tho). Detect for some
  29. ;; threshold when to update from one datastructure (list->array,
  30. ;; list->hashmap) for all variables in memory (check sb-introspect for
  31. ;; the impl) when datastructure changes, (COMPILE (LISP X)) => equal
  32. ;; to (SOURCE X)
  33. ;;
  34. ;; (SB-KERNEL::STRUCTURE-CLASSOID-CLASS-INFO
  35. ;;      (SB-PCL::CLASS-CLASSOID (find-class 'sb-c::constraint)))
  36. ;;
  37. ;; UTIL FUNCTIONS
  38. ;; =============================================================================
  39. ;; FUNCTION SPECIFICATIONS -- OR -- GENERIC FUNCTIONS
  40. ;; =============================================================================
  41. ;; FUNCTION IMPLEMENTATIONS -- OR -- METHODS
  42. ;; =============================================================================
  43. ;; NEW FRIENDS -- OR -- THE F, M & C MACROS
  44. ;; =============================================================================
  45. ;; (list SB-PCL::*THE-CLASS-FUNCALLABLE-STANDARD-CLASS*
  46. ;; SB-PCL::*THE-CLASS-FUNCALLABLE-STANDARD-OBJECT*
  47. ;; SB-KERNEL::*FUNCALLABLE-INSTANCE-TYPE*
  48. ;; SB-KERNEL::**BUILT-IN-CLASS-CODES**
  49. ;; SB-KERNEL::*NON-INSTANCE-CLASSOID-TYPES*
  50. ;; SB-PCL::**STANDARD-METHOD-CLASSES**
  51. ;; SB-VM::**PRIMITIVE-TYPE-AUX-CACHE-VECTOR**
  52. ;; SB-PCL::*STANDARD-CLASSES*
  53. ;; SB-PCL::*STANDARD-METHOD-CLASS-NAMES*)
  54. ;; SB-C::PRESENT-IN-FORM
  55. ;; SB-KERNEL::*DEF!STRUCT-TYPE-MAKE-LOAD-FORM-FUN*
  56. ;; *REPL-READ-FORM-FUN*
  57. ;; SB-WALKER:WALK-FORM
  58. ;;
  59. ;; (sb-walker::walk-form
  60. ;;  '(let* ((x 2)
  61. ;;   (y 4)
  62. ;;   (z nil))
  63. ;;    (list (+ x f)
  64. ;;     (+ y c)
  65. ;;     (+ z e))) nil
  66. ;;  (lambda (subform context env)
  67. ;;    (declare (ignore context env))
  68. ;;    (print subform)))
  69.  
  70. (progn (defun lisp-fu (&optional with-graphics?)
  71.      "This doesn't work because why?
  72.  
  73. loop for x in list-all-packages do sb-ext::unlock-package x
  74. format t \"~%; Unlocking ~s\" x"
  75.      (SET-SBCL-SOURCE-LOCATION #p"~/sb/")
  76.      (macrolet ((taking-new (&rest body)
  77.               `(handler-bind ((name-conflict (lambda (condition)
  78.                                (invoke-restart 'sb-impl::take-new))))
  79.              ,@body)))
  80.        (let* ((metaprogramming-systems
  81.            '(:anaphora :cl-ppcre :optima :fare-quasiquote
  82.              :named-readtables :fare-utils
  83.              :optima.ppcre :fare-quasiquote-optima
  84.              :fare-quasiquote-readtable :sb-introspect))         
  85.           (graphics-systems
  86.            '(:mcclim :mcclim-bezier :mcclim-bezier-clx :mcclim-clx-fb
  87.              :clim-widgets :climacs :clouseau :clim-listener)))
  88.          (ql:quickload metaprogramming-systems)
  89.          (taking-new
  90.           (use-package :asdf)
  91.           (use-package :optima)
  92.           (use-package :optima.ppcre)
  93.           (use-package :cl-ppcre)    
  94.           (use-package :fare-quasiquote)
  95.           (use-package :named-readtables)
  96.           (use-package :anaphora)
  97.           (use-package :sb-impl)
  98.           (use-package :sb-int)
  99.           (load "~/sb/contrib/sb-introspect/sb-introspect.asd")
  100.           (asdf::operate :compile-op :sb-introspect)
  101.           (asdf::operate :load-op :sb-introspect)
  102.           (use-package :sb-introspect))
  103.          (when with-graphics? (ql:quickload graphics-systems))
  104.          (eval (read-from-string "(in-readtable :fare-quasiquote)")))))
  105.        (lisp-fu t))
  106.  
  107. (defun infos (sym)
  108.   `(,sym
  109.     ,@(remove-if-not
  110.        'third
  111.        (loop for o across sb-c::*info-types*
  112.       when o collect (let* ((category (slot-value o 'SB-C::CATEGORY))
  113.                 (kind (slot-value o 'sb-c::kind)))
  114.                (list category kind (sb-c::info category kind sym)))))))
  115.  
  116. (defun alias (f1 f2)
  117.   (assert (fboundp f1))
  118.   (loop for (class type x) in (rest (infos f1))
  119.      do (setf (sb-c::info class type f2) x)
  120.      finally (return (values (infos f2) f1))))
  121.  
  122. (defun unicode-apropos (s)
  123.   "Unicode characters are named in :UPCASE, ARABIC, CRYLLIC etc"
  124.   (setf s (string-upcase s))
  125.   (loop with errors = nil with v0 = nil
  126.      for a across SB-INT:**UNICODE-CHAR-NAME-DATABASE**
  127.      ;; SB-INT:**UNICODE-1-NAME-CHAR-DATABASE**
  128.      for x = (ignore-errors (code-char a))
  129.      do (if (and x (scan s (char-name (code-char a))))
  130.         (push x v0)
  131.         (push a errors))
  132.      finally (return v0)))
  133.  
  134. (defgeneric lisp (object)
  135.   (:documentation "LISP returns the lisp code that /defines/ OBJECT for its current value.
  136. Implementing LISP DEFMETHODS for all of the base types allow for when *PRINT-READABLY* = T."))
  137.  
  138. (defgeneric source (object)
  139.   (:documentation "LISP returns the lisp code that /defined/ OBJECT"))
  140.  
  141. (defgeneric name (o)
  142.   (:documentation "PACKAGE-NAME & friends are redundant")
  143.   ;; (apropos "-name")
  144.   ;; (apropos "LIST-ALL")
  145.   ;; (apropos "PARSE-")
  146.   ;; (apropos "WITH-")
  147.   ;; (apropos "MAP-")
  148.   ;; (apropos "DO-")
  149.   )
  150.  
  151. (defgeneric more (o)
  152.   (:documentation
  153.    "`(,OBJECT ,@INTERESTING-BRANCHES) allowing for CAR to reduce a graph node in place"))
  154.  
  155. (defgeneric args (o) (:documentation "DWIM SB-INTROSPECT:FUNCTION-LAMBDA-LIST & co!"))
  156.  
  157. (defmethod names ((c standard-class))
  158.   (mapcar 'SB-MOP:SLOT-DEFINITION-NAME (SB-MOP:CLASS-SLOTS c)))
  159.  
  160. (defmethod lisp ((list list)) (loop for object in list collect (lisp object)))
  161. (defmethod lisp ((number number)) number)
  162. (defmethod lisp ((string string)) string)
  163. (defmethod lisp ((name symbol))
  164.   (if (keywordp name)
  165.       (or (awhen (find-package name)) (awhen (asdf::find-system name)))
  166.       name))
  167.  
  168. (defun ->s (o)
  169.   "SYMBOLICATE"
  170.   (typecase o
  171.     (string o)
  172.     (symbol (symbol-name o))
  173.     (SB-IMPL::STRING-OUTPUT-STREAM (cl::make-string-output-stream))))
  174.  
  175. (defun ->k (o)
  176.   "KEYWORDICATE"
  177.   (typecase o
  178.     (string (intern (string-upcase o) 'keyword))
  179.     (symbol (intern (symbol-name o) 'keyword))))
  180.  
  181. (defun ->class (o)
  182.   (typecase o
  183.     (symbol (find-class o nil))
  184.     (t (find-class (type-of o) nil))))
  185.  
  186. (defun fill-paragraph-to-column (string &optional (fill-column 80))
  187.     "Copied from Advanced Use of Lisp's FORMAT Function pg. 5
  188.  
  189.   Here's how it works:
  190.   1. The ~{ applies its inner format string to each element in its argument. In
  191.   our case, the inner format string is '~<~%~1,FILL-COLUMN:;~A~>'. The argument
  192.   is WORDS which is a list of strings.
  193.  
  194.   2. The inner string is applied to the next element in WORDS.
  195.  
  196.   (a) The '~<~%~1,FILL-COLUMN:;~A~>' has two clauses:
  197.   (b) That first clause is special becaues it ends with two integers & a colon.
  198.       That special type of clause means 'Do not print this clause unless the
  199.       length of the result of formatting the other clause is longer than
  200.       40 - 1 -> 39.'
  201.  
  202.   3. Until WORDS is the empty list, repeat step number 2.
  203.  
  204.   Step 2.2 is where the action happens. The ~< directive is given one of the
  205.   words, which it formats according to the its second clause, ~A. It takes the
  206.   result of that operation, adds its length to the line position of the output
  207.   stream (or the output string, since we're using NIL as FORMAT's first argument),
  208.   & comparse that sum to 40 - 1 -> 39, which it gets from the first clause. If the
  209.   sum is greater than 39, the ~< output the first part of its first clause &
  210.   resets the line position to 0. Then it outputs the word that it just formatted"
  211.   (assert (not (find #\newline string :test 'char=)))
  212.   (let* ((format-string (format nil "~~{~~<~~%~~1,~A:;~~A~~> ~~}" fill-column))
  213.      (words (cl-ppcre::split #\space string)))
  214.     (format nil format-string words)))
  215.  
  216. (defun absorb-variables (package)
  217.   "Absorbs variables, ignoring any symbols that cause conflicts"
  218.   (loop for symbol being the present-symbols of package
  219.      for x = (when (and (boundp symbol)
  220.             (ignore-errors (import symbol)))
  221.            symbol)
  222.      when x collect x))
  223.  
  224. (defun absorb-functions (package)
  225.   "Absorbs functions, ignoring any symbols that cause conflicts"
  226.   (loop for symbol being the present-symbols of package
  227.      for x = (when (and (fboundp symbol) (ignore-errors (import symbol)))
  228.            symbol)
  229.      when x collect x))
  230.  
  231. (defun absorb (package)
  232.   "Absorbs variables & functions "
  233.   (append (absorb-variables package) (absorb-functions package)))
  234.  
  235. (defun take (n l) (loop repeat n for e in l collect e))
  236.  
  237. (defun drop (n l)
  238.   (unless (> n (length l)) (subseq l n (length l))))
  239.  
  240. (defmethod up ((o t))
  241.   (slot-value o (slot-value (first (SB-MOP:CLASS-SLOTS (->class o))) 'sb-pcl::name)))
  242. (defmethod left ((o t))
  243.   (slot-value o (slot-value (second (SB-MOP:CLASS-SLOTS (->class o))) 'sb-pcl::name)))
  244. (defmethod down ((o t))
  245.   (slot-value o (slot-value (third (SB-MOP:CLASS-SLOTS (->class o))) 'sb-pcl::name)))
  246. (defmethod right ((o t))
  247.   (slot-value o (slot-value (fourth (SB-MOP:CLASS-SLOTS (->class o))) 'sb-pcl::name)))
  248.  
  249. (alias 'lambda 'y)
  250. (alias 'make-instance 'instance)
  251. (alias 'remove-if-not 'filter)
  252. (alias 'expt '^)
  253. (alias 'uiop/stream:read-file-lines 'lines)
  254. (alias 'uiop/stream:read-file-forms 'forms)
  255. (alias 'ql-dist::system-apropos '?system)
  256. (alias 'ql-dist::system-apropos-list '?systems)
  257. (alias 'apropos '?)
  258. (alias 'apropos-list '?s)
  259. (alias 'remove-duplicates 'distinct)
  260. (alias 'describe '??)
  261. (alias 'define-symbol-macro 'cheat)
  262. (alias 'defparameter 'var)
  263. (alias 'rename-file 'mv)
  264.  
  265. ;; (sb-pcl::make-structure-class-defstruct-form )
  266. ;; (SB-VM::MAP-ALLOCATED-OBJECTS (lambda (&rest _) (print _)) :dynamic)
  267. ;; (SB-PCL::MAP-ALL-GENERIC-FUNCTIONS 'print)
  268.  
  269. ;; (define-symbol-macro args
  270. ;;     (let* ((v0 nil))
  271. ;;       (do-all-symbols (x)
  272. ;;  (when (fboundp x)
  273. ;;    (when (equal '(structure-class) (args x))
  274. ;;      (push x v0))))
  275. ;;       v0))
  276.  
  277. (cheat structures
  278.        (let* ((v0 nil))
  279.      (sb-pcl::map-all-classes
  280.       (lambda (x) (when (typep x 'structure-class) (push x v0))))
  281.      v0))
  282.  
  283. (cheat conditions
  284.        (let* ((v0 nil))
  285.      (sb-pcl::map-all-classes
  286.       (lambda (x) (when (typep x 'sb-pcl::condition-class) (push x v0))))
  287.      v0))
  288.  
  289. (cheat classes
  290.        (let* ((v0 nil))
  291.      (sb-pcl::map-all-classes (lambda (x) (push x v0)))
  292.      v0))
  293. (cheat rt *readtable*)
  294. (cheat pkg *package*)
  295. (cheat pkgs (list-all-packages))
  296. (cheat kpkg SB-INT:*KEYWORD-PACKAGE*)
  297. (cheat systems ASDF/FIND-SYSTEM:*DEFINED-SYSTEMS*)
  298. (cheat dir *default-pathname-defaults*)
  299. (cheat q (save-lisp-and-die (format nil "m~a" (symbol-name (gensym))) :executable t))
  300. (cheat ls (ls dir))
  301. (cheat out *standard-output*)
  302. (cheat in *standard-input*)
  303. (cheat &keys LAMBDA-LIST-KEYWORDS)
  304.  
  305. (var pwd (setf dir #p"/"))
  306.  
  307. (defun ls (dir)
  308.   (assert (probe-file dir))
  309.   (let* ((v0 nil))
  310.     (sb-ext::map-directory (lambda (p) (push p v0))
  311.                dir
  312.                :directories t
  313.                :files t)
  314.     v0))
  315.  
  316. (defun dirs (dir)
  317.   (assert (probe-file dir))
  318.   (let* ((v0 nil))
  319.     (sb-ext::map-directory (lambda (p) (push p v0))
  320.                dir
  321.                :directories t
  322.                :files nil)
  323.     v0))
  324.  
  325. (defun files (dir)
  326.   (assert (probe-file dir))
  327.   (let* ((v0 nil))
  328.     (sb-ext::map-directory (lambda (p) (push p v0))
  329.                dir
  330.                :directories nil
  331.                :files t)
  332.     v0))
  333.  
  334. (defun walk-directory (function dir &optional directories?)
  335.   "When DIRECTORIES?, FUNCTION is funcalled on them as well"
  336.   (assert (probe-file dir))
  337.   (labels ((%walk (dir)
  338.          (if directories?
  339.          (sb-ext::map-directory function dir :directories t :files t)
  340.          (sb-ext::map-directory function dir :directories nil :files t))
  341.          (sb-ext::map-directory #'%walk dir :directories t :files nil)))
  342.     (%walk dir)))
  343.  
  344. (defun %load-system (a)
  345.   (asdf::operate 'asdf::compile-op a :force t)
  346.   (asdf::operate 'asdf::load-op a :force t))
  347.  
  348. (defun repl-prompt (stream)
  349.   (format stream "~%~A,~A,~A> "
  350.       (package-name *package*)
  351.       (readtable-name *readtable*)
  352.       SB-KERNEL:*EVAL-CALLS*)
  353.   (force-output stream))
  354.  
  355. (defun parse-f-signature (l)
  356.   "Common Lisp requires we ((VARIABLE TYPE)) when using defmethod, which is tiresome.
  357. An F-SIGNATURE consists of predefined nicknames for base types and is parsed into an
  358. acceptable LAMBDA LIST. MAPCAR CAR or MAPCAR SECOND yeilds less or more formal DEFUN
  359. friendly argl ists. Declaration typing information could also be generated"
  360.   (if (some 'listp l) l
  361.       (loop with nicknames = '((p pathname)
  362.                    (s string)
  363.                    (o t)
  364.                    (l list)
  365.                    (i symbol)
  366.                    (pkg package))
  367.      for o in l
  368.      for x = (find o nicknames :key 'car)
  369.      collect (or x o))))
  370.  
  371. (defun init-hook ()
  372.   (setf rt (find-readtable :fare-quasiquote)
  373.     sb-int:*repl-prompt-fun* 'REPL-PROMPT
  374.     *INIT-HOOKS* '(init-hook)
  375.     *compile-print* t
  376.     *compile-verbose* t
  377.     *load-print* t
  378.     *load-verbose* t))
  379.  
  380. (defun location-graph (stream)
  381.   (let* ((*print-length* 3)
  382.      (n (length (write-to-string pwd))))
  383.     (labels ((adjust () (loop repeat n do (write-char #\space stream))))
  384.       (dlet (uarrow larrow rarrow vbreak darrow)
  385.       '("      A     "
  386.         " <-- " " --> "
  387.         "      |     "
  388.         "      V     ")
  389.     ;; UP
  390.     ;;(adjust)
  391.     (fresh-line stream)
  392.     (write (up pwd) :stream stream)
  393.     (fresh-line stream)
  394.     (adjust)
  395.     (princ uarrow)
  396.     (fresh-line stream)
  397.     (adjust)
  398.     (princ vbreak)
  399.     (fresh-line stream)
  400.  
  401.     ;; CENTER
  402.     (write (left pwd) :stream stream)
  403.     (princ larrow)
  404.     (write pwd :stream stream)
  405.     (princ rarrow)
  406.     (write (right pwd) :stream stream)
  407.     (fresh-line stream)
  408.  
  409.     ;; DOWN
  410.     (adjust)
  411.     (princ vbreak)
  412.     (fresh-line stream)
  413.     (adjust)
  414.     (princ darrow)
  415.     (fresh-line stream)
  416.     (adjust)
  417.     (write (down pwd) :stream stream)
  418.     (fresh-line stream)
  419.     (values)))))
  420.  
  421. (defun out (control-string &rest format-arguments)
  422.   (apply 'format (list t control-string format-arguments))
  423.   (force-output))
  424.  
  425. (defun hashtable->list (hashtable)
  426.   (let* ((out))
  427.     (maphash (lambda (k v) (push (list k v) out))
  428.          hashtable)
  429.     out))
  430.  
  431. (defun walk-tree (fun tree)
  432.   "http://lisptips.com/post/43404489000/the-tree-walkers-of-cl"
  433.   (subst-if t (constantly nil) tree :key fun))
  434.  
  435. (defun walk-tree-atoms (fun tree)
  436.   "http://lisptips.com/post/43404489000/the-tree-walkers-of-cl"
  437.   (tree-equal tree tree
  438.           :test (lambda (element-1 element-2)
  439.               (declare (ignore element-2))
  440.               (funcall fun element-1) t)))
  441.  
  442. (defun select-node (fun tree &optional (ignore-errors t))
  443.   (walk-tree (lambda (node) (when (if ignore-errors
  444.                       (ignore-errors (funcall fun node))
  445.                       (funcall fun node))
  446.                   (return-from select-node node)))
  447.          tree))
  448.  
  449. (defun collect-nodes (fun tree &optional (ignore-errors t))
  450.   (let* ((v0 nil))
  451.     (walk-tree (lambda (node) (when (if ignore-errors
  452.                     (ignore-errors (funcall fun node))
  453.                     (funcall fun node))
  454.                 (push node v0)))
  455.            tree)
  456.     v0))
  457.  
  458. (defmacro with-getfs (getfs plist &rest body)
  459.   (assert (every 'keywordp getfs))
  460.   `(let* ,(loop for getf in getfs
  461.          collect (list (intern (symbol-name getf)) (list 'getf plist getf)))
  462.      ,@body))
  463.  
  464. (defun expand-class-slot-abbreviation (l)
  465.   (assert (and (listp l) (oddp (length l))))
  466.   (let* ((slot-name (car l))
  467.          (remaining-plist (rest l)))
  468.     (if (or (getf remaining-plist :reader)
  469.             (getf remaining-plist :writer)
  470.             (getf remaining-plist :accessor)
  471.             (getf remaining-plist :initarg))
  472.         l ;; there is nothing to be done
  473.         (progn
  474.           (setf (getf remaining-plist :initform) (getf remaining-plist :initform)
  475.                 (getf remaining-plist :initarg) (make-keyword slot-name)
  476.                 (getf remaining-plist :accessor) slot-name)
  477.           (cons slot-name remaining-)))))
  478.  
  479. (defmacro c (name (&rest superclasses) (&rest slots) &rest args)
  480.   `(defclass ,name ,superclasses
  481.      ,(loop for slot-name in slots
  482.      collect (etypecase slot-name
  483.            (symbol (list slot-name
  484.                  :accessor slot-name
  485.                  :initarg (intern (format nil "~a" slot-name) 'keyword)
  486.                  :initform nil))
  487.            (cons (expand-class-slot-abbreviation slot-name))))
  488.      ,@args))
  489.  
  490. (defun sformat (control-string &rest format-arguments)
  491.   (apply 'format (append (list nil control-string) format-arguments)))
  492.  
  493. (defmethod args ((i symbol)) (sb-introspect:function-lambda-list i))
  494.  
  495. (defun f-signature (symbol) `(f ,symbol ,(args symbol)))
  496.  
  497. (defun trim (s)
  498.   (string-right-trim '(#\space #\newline #\tab)
  499.              (string-left-trim '(#\space #\newline #\tab) s)))
  500.  
  501. (defun specification-f? (name args body)
  502.   (when (or (and (= 1 (length body))
  503.          (stringp (car body)))
  504.         (null body))
  505.     name))
  506.  
  507. (defun removes (removes sequence &rest args
  508.         &key from-end (test #'eql)
  509.           test-not (start 0)
  510.           end count key)
  511.   (loop with v0 = sequence
  512.      for remove in removes
  513.      do (setf v0 (remove remove v0
  514.              :key key
  515.              :from-end from-end
  516.              :test test
  517.              :test-not test-not
  518.              :start start
  519.              :end end
  520.              :count count))
  521.      finally (return-from removes v0)))
  522.  
  523. (defun method-f? (name args body)
  524.   (SB-PCL::FIND-GENERIC-FUNCTION name nil))
  525.  
  526. (defun defun-f? (name args body) (and name args body))
  527.  
  528. (defun pl (l &optional n)
  529.   "[P]RINT [L]IST, a non PrettyPrinting ~{~%~S~}"
  530.   (let* ((*print-pretty* nil))
  531.     (map nil (lambda (o) (print o) (when n
  532.                      (loop repeat n do (fresh-line))))
  533.      l)))
  534.  
  535. ;; (define-info-type (:function :definition) :type-spec (or fdefn null))
  536. ;; (define-info-type (:function :source) :type-spec (or list null))
  537. ;; (define-info-type (:variable :source) :type-spec (or list null))
  538.  
  539. ;; (defun %lisp (object)
  540. ;;   (let* (v0 v1)
  541. ;;     (typecase object
  542. ;;       (symbol (when (boundp object)
  543. ;;      (setf v0 (typecase object
  544. ;;             (symbol
  545. ;;              (sb-int:awhen (symbol-value object)
  546. ;;                (typecase sb-int:it
  547. ;;              (list (loop for object in sb-int:it
  548. ;;                   collect (%lisp object)))
  549. ;;              (t sb-int:it))))
  550. ;;             (t object)))))
  551. ;;       (list (loop for object in object collect (%lisp object)))
  552. ;;       (t object))
  553. ;;     (when (and (not v0) v1) (setf v0 v1 v1 nil))
  554. ;;     (values v0 v1)))
  555.  
  556. ;; (defun %source (symbol) (fboundp symbol))
  557. ;; (defun parse-sources (p)
  558. ;;   "pathnames change, and must be OPEN CLOSEd so we iterate through once on init
  559. ;; assigning SOURCE-FORMS into INFOS, then update on redefinition CONDITIONS.
  560.  
  561. ;; SBCL has what should be docstrings as comments above functions for no good
  562. ;; reason. They are moved intom
  563.  
  564. ;; Seeing as each SOURCE (or LISP) is a graph of FUNCALLs, we should be able to
  565. ;; dump a buildable set of files for arbitrary lisp code")
  566. ;; (defun hyperspec ()
  567. ;;   (walk-tree (lambda (o) (match o
  568. ;;            (((:LINK :REL "PREV" :HREF ,pointer))
  569. ;;             (list :prev ,pointer))
  570. ;;            (((:LINK :REL "UP" :HREF ,pointer))
  571. ;;             (list :up ,pointer))
  572. ;;            (((:LINK :REL "NEXT" :HREF ,pointer))
  573. ;;             (list :next ,pointer))))
  574. ;;       ))
  575.  
  576. ;; (defun induce () SB-IMPL::*EVAL-SOURCE-CONTEXT*)
  577. ;; (define-symbol-macro %... (induce))
  578. ;; (SB-C::CALL-WITH-EACH-GLOBALDB-NAME 'print)
  579. ;; SB-C::%DO-FORMS-FROM-INFO
  580. ;; LOAD-AS-SOURCE
  581.  
  582. (defvar unparsed-source-forms nil
  583.   "Until we know where to hang DEFTYPE, optimizers")
  584.  
  585. (defun source (i &optional source)
  586.   (if source
  587.       (setf (sb-c::info :RANDOM-DOCUMENTATION :STUFF i) source)
  588.       (sb-c::info :RANDOM-DOCUMENTATION :STUFF i)))
  589.  
  590. (defun parse-sb-file (p)
  591.   "Adds all information that can be extracted from the file's TLFs to the INFODB"
  592.   (let* ((*package* pkg))
  593.     (with-open-file (stream p :direction :input)
  594.       (loop with x = nil
  595.      while (setf x (read stream nil nil))
  596.      do (progn (print x)
  597.            (match x
  598.              (`(in-package ,package-designator)
  599.                (setf *package* (find-package package-designator)))
  600.              (`(defmethod ,name ,@args ,@body)
  601.                (source name x))
  602.              (`(defmacro ,name ,@args ,@body)
  603.                (source name x))
  604.              (`(defun ,name ,@args ,@body)
  605.                (source name x))
  606.              (`(eval-when ,@args ,@body)
  607.                (format t "~%Ignoring EVAL-WHEN"))
  608.              (`(deftype ,name ,@args ,@body)
  609.                (format t "~%Ignoring type definition ~S" name))
  610.              (`(defstruct (,name ,@args) ,@body)
  611.                (format t "~%Ignoring struct ~S" name))
  612.              (`(sb-c:defoptimizer (,name ir2-convert)
  613.                ((objects atype dtype detail code-context cast-context) node block)
  614.              ,@body))
  615.              (`(sb-c::deftransform ,name ,args ,@body))
  616.              (`(define-source-transform ,name ,args ,@body))
  617.              (`(defknown ,name (system-area-pointer alien-type) alien-value
  618.                (flushable movable)))
  619.  
  620.              (`(defglobal ,name ,@body))
  621.              (`(defconstant ,name ,@body))
  622.              (`(defvar ,name ,@body))
  623.              (`(defparameter ,name ,@body))
  624.              (`(declaim (type index *assem-max-locations*)))
  625.              (`(defstruct (,name
  626.                     (:include sset-element)
  627.                     (:constructor make-constraint (number kind x y not-p))
  628.                     (:copier nil))
  629.              ,@slots))))))))
  630.  
  631. (defmethod lisp ((package package))
  632.   (let* ((used-packages     (package-use-list package))
  633.  
  634.      (used-symbols      (mapcan (lambda (package)
  635.                       (loop for i being the external-symbols of package collect i))
  636.                     used-packages))
  637.      (shadows           '())
  638.      (shadowing-imports (make-hash-table))
  639.      (exports (loop for i being the external-symbols of package collect i))
  640.      (shadowed-symbols  (package-shadowing-symbols package))
  641.      (imports           (make-hash-table))
  642.      (prepare-token
  643.       (lambda (_ x)
  644.         (when (typep x 'package) (setf x (package-name x)))
  645.         (intern (if (stringp x) x (symbol-name x)) 'keyword))))
  646.     (do-symbols (sym package)
  647.       (unless (member sym exports)
  648.     (let ((home (symbol-package sym)))
  649.       (unless (or (eq home package)
  650.               (member sym shadowed-symbols)
  651.               (member sym used-symbols)
  652.               (member home used-packages))
  653.         (push sym (gethash home imports '()))))))
  654.     (dolist (sym shadowed-symbols)
  655.       (let ((home (symbol-package sym)))
  656.     (if (eq home package)
  657.         (push sym shadows)
  658.         (push sym (gethash home shadowing-imports '())))))
  659.     (flet ((pname (x) (funcall prepare-token :package x))
  660.        (sname (x) (funcall prepare-token :symbol  x)))
  661.       `(defpackage ,(pname (package-name package))
  662.      ,@(when (package-nicknames package)
  663.          `((:nicknames ,@(mapcar (function pname) (package-nicknames package)))))
  664.      (:use ,@(mapcar (lambda (p) (pname (package-name p))) used-packages))
  665.      ,@(when shadows
  666.          `((:shadow ,@(mapcar (function sname) shadows))))
  667.      ,@(when exports
  668.          `((:export  ,@(mapcar (function sname) exports))))
  669.      ,@(when (plusp (hash-table-count shadowing-imports))
  670.          (let ((forms '()))
  671.            (maphash (lambda (pack syms)
  672.                   (push `(:shadowing-import-from
  673.                       ,(pname (package-name pack))
  674.                       ,@(mapcar (function sname) syms))
  675.                     forms))
  676.                 shadowing-imports)
  677.            forms))
  678.      ,@(when (plusp (hash-table-count imports))
  679.          (let ((forms '()))
  680.            (maphash (lambda (pack syms)
  681.                   (push `(:import-from
  682.                       ,(pname (package-name pack))
  683.                       ,@(mapcar (function sname) syms))
  684.                     forms))
  685.                 imports)
  686.            forms))))))
  687.  
  688. (defmethod lisp ((o asdf::system))
  689.   (match o
  690.     ((class asdf::system
  691.         ASDF/COMPONENT:NAME
  692.         ASDF/COMPONENT:DESCRIPTION
  693.         ASDF/COMPONENT:SIDEWAY-DEPENDENCIES
  694.         ASDF/COMPONENT:AUTHOR
  695.         ASDF/COMPONENT:CHILDREN
  696.         ASDF/COMPONENT:LONG-DESCRIPTION
  697.         VERSION)
  698.      `(asdf::defsystem ,(->k ASDF/COMPONENT:NAME)
  699.     ,@(when ASDF/COMPONENT:AUTHOR
  700.         `(:author ,ASDF/COMPONENT:AUTHOR))
  701.     ,@(when ASDF/COMPONENT:DESCRIPTION
  702.         `(:description ,ASDF/COMPONENT:DESCRIPTION))
  703.     ,@(when ASDF/COMPONENT:LONG-DESCRIPTION
  704.         `(:long-description ,ASDF/COMPONENT:LONG-DESCRIPTION))
  705.     ,@(when version `(:version ,VERSION))
  706.     ,@(when ASDF/COMPONENT:SIDEWAY-DEPENDENCIES
  707.         ;; Is identical to ASDF/SYSTEM::DEPENDS-ON, but sideways dependencies
  708.         ;; returns keywords, as opposed to strings.
  709.         `(:depends-on ,ASDF/COMPONENT:SIDEWAY-DEPENDENCIES))
  710.     :components  ,(lisp ASDF/COMPONENT:CHILDREN)))))
  711.  
  712. (defmethod lisp ((o cl-source-file))
  713.   (match o
  714.     ((class cl-source-file asdf/component:name)
  715.      `(:file ,ASDF/COMPONENT:NAME))))
  716.  
  717. (defmethod lisp ((o asdf::module))
  718.   (match o
  719.     ((class asdf::module asdf/component:name asdf/component:children)
  720.      `(:module ,asdf/component:name
  721.            :serial t
  722.            :components ,(mapcar 'lisp asdf/component:children)))))
  723.  
  724. (defmethod lisp ((o structure-class))
  725.   "Can we add the source form to SB-PCL::CLASS-DEFSTRUCT-FORM at load time?"
  726.   (labels ((%lisp (o)
  727.          ;; SB-PCL::STRUCTURE-DIRECT-SLOT-DEFINITION
  728.          (with-slots ((name sb-pcl::name)
  729.               (type sb-pcl::%type)
  730.               (documentation sb-pcl::%documentation)) o
  731.            `(,name nil
  732.                ,@(when documentation `(:documentation ,documentation))
  733.                ,@(when type `(:type ,type))))))
  734.     (let* ((includes (remove 'STRUCTURE-OBJECT
  735.                  (mapcar (lambda (x) (slot-value x 'sb-pcl::name))
  736.                      (SB-MOP:CLASS-DIRECT-SUPERCLASSES o))))
  737.        (slots (SB-MOP:CLASS-DIRECT-SLOTS o))
  738.        (constructor)
  739.        (copier))
  740.       `(defstruct ,(remove nil `(,(slot-value o 'sb-pcl::name)
  741.                   ,(when includes `(:include ,@includes))
  742.                   ,(when constructor `(:constructor ,constructor))
  743.                   ,(when copier `(:copier ,copier))
  744.                   ;; (:pure t)
  745.                   ;; (:predicates nil)
  746.                   ))
  747.      ,@(lisp slots)))))
  748.  
  749. (defmethod lisp ((o sb-mop:standard-effective-slot-definition))
  750.   (match o ((class sb-mop:standard-effective-slot-definition
  751.            sb-pcl::name sb-pcl::initform
  752.            sb-pcl::initargs sb-pcl::%type)
  753.         `(,sb-pcl::name
  754.           :accessor ,sb-pcl::name
  755.           ,@(list :initform sb-pcl::initform)
  756.           ,@(when sb-pcl::initargs `(:initargs ,sb-pcl::initargs))
  757.           ,@(when `(:type ,sb-pcl::%type))) )))
  758.  
  759. (defmethod lisp ((o sb-mop:standard-direct-slot-definition))
  760.   (match o
  761.     ((class SB-MOP:STANDARD-DIRECT-SLOT-DEFINITION
  762.         sb-pcl::name sb-pcl::initform
  763.         sb-pcl::initargs
  764.         sb-pcl::%type)
  765.      `(,sb-pcl::name
  766.        :accessor ,sb-pcl::name
  767.        ,@(list :initform sb-pcl::initform)
  768.        ,@(when sb-pcl::initargs `(:initargs ,@sb-pcl::initargs))
  769.        ,@(when `(:type ,sb-pcl::%type))))))
  770.  
  771. (defmethod lisp ((o standard-class))  
  772.   `(defclass ,(class-name o)
  773.        ,(mapcar 'class-name (sb-mop:class-direct-superclasses o))
  774.      ,(lisp (sb-mop:class-direct-slots o))))
  775.  
  776. (defmethod lisp ((o sb-pcl::condition-class))
  777.   `(define-condition name (signature-error)
  778.      ()
  779.      (:report
  780.       (lambda (condition stream)
  781.     (format stream "Missing signature~@[ at position ~D~] in ~A"
  782.         (signature-error-position condition)
  783.         (signature-error-source condition))))))
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top