;; KKK.LISP
;; =============================================================================
;; - The notion of internal and external symbols is stupid. Dynamic analysis of
;;   call trees allows for all documentation to be onion-layered according to
;;   high-or-lowlevel intent. All classes & whatnot belong in the same package,
;;   or at least a MUCH SMALLER set of packages
;;
;; - DEFTYPE, & DEFMETHOD unification. Why is (defmethod ... ((k keyword)) ...)
;;   invalid?
;; - single compiler build that includes pattern matching
;; - truthy predicates
;; - MACRO GENERATION
;; - RE-APPLICATION OF ALL REPL FORMS. WHY SAVE AND DIE WHEN YOU CAN SINGLE STEP
;;   BACKWARDS?
;; - INFODB SOURCES
;; - COMMENTS -> DOCSTRINGS
;; - SELF-DISTILLING SYNTATIC SUGAR
;; - DATASTRUCTURE CLIMBING,
;;
;;   (defvar place nil)
;;   (setf (getf place :a) "b" ;; repeat ~80k times, so place.length
;;                             ;; = ~160k & really wants a hashmap
;;         (loop with v0 = (make-hashmap :count (/ (length place) 2))
;;               for k in (plist-keys place)
;; 	      do (setf (gethash v0 k) (getf place k))))
;;
;; what is missing here is the implementation of the GENERIC-FUNCTIONs
;; SOURCE & LISP + a proggy walker (easy pi tho). Detect for some
;; threshold when to update from one datastructure (list->array,
;; list->hashmap) for all variables in memory (check sb-introspect for
;; the impl) when datastructure changes, (COMPILE (LISP X)) => equal
;; to (SOURCE X)
;;
;; (SB-KERNEL::STRUCTURE-CLASSOID-CLASS-INFO
;;      (SB-PCL::CLASS-CLASSOID (find-class 'sb-c::constraint)))
;;
;; UTIL FUNCTIONS
;; =============================================================================
;; FUNCTION SPECIFICATIONS -- OR -- GENERIC FUNCTIONS
;; =============================================================================
;; FUNCTION IMPLEMENTATIONS -- OR -- METHODS
;; =============================================================================
;; NEW FRIENDS -- OR -- THE F, M & C MACROS
;; =============================================================================
;; (list SB-PCL::*THE-CLASS-FUNCALLABLE-STANDARD-CLASS*
;; SB-PCL::*THE-CLASS-FUNCALLABLE-STANDARD-OBJECT*
;; SB-KERNEL::*FUNCALLABLE-INSTANCE-TYPE*
;; SB-KERNEL::**BUILT-IN-CLASS-CODES**
;; SB-KERNEL::*NON-INSTANCE-CLASSOID-TYPES*
;; SB-PCL::**STANDARD-METHOD-CLASSES**
;; SB-VM::**PRIMITIVE-TYPE-AUX-CACHE-VECTOR**
;; SB-PCL::*STANDARD-CLASSES*
;; SB-PCL::*STANDARD-METHOD-CLASS-NAMES*)
;; SB-C::PRESENT-IN-FORM
;; SB-KERNEL::*DEF!STRUCT-TYPE-MAKE-LOAD-FORM-FUN*
;; *REPL-READ-FORM-FUN*
;; SB-WALKER:WALK-FORM
;;
;; (sb-walker::walk-form
;;  '(let* ((x 2)
;; 	 (y 4)
;; 	 (z nil))
;;    (list (+ x f)
;;     (+ y c)
;;     (+ z e))) nil
;;  (lambda (subform context env)
;;    (declare (ignore context env))
;;    (print subform)))

(progn (defun lisp-fu (&optional with-graphics?)
	 "This doesn't work because why?

loop for x in list-all-packages do sb-ext::unlock-package x
format t \"~%; Unlocking ~s\" x"
	 (SET-SBCL-SOURCE-LOCATION #p"~/sb/")
	 (macrolet ((taking-new (&rest body)
		      `(handler-bind ((name-conflict (lambda (condition)
						       (invoke-restart 'sb-impl::take-new))))
			 ,@body)))
	   (let* ((metaprogramming-systems
		   '(:anaphora :cl-ppcre :optima :fare-quasiquote
		     :named-readtables :fare-utils
		     :optima.ppcre :fare-quasiquote-optima
		     :fare-quasiquote-readtable :sb-introspect))
		  (graphics-systems
		   '(:mcclim :mcclim-bezier :mcclim-bezier-clx :mcclim-clx-fb
		     :clim-widgets :climacs :clouseau :clim-listener)))
	     (ql:quickload metaprogramming-systems)
	     (taking-new
	      (use-package :asdf)
	      (use-package :optima)
	      (use-package :optima.ppcre)
	      (use-package :cl-ppcre)
	      (use-package :fare-quasiquote)
	      (use-package :named-readtables)
	      (use-package :anaphora)
	      (use-package :sb-impl)
	      (use-package :sb-int)
	      (load "~/sb/contrib/sb-introspect/sb-introspect.asd")
	      (asdf::operate :compile-op :sb-introspect)
	      (asdf::operate :load-op :sb-introspect)
	      (use-package :sb-introspect))
	     (when with-graphics? (ql:quickload graphics-systems))
	     (eval (read-from-string "(in-readtable :fare-quasiquote)")))))
       (lisp-fu t))

(defun infos (sym)
  `(,sym
    ,@(remove-if-not
       'third
       (loop for o across sb-c::*info-types*
	  when o collect (let* ((category (slot-value o 'SB-C::CATEGORY))
				(kind (slot-value o 'sb-c::kind)))
			   (list category kind (sb-c::info category kind sym)))))))

(defun alias (f1 f2)
  (assert (fboundp f1))
  (loop for (class type x) in (rest (infos f1))
     do (setf (sb-c::info class type f2) x)
     finally (return (values (infos f2) f1))))

(defun unicode-apropos (s)
  "Unicode characters are named in :UPCASE, ARABIC, CRYLLIC etc"
  (setf s (string-upcase s))
  (loop with errors = nil with v0 = nil
     for a across SB-INT:**UNICODE-CHAR-NAME-DATABASE**
     ;; SB-INT:**UNICODE-1-NAME-CHAR-DATABASE**
     for x = (ignore-errors (code-char a))
     do (if (and x (scan s (char-name (code-char a))))
	    (push x v0)
	    (push a errors))
     finally (return v0)))

(defgeneric lisp (object)
  (:documentation "LISP returns the lisp code that /defines/ OBJECT for its current value.
Implementing LISP DEFMETHODS for all of the base types allow for when *PRINT-READABLY* = T."))

(defgeneric source (object)
  (:documentation "LISP returns the lisp code that /defined/ OBJECT"))

(defgeneric name (o)
  (:documentation "PACKAGE-NAME & friends are redundant")
  ;; (apropos "-name")
  ;; (apropos "LIST-ALL")
  ;; (apropos "PARSE-")
  ;; (apropos "WITH-")
  ;; (apropos "MAP-")
  ;; (apropos "DO-")
  )

(defgeneric more (o)
  (:documentation
   "`(,OBJECT ,@INTERESTING-BRANCHES) allowing for CAR to reduce a graph node in place"))

(defgeneric args (o) (:documentation "DWIM SB-INTROSPECT:FUNCTION-LAMBDA-LIST & co!"))

(defmethod names ((c standard-class))
  (mapcar 'SB-MOP:SLOT-DEFINITION-NAME (SB-MOP:CLASS-SLOTS c)))

(defmethod lisp ((list list)) (loop for object in list collect (lisp object)))
(defmethod lisp ((number number)) number)
(defmethod lisp ((string string)) string)
(defmethod lisp ((name symbol))
  (if (keywordp name)
      (or (awhen (find-package name)) (awhen (asdf::find-system name)))
      name))

(defun ->s (o)
  "SYMBOLICATE"
  (typecase o
    (string o)
    (symbol (symbol-name o))
    (SB-IMPL::STRING-OUTPUT-STREAM (cl::make-string-output-stream))))

(defun ->k (o)
  "KEYWORDICATE"
  (typecase o
    (string (intern (string-upcase o) 'keyword))
    (symbol (intern (symbol-name o) 'keyword))))

(defun ->class (o)
  (typecase o
    (symbol (find-class o nil))
    (t (find-class (type-of o) nil))))

(defun fill-paragraph-to-column (string &optional (fill-column 80))
    "Copied from Advanced Use of Lisp's FORMAT Function pg. 5

  Here's how it works:
  1. The ~{ applies its inner format string to each element in its argument. In
  our case, the inner format string is '~<~%~1,FILL-COLUMN:;~A~>'. The argument
  is WORDS which is a list of strings.

  2. The inner string is applied to the next element in WORDS.

  (a) The '~<~%~1,FILL-COLUMN:;~A~>' has two clauses:
  (b) That first clause is special becaues it ends with two integers & a colon.
      That special type of clause means 'Do not print this clause unless the
      length of the result of formatting the other clause is longer than
      40 - 1 -> 39.'

  3. Until WORDS is the empty list, repeat step number 2.

  Step 2.2 is where the action happens. The ~< directive is given one of the
  words, which it formats according to the its second clause, ~A. It takes the
  result of that operation, adds its length to the line position of the output
  stream (or the output string, since we're using NIL as FORMAT's first argument),
  & comparse that sum to 40 - 1 -> 39, which it gets from the first clause. If the
  sum is greater than 39, the ~< output the first part of its first clause &
  resets the line position to 0. Then it outputs the word that it just formatted"
  (assert (not (find #\newline string :test 'char=)))
  (let* ((format-string (format nil "~~{~~<~~%~~1,~A:;~~A~~> ~~}" fill-column))
	 (words (cl-ppcre::split #\space string)))
    (format nil format-string words)))

(defun absorb-variables (package)
  "Absorbs variables, ignoring any symbols that cause conflicts"
  (loop for symbol being the present-symbols of package
     for x = (when (and (boundp symbol)
			(ignore-errors (import symbol)))
	       symbol)
     when x collect x))

(defun absorb-functions (package)
  "Absorbs functions, ignoring any symbols that cause conflicts"
  (loop for symbol being the present-symbols of package
     for x = (when (and (fboundp symbol) (ignore-errors (import symbol)))
	       symbol)
     when x collect x))

(defun absorb (package)
  "Absorbs variables & functions "
  (append (absorb-variables package) (absorb-functions package)))

(defun take (n l) (loop repeat n for e in l collect e))

(defun drop (n l)
  (unless (> n (length l)) (subseq l n (length l))))

(defmethod up ((o t))
  (slot-value o (slot-value (first (SB-MOP:CLASS-SLOTS (->class o))) 'sb-pcl::name)))
(defmethod left ((o t))
  (slot-value o (slot-value (second (SB-MOP:CLASS-SLOTS (->class o))) 'sb-pcl::name)))
(defmethod down ((o t))
  (slot-value o (slot-value (third (SB-MOP:CLASS-SLOTS (->class o))) 'sb-pcl::name)))
(defmethod right ((o t))
  (slot-value o (slot-value (fourth (SB-MOP:CLASS-SLOTS (->class o))) 'sb-pcl::name)))

(alias 'lambda 'y)
(alias 'make-instance 'instance)
(alias 'remove-if-not 'filter)
(alias 'expt '^)
(alias 'uiop/stream:read-file-lines 'lines)
(alias 'uiop/stream:read-file-forms 'forms)
(alias 'ql-dist::system-apropos '?system)
(alias 'ql-dist::system-apropos-list '?systems)
(alias 'apropos '?)
(alias 'apropos-list '?s)
(alias 'remove-duplicates 'distinct)
(alias 'describe '??)
(alias 'define-symbol-macro 'cheat)
(alias 'defparameter 'var)
(alias 'rename-file 'mv)

;; (sb-pcl::make-structure-class-defstruct-form )
;; (SB-VM::MAP-ALLOCATED-OBJECTS (lambda (&rest _) (print _)) :dynamic)
;; (SB-PCL::MAP-ALL-GENERIC-FUNCTIONS 'print)

;; (define-symbol-macro args
;;     (let* ((v0 nil))
;;       (do-all-symbols (x)
;; 	(when (fboundp x)
;; 	  (when (equal '(structure-class) (args x))
;; 	    (push x v0))))
;;       v0))

(cheat structures
       (let* ((v0 nil))
	 (sb-pcl::map-all-classes
	  (lambda (x) (when (typep x 'structure-class) (push x v0))))
	 v0))

(cheat conditions
       (let* ((v0 nil))
	 (sb-pcl::map-all-classes
	  (lambda (x) (when (typep x 'sb-pcl::condition-class) (push x v0))))
	 v0))

(cheat classes
       (let* ((v0 nil))
	 (sb-pcl::map-all-classes (lambda (x) (push x v0)))
	 v0))
(cheat rt *readtable*)
(cheat pkg *package*)
(cheat pkgs (list-all-packages))
(cheat kpkg SB-INT:*KEYWORD-PACKAGE*)
(cheat systems ASDF/FIND-SYSTEM:*DEFINED-SYSTEMS*)
(cheat dir *default-pathname-defaults*)
(cheat q (save-lisp-and-die (format nil "m~a" (symbol-name (gensym))) :executable t))
(cheat ls (ls dir))
(cheat out *standard-output*)
(cheat in *standard-input*)
(cheat &keys LAMBDA-LIST-KEYWORDS)

(var pwd (setf dir #p"/"))

(defun ls (dir)
  (assert (probe-file dir))
  (let* ((v0 nil))
    (sb-ext::map-directory (lambda (p) (push p v0))
			   dir
			   :directories t
			   :files t)
    v0))

(defun dirs (dir)
  (assert (probe-file dir))
  (let* ((v0 nil))
    (sb-ext::map-directory (lambda (p) (push p v0))
			   dir
			   :directories t
			   :files nil)
    v0))

(defun files (dir)
  (assert (probe-file dir))
  (let* ((v0 nil))
    (sb-ext::map-directory (lambda (p) (push p v0))
			   dir
			   :directories nil
			   :files t)
    v0))

(defun walk-directory (function dir &optional directories?)
  "When DIRECTORIES?, FUNCTION is funcalled on them as well"
  (assert (probe-file dir))
  (labels ((%walk (dir)
	     (if directories?
		 (sb-ext::map-directory function dir :directories t :files t)
		 (sb-ext::map-directory function dir :directories nil :files t))
	     (sb-ext::map-directory #'%walk dir :directories t :files nil)))
    (%walk dir)))

(defun %load-system (a)
  (asdf::operate 'asdf::compile-op a :force t)
  (asdf::operate 'asdf::load-op a :force t))

(defun repl-prompt (stream)
  (format stream "~%~A,~A,~A> "
	  (package-name *package*)
	  (readtable-name *readtable*)
	  SB-KERNEL:*EVAL-CALLS*)
  (force-output stream))

(defun parse-f-signature (l)
  "Common Lisp requires we ((VARIABLE TYPE)) when using defmethod, which is tiresome.
An F-SIGNATURE consists of predefined nicknames for base types and is parsed into an
acceptable LAMBDA LIST. MAPCAR CAR or MAPCAR SECOND yeilds less or more formal DEFUN
friendly argl ists. Declaration typing information could also be generated"
  (if (some 'listp l) l
      (loop with nicknames = '((p pathname)
			       (s string)
			       (o t)
			       (l list)
			       (i symbol)
			       (pkg package))
	 for o in l
	 for x = (find o nicknames :key 'car)
	 collect (or x o))))

(defun init-hook ()
  (setf rt (find-readtable :fare-quasiquote)
	sb-int:*repl-prompt-fun* 'REPL-PROMPT
	*INIT-HOOKS* '(init-hook)
	*compile-print* t
	*compile-verbose* t
	*load-print* t
	*load-verbose* t))

(defun location-graph (stream)
  (let* ((*print-length* 3)
	 (n (length (write-to-string pwd))))
    (labels ((adjust () (loop repeat n do (write-char #\space stream))))
      (dlet (uarrow larrow rarrow vbreak darrow)
	  '("      A     "
	    " <-- " " --> "
	    "      |     "
	    "      V     ")
	;; UP
	;;(adjust)
	(fresh-line stream)
	(write (up pwd) :stream stream)
	(fresh-line stream)
	(adjust)
	(princ uarrow)
	(fresh-line stream)
	(adjust)
	(princ vbreak)
	(fresh-line stream)

	;; CENTER
	(write (left pwd) :stream stream)
	(princ larrow)
	(write pwd :stream stream)
	(princ rarrow)
	(write (right pwd) :stream stream)
	(fresh-line stream)

	;; DOWN
	(adjust)
	(princ vbreak)
	(fresh-line stream)
	(adjust)
	(princ darrow)
	(fresh-line stream)
	(adjust)
	(write (down pwd) :stream stream)
	(fresh-line stream)
	(values)))))

(defun out (control-string &rest format-arguments)
  (apply 'format (list t control-string format-arguments))
  (force-output))

(defun hashtable->list (hashtable)
  (let* ((out))
    (maphash (lambda (k v) (push (list k v) out))
         hashtable)
    out))

(defun walk-tree (fun tree)
  "http://lisptips.com/post/43404489000/the-tree-walkers-of-cl"
  (subst-if t (constantly nil) tree :key fun))

(defun walk-tree-atoms (fun tree)
  "http://lisptips.com/post/43404489000/the-tree-walkers-of-cl"
  (tree-equal tree tree
	      :test (lambda (element-1 element-2)
		      (declare (ignore element-2))
		      (funcall fun element-1) t)))

(defun select-node (fun tree &optional (ignore-errors t))
  (walk-tree (lambda (node) (when (if ignore-errors
				      (ignore-errors (funcall fun node))
				      (funcall fun node))
			      (return-from select-node node)))
	     tree))

(defun collect-nodes (fun tree &optional (ignore-errors t))
  (let* ((v0 nil))
    (walk-tree (lambda (node) (when (if ignore-errors
					(ignore-errors (funcall fun node))
					(funcall fun node))
				(push node v0)))
	       tree)
    v0))

(defmacro with-getfs (getfs plist &rest body)
  (assert (every 'keywordp getfs))
  `(let* ,(loop for getf in getfs
	     collect (list (intern (symbol-name getf)) (list 'getf plist getf)))
     ,@body))

(defun expand-class-slot-abbreviation (l)
  (assert (and (listp l) (oddp (length l))))
  (let* ((slot-name (car l))
         (remaining-plist (rest l)))
    (if (or (getf remaining-plist :reader)
            (getf remaining-plist :writer)
            (getf remaining-plist :accessor)
            (getf remaining-plist :initarg))
        l ;; there is nothing to be done
        (progn
          (setf (getf remaining-plist :initform) (getf remaining-plist :initform)
                (getf remaining-plist :initarg) (make-keyword slot-name)
                (getf remaining-plist :accessor) slot-name)
          (cons slot-name remaining-)))))

(defmacro c (name (&rest superclasses) (&rest slots) &rest args)
  `(defclass ,name ,superclasses
     ,(loop for slot-name in slots
	 collect (etypecase slot-name
		   (symbol (list slot-name
				 :accessor slot-name
				 :initarg (intern (format nil "~a" slot-name) 'keyword)
				 :initform nil))
		   (cons (expand-class-slot-abbreviation slot-name))))
     ,@args))

(defun sformat (control-string &rest format-arguments)
  (apply 'format (append (list nil control-string) format-arguments)))

(defmethod args ((i symbol)) (sb-introspect:function-lambda-list i))

(defun f-signature (symbol) `(f ,symbol ,(args symbol)))

(defun trim (s)
  (string-right-trim '(#\space #\newline #\tab)
		     (string-left-trim '(#\space #\newline #\tab) s)))

(defun specification-f? (name args body)
  (when (or (and (= 1 (length body))
		 (stringp (car body)))
	    (null body))
    name))

(defun removes (removes sequence &rest args
		&key from-end (test #'eql)
		  test-not (start 0)
		  end count key)
  (loop with v0 = sequence
     for remove in removes
     do (setf v0 (remove remove v0
			 :key key
			 :from-end from-end
			 :test test
			 :test-not test-not
			 :start start
			 :end end
			 :count count))
     finally (return-from removes v0)))

(defun method-f? (name args body)
  (SB-PCL::FIND-GENERIC-FUNCTION name nil))

(defun defun-f? (name args body) (and name args body))

(defun pl (l &optional n)
  "[P]RINT [L]IST, a non PrettyPrinting ~{~%~S~}"
  (let* ((*print-pretty* nil))
    (map nil (lambda (o) (print o) (when n
				     (loop repeat n do (fresh-line))))
	 l)))

;; (define-info-type (:function :definition) :type-spec (or fdefn null))
;; (define-info-type (:function :source) :type-spec (or list null))
;; (define-info-type (:variable :source) :type-spec (or list null))

;; (defun %lisp (object)
;;   (let* (v0 v1)
;;     (typecase object
;;       (symbol (when (boundp object)
;; 		(setf v0 (typecase object
;; 			   (symbol
;; 			    (sb-int:awhen (symbol-value object)
;; 			      (typecase sb-int:it
;; 				(list (loop for object in sb-int:it
;; 					 collect (%lisp object)))
;; 				(t sb-int:it))))
;; 			   (t object)))))
;;       (list (loop for object in object collect (%lisp object)))
;;       (t object))
;;     (when (and (not v0) v1) (setf v0 v1 v1 nil))
;;     (values v0 v1)))

;; (defun %source (symbol) (fboundp symbol))
;; (defun parse-sources (p)
;;   "pathnames change, and must be OPEN CLOSEd so we iterate through once on init
;; assigning SOURCE-FORMS into INFOS, then update on redefinition CONDITIONS.

;; SBCL has what should be docstrings as comments above functions for no good
;; reason. They are moved intom

;; Seeing as each SOURCE (or LISP) is a graph of FUNCALLs, we should be able to
;; dump a buildable set of files for arbitrary lisp code")
;; (defun hyperspec ()
;;   (walk-tree (lambda (o) (match o
;; 			  (((:LINK :REL "PREV" :HREF ,pointer))
;; 			   (list :prev ,pointer))
;; 			  (((:LINK :REL "UP" :HREF ,pointer))
;; 			   (list :up ,pointer))
;; 			  (((:LINK :REL "NEXT" :HREF ,pointer))
;; 			   (list :next ,pointer))))
;; 	     ))

;; (defun induce () SB-IMPL::*EVAL-SOURCE-CONTEXT*)
;; (define-symbol-macro %... (induce))
;; (SB-C::CALL-WITH-EACH-GLOBALDB-NAME 'print)
;; SB-C::%DO-FORMS-FROM-INFO
;; LOAD-AS-SOURCE

(defvar unparsed-source-forms nil
  "Until we know where to hang DEFTYPE, optimizers")

(defun source (i &optional source)
  (if source
      (setf (sb-c::info :RANDOM-DOCUMENTATION :STUFF i) source)
      (sb-c::info :RANDOM-DOCUMENTATION :STUFF i)))

(defun parse-sb-file (p)
  "Adds all information that can be extracted from the file's TLFs to the INFODB"
  (let* ((*package* pkg))
    (with-open-file (stream p :direction :input)
      (loop with x = nil
	 while (setf x (read stream nil nil))
	 do (progn (print x)
		   (match x
		     (`(in-package ,package-designator)
		       (setf *package* (find-package package-designator)))
		     (`(defmethod ,name ,@args ,@body)
		       (source name x))
		     (`(defmacro ,name ,@args ,@body)
		       (source name x))
		     (`(defun ,name ,@args ,@body)
		       (source name x))
		     (`(eval-when ,@args ,@body)
		       (format t "~%Ignoring EVAL-WHEN"))
		     (`(deftype ,name ,@args ,@body)
		       (format t "~%Ignoring type definition ~S" name))
		     (`(defstruct (,name ,@args) ,@body)
		       (format t "~%Ignoring struct ~S" name))
		     (`(sb-c:defoptimizer (,name ir2-convert)
			   ((objects atype dtype detail code-context cast-context) node block)
			 ,@body))
		     (`(sb-c::deftransform ,name ,args ,@body))
		     (`(define-source-transform ,name ,args ,@body))
		     (`(defknown ,name (system-area-pointer alien-type) alien-value
			   (flushable movable)))

		     (`(defglobal ,name ,@body))
		     (`(defconstant ,name ,@body))
		     (`(defvar ,name ,@body))
		     (`(defparameter ,name ,@body))
		     (`(declaim (type index *assem-max-locations*)))
		     (`(defstruct (,name
				    (:include sset-element)
				    (:constructor make-constraint (number kind x y not-p))
				    (:copier nil))
			 ,@slots))))))))

(defmethod lisp ((package package))
  (let* ((used-packages     (package-use-list package))

	 (used-symbols      (mapcan (lambda (package)
				      (loop for i being the external-symbols of package collect i))
				    used-packages))
	 (shadows           '())
	 (shadowing-imports (make-hash-table))
	 (exports (loop for i being the external-symbols of package collect i))
	 (shadowed-symbols  (package-shadowing-symbols package))
	 (imports           (make-hash-table))
	 (prepare-token
	  (lambda (_ x)
	    (when (typep x 'package) (setf x (package-name x)))
	    (intern (if (stringp x) x (symbol-name x)) 'keyword))))
    (do-symbols (sym package)
      (unless (member sym exports)
	(let ((home (symbol-package sym)))
	  (unless (or (eq home package)
		      (member sym shadowed-symbols)
		      (member sym used-symbols)
		      (member home used-packages))
	    (push sym (gethash home imports '()))))))
    (dolist (sym shadowed-symbols)
      (let ((home (symbol-package sym)))
	(if (eq home package)
	    (push sym shadows)
	    (push sym (gethash home shadowing-imports '())))))
    (flet ((pname (x) (funcall prepare-token :package x))
	   (sname (x) (funcall prepare-token :symbol  x)))
      `(defpackage ,(pname (package-name package))
	 ,@(when (package-nicknames package)
		 `((:nicknames ,@(mapcar (function pname) (package-nicknames package)))))
	 (:use ,@(mapcar (lambda (p) (pname (package-name p))) used-packages))
	 ,@(when shadows
		 `((:shadow ,@(mapcar (function sname) shadows))))
	 ,@(when exports
		 `((:export  ,@(mapcar (function sname) exports))))
	 ,@(when (plusp (hash-table-count shadowing-imports))
		 (let ((forms '()))
		   (maphash (lambda (pack syms)
			      (push `(:shadowing-import-from
				      ,(pname (package-name pack))
				      ,@(mapcar (function sname) syms))
				    forms))
			    shadowing-imports)
		   forms))
	 ,@(when (plusp (hash-table-count imports))
		 (let ((forms '()))
		   (maphash (lambda (pack syms)
			      (push `(:import-from
				      ,(pname (package-name pack))
				      ,@(mapcar (function sname) syms))
				    forms))
			    imports)
		   forms))))))

(defmethod lisp ((o asdf::system))
  (match o
    ((class asdf::system
	    ASDF/COMPONENT:NAME
	    ASDF/COMPONENT:DESCRIPTION
	    ASDF/COMPONENT:SIDEWAY-DEPENDENCIES
	    ASDF/COMPONENT:AUTHOR
	    ASDF/COMPONENT:CHILDREN
	    ASDF/COMPONENT:LONG-DESCRIPTION
	    VERSION)
     `(asdf::defsystem ,(->k ASDF/COMPONENT:NAME)
	,@(when ASDF/COMPONENT:AUTHOR
		`(:author ,ASDF/COMPONENT:AUTHOR))
	,@(when ASDF/COMPONENT:DESCRIPTION
		`(:description ,ASDF/COMPONENT:DESCRIPTION))
	,@(when ASDF/COMPONENT:LONG-DESCRIPTION
		`(:long-description ,ASDF/COMPONENT:LONG-DESCRIPTION))
	,@(when version `(:version ,VERSION))
	,@(when ASDF/COMPONENT:SIDEWAY-DEPENDENCIES
		;; Is identical to ASDF/SYSTEM::DEPENDS-ON, but sideways dependencies
		;; returns keywords, as opposed to strings.
		`(:depends-on ,ASDF/COMPONENT:SIDEWAY-DEPENDENCIES))
	:components  ,(lisp ASDF/COMPONENT:CHILDREN)))))

(defmethod lisp ((o cl-source-file))
  (match o
    ((class cl-source-file asdf/component:name)
     `(:file ,ASDF/COMPONENT:NAME))))

(defmethod lisp ((o asdf::module))
  (match o
    ((class asdf::module asdf/component:name asdf/component:children)
     `(:module ,asdf/component:name
	       :serial t
	       :components ,(mapcar 'lisp asdf/component:children)))))

(defmethod lisp ((o structure-class))
  "Can we add the source form to SB-PCL::CLASS-DEFSTRUCT-FORM at load time?"
  (labels ((%lisp (o)
	     ;; SB-PCL::STRUCTURE-DIRECT-SLOT-DEFINITION
	     (with-slots ((name sb-pcl::name)
			  (type sb-pcl::%type)
			  (documentation sb-pcl::%documentation)) o
	       `(,name nil
		       ,@(when documentation `(:documentation ,documentation))
		       ,@(when type `(:type ,type))))))
    (let* ((includes (remove 'STRUCTURE-OBJECT
			     (mapcar (lambda (x) (slot-value x 'sb-pcl::name))
				     (SB-MOP:CLASS-DIRECT-SUPERCLASSES o))))
	   (slots (SB-MOP:CLASS-DIRECT-SLOTS o))
	   (constructor)
	   (copier))
      `(defstruct ,(remove nil `(,(slot-value o 'sb-pcl::name)
				  ,(when includes `(:include ,@includes))
				  ,(when constructor `(:constructor ,constructor))
				  ,(when copier `(:copier ,copier))
				  ;; (:pure t)
				  ;; (:predicates nil)
				  ))
	 ,@(lisp slots)))))

(defmethod lisp ((o sb-mop:standard-effective-slot-definition))
  (match o ((class sb-mop:standard-effective-slot-definition
		   sb-pcl::name sb-pcl::initform
		   sb-pcl::initargs sb-pcl::%type)
	    `(,sb-pcl::name
	      :accessor ,sb-pcl::name
	      ,@(list :initform sb-pcl::initform)
	      ,@(when sb-pcl::initargs `(:initargs ,sb-pcl::initargs))
	      ,@(when `(:type ,sb-pcl::%type))) )))

(defmethod lisp ((o sb-mop:standard-direct-slot-definition))
  (match o
    ((class SB-MOP:STANDARD-DIRECT-SLOT-DEFINITION
	    sb-pcl::name sb-pcl::initform
	    sb-pcl::initargs
	    sb-pcl::%type)
     `(,sb-pcl::name
       :accessor ,sb-pcl::name
       ,@(list :initform sb-pcl::initform)
       ,@(when sb-pcl::initargs `(:initargs ,@sb-pcl::initargs))
       ,@(when `(:type ,sb-pcl::%type))))))

(defmethod lisp ((o standard-class))
  `(defclass ,(class-name o)
       ,(mapcar 'class-name (sb-mop:class-direct-superclasses o))
     ,(lisp (sb-mop:class-direct-slots o))))

(defmethod lisp ((o sb-pcl::condition-class))
  `(define-condition name (signature-error)
     ()
     (:report
      (lambda (condition stream)
	(format stream "Missing signature~@[ at position ~D~] in ~A"
		(signature-error-position condition)
		(signature-error-source condition))))))