dotfiles/sbclrc at master · realark/dotfiles · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
; -*- mode: Lisp;-*-

;; (setf *read-default-float-format* 'double-float)

(sb-ext:restrict-compiler-policy 'debug 3)
(sb-ext:set-sbcl-source-location "~/prog/sbcl")

(push :ark-dev-machine *features*)

(require 'asdf)
#-quicklisp
(let ((quicklisp-init
       (merge-pathnames ".roswell/lisp/quicklisp/setup.lisp"
                        (user-homedir-pathname))))
  (when (probe-file quicklisp-init)
    (load quicklisp-init)))

(ql:quickload :cl-annot)
(ql:quickload :clhs)
;; (ql:quickload :lisp-critic)
(annot:enable-annot-syntax)

(defpackage :ark (:use :cl))
(in-package :ark)

@export
(defmacro dis (args &rest body)
  "Disassemble a lambda expression."
  (flet ((arg-name (arg)
           (if (consp arg)
               (cadr arg)
               arg))
         (arg-decl (arg)
           (if (consp arg)
               `(type ,(car arg) ,(cadr arg))
               nil)))
    (let ((arglist (mapcar #'arg-name args))
          (declarations (mapcar #'arg-decl args)))
      `(disassemble
        (lambda ,arglist
          (declare ,@(remove nil declarations))
          ,@body)))))

@export
(defmacro disasm-method (name &rest specializers)
  "Disassemble a method.
Usage: (disasm-method #'package:generic-fun '(integer))"
  `(let* ((method (find-method (function ,name) nil '(,@specializers)))
          (function (sb-mop:method-function method))
          (fast-function (sb-pcl::%method-function-fast-function function)))
     (disassemble fast-function)))


;; hash-table literal syntax using braces
(set-macro-character #\{
		     (lambda (str char)
		       (declare (ignore char))
		       (let ((*readtable* (copy-readtable *readtable* nil))
			     (keep-going t))
			 (set-macro-character #\} (lambda (stream char)
						    (declare (ignore char) (ignore stream))
						    (setf keep-going nil)))
			 (let ((pairs (loop for key = (read str nil nil t)
					   while keep-going
					   for value = (read str nil nil t)
					   collect (list key value)))
			       (retn (gensym)))
			   `(let ((,retn (make-hash-table :test #'equal)))
			      ,@(mapcar
				 (lambda (pair)
				   `(setf (gethash ,(car pair) ,retn) ,(cadr pair)))
				 pairs)
			      ,retn)))))

(defparameter *pretty-print-hash-table* t)

(defmethod print-object ((object hash-table) stream)
  (format stream "#HASH{count ~a test ~a}{~{~{(~a : ~a)~}~^ ~}}"
          (hash-table-count object)
          (hash-table-test object)
          (when *pretty-print-hash-table*
            (loop for key being the hash-keys of object
                    using (hash-value value)
                  collect (list key value)))))