Skip to content

Commit 03c5ba8

Browse files
willfwillf
committed
first commit
0 parents  commit 03c5ba8

14 files changed

+1794
-0
lines changed

‎Code/Utilities/logging.lisp

+95
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,95 @@
1+
(in-package "LOG")
2+
;;------------------------------------------------------------------------------
3+
;;
4+
;; File: LOGGING.LISP
5+
;; Created: 10/19/94
6+
;; Author: Will Fitzgerald
7+
;;
8+
;; Description: A simple logging facility
9+
;;
10+
;;------------------------------------------------------------------------------
11+
12+
13+
14+
;;------------------------------------------------------------------------------
15+
;; Packages
16+
;;------------------------------------------------------------------------------
17+
(eval-when (load eval compile)
18+
(unless (find-package :log)
19+
(make-package :log)))
20+
21+
(in-package :log)
22+
(use-package :tables)
23+
24+
(export '(reset-log set-logging record-log print-log with-logging))
25+
26+
27+
;;------------------------------------------------------------------------------
28+
;; A log is a list of statements keyed off a symbolic form.
29+
;;------------------------------------------------------------------------------
30+
(deftable log-of)
31+
32+
(defvar *logging* nil)
33+
(defvar *log-keys* nil)
34+
35+
(defun reset-log ()
36+
(clear-table (log-of))
37+
(setf *log-keys* nil)
38+
*logging*)
39+
40+
;;------------------------------------------------------------------------------
41+
;; Turning logging off and on.
42+
;;------------------------------------------------------------------------------
43+
(defun set-logging (&optional (value t))
44+
(setf *logging* value))
45+
46+
(defmacro with-logging (&rest body)
47+
`(let ((*logging* t))
48+
(reset-log)
49+
,@body))
50+
51+
;;------------------------------------------------------------------------------
52+
;; Making records in the log
53+
;;------------------------------------------------------------------------------
54+
(defun make-statement (string args)
55+
(format nil "~?" string args))
56+
57+
(defun record-log (logname string &rest args)
58+
(when *logging*
59+
(push (make-statement string args) (log-of logname))
60+
(pushnew logname *log-keys* )
61+
*logging*))
62+
63+
;;------------------------------------------------------------------------------
64+
;; Printing the log
65+
;;------------------------------------------------------------------------------
66+
67+
(defun print-log (&optional logname (stream *standard-output*))
68+
(if logname
69+
(loop for log-entry in (reverse (log-of logname))
70+
doing
71+
(format stream "~A~%" log-entry))
72+
(loop for log-key in (reverse *log-keys*) doing
73+
(print-log log-key stream)))
74+
(values))
75+
76+
77+
78+
79+
#|
80+
81+
(defun fact (n)
82+
(record-log 'fact "entering FACT with ~S" n)
83+
(cond
84+
((= n 1) 1)
85+
(t (* (fact (1- n)) n))))
86+
87+
(set-logging)
88+
(reset-log)
89+
(fact 20)
90+
(print-log)
91+
92+
(set-logging nil)
93+
(with-logging (fact 4))
94+
(print-log)
95+
|#

‎Code/Utilities/tables.lisp

+161
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,161 @@
1+
;;; A simple table utility
2+
;;; ----------------------------------------------------------------------
3+
;;; - File: tables.lisp
4+
;;; - Author: Chris Riesbeck
5+
;;; - Most recent update: 7/27/94
6+
7+
;;; ----------------------------------------------------------------------
8+
;;; Defining a table function
9+
;;; ----------------------------------------------------------------------
10+
11+
;;; (DEFTABLE name) => name
12+
;;;
13+
;;; DEFTABLE defines name to be a table function such that
14+
;;;
15+
;;; - (name key) retrieves a value for key, if any
16+
;;; - (SETF (name key) value) stores a value for key
17+
;;; - (name) returns the internal table associated with name;
18+
;;; this is useful when manipulating tables (see below).
19+
;;;
20+
;;; The table is empty when name is defined (or redefined).
21+
;;;
22+
;;; Examples:
23+
;;;
24+
;;; > (deftable AGE-of)
25+
;;; AGE-OF
26+
;;; > (age-of 'john)
27+
;;; NIL
28+
;;; > (setf (age-of 'john) 22)
29+
;;; 22
30+
;;; > (age-of 'john)
31+
;;; 22
32+
;;;
33+
;;; Note: DEFTABLE is a top-level form, like DEFUN. It is not for
34+
;;; creating local table functions. The following is wrong:
35+
;;;
36+
;;; (defun foo (...)
37+
;;; (deftable baz)
38+
;;; ...)
39+
;;;
40+
;;; If you want a local table, use MAKE-HASH-TABLE and GETHASH.
41+
42+
43+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
44+
;;; Packages
45+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
46+
47+
(eval-when (load eval compile)
48+
(unless (find-package :tables)
49+
(make-package :tables)))
50+
51+
(in-package :tables)
52+
53+
(export '(deftable in-table-p remove-key clear-table map-table))
54+
55+
56+
;;; ----------------------------------------------------------------------
57+
;;; Implementation notes:
58+
;;;
59+
;;; - I avoided (DEFUN (SETF fn) ...) so as not to require CL 2
60+
;;; - I used PROGN to make the DEFSETF top-level for MacIntosh
61+
;;; Common Lisp.
62+
63+
(defmacro deftable (fn &optional test)
64+
(let ((set-fn (gensym)))
65+
`(progn
66+
(let* ((fn ',fn)
67+
(table (get-table fn ,test)))
68+
(defun ,fn (&optional (key nil key-given-p))
69+
(if key-given-p
70+
(gethash key table)
71+
table))
72+
(defun ,set-fn (arg1 &optional (arg2 nil arg2-p))
73+
(cond (arg2-p
74+
(setf (gethash arg1 table) arg2))
75+
(t (set-table fn arg1)))))
76+
(defsetf ,fn ,set-fn)
77+
',fn)))
78+
79+
(defvar *tables* (make-hash-table)
80+
"Table of DEFTABLE functions.")
81+
82+
(defun get-table (name test)
83+
(set-table name (make-hash-table :test (or test #'eql))))
84+
85+
(defun set-table (name table)
86+
(if (hash-table-p table)
87+
(setf (gethash name *tables*) table)
88+
(error "~S not a table" table)))
89+
90+
;;; ----------------------------------------------------------------------
91+
;;; Manipulating tables
92+
;;; ----------------------------------------------------------------------
93+
94+
;;; Certain functions need explicit access to the internal table. To
95+
;;; get this table, call the table function with no arguments, e.g.,
96+
;;; (AGE-OF). This returns the internal table for AGE-OF, which
97+
;;; can then be passed to a table manipulation function.
98+
;;;
99+
;;; Example: The following clears the AGE-OF table.
100+
;;;
101+
;;; > (clear-table (age-of))
102+
;;;
103+
;;; The nature of the internal table is implementation-dependent.
104+
105+
;;; (IN-TABLE-P key table) => T or NIL
106+
;;; Returns true if key has a value in the table.
107+
;;; (REMOVE-KEY key table) => T or NIL
108+
;;; Removes any entry for key in the table, and returns true
109+
;;; if there was one.
110+
;;; (CLEAR-TABLE table) => table
111+
;;; Removes all entries from the table.
112+
;;; (MAP-TABLE function table) => NIL
113+
;;; Calls (function key value) for every key and value in the table.
114+
;;; The order in which keys are found is implementation-dependent.
115+
116+
;;; ----------------------------------------------------------------------
117+
;;; Implementation notes:
118+
;;;
119+
;;; - I avoided MULTIPLE-VALUE-BIND for Xlisp compatibility.
120+
121+
(let ((flag (list nil)))
122+
(defun in-table-p (key table)
123+
(not (eq flag (gethash key table flag)))))
124+
125+
(defun remove-key (key table) (remhash key table))
126+
127+
(defun clear-table (table) (clrhash table))
128+
129+
(defun map-table (fn table) (maphash fn table))
130+
131+
(provide "tables")
132+
133+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
134+
;;; Change log
135+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
136+
137+
#|
138+
7/27/94 [CKR]
139+
Problem: If name is a function, (DEFTABLE name) would cause an error.
140+
Cause: Calling (name) doesn't do the right thing.
141+
Change: Store name->table associations in the table *TABLES*.
142+
143+
12/1/93 [CKR]
144+
Problem: If several packages used TABLES, they each loaded separate
145+
copies of TABLES.
146+
Cause: No TABLES package (because all functions were exported) that
147+
they could use.
148+
Change: Set up TABLES package.
149+
150+
11/4/92 [CKR]
151+
Problem: In some Lisps, e.g., MCL, the DEFSETF in DEFTABLE wasn't
152+
happening at the right time in compiled code.
153+
Cause: DEFSETF, a top-level form, was inside the LET.
154+
Change: Put DEFSETF outside the LET, in a PROGN.
155+
156+
9/30/92 [CKR]
157+
Problem: IN-TABLE-P returned multiple values instead of just T or NIL
158+
Cause: IN-TABLE-P defined as a simple call to GETHASH
159+
Change: Use (NOT (EQ flag (GETHASH ... flag)))
160+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
161+
|#

‎Code/Utilities/toList.lisp

+50
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,50 @@
1+
(in-package "COMMON-LISP-USER")
2+
;;------------------------------------------------------------------------------
3+
;;
4+
;; File: ->LIST.LISP
5+
;; Created: 2/25/93
6+
;; Author: Will Fitzgerald
7+
;;
8+
;; Description: Simple conversion utilities for strings to lists
9+
;;
10+
;;------------------------------------------------------------------------------
11+
12+
13+
(defmethod ->list ((self string) &key
14+
(start 0)
15+
(char-bag '(#\Space))
16+
(test #'(lambda (ch) (not (member ch char-bag :test 'char=))))
17+
(post-process 'identity))
18+
"Converts SELF into a list,
19+
starting at START;
20+
dividing words at boundaries defined by characters in CHAR-BAG,
21+
or at boundaries defined by TEST;
22+
each item is run through POST-PROCESS as it is created. POST-PROCESS can
23+
be destructive (eg, NSTRING-DOWNCASE)."
24+
(labels ((->list* (position)
25+
(let* ((pos (position-if-not test self :start position))
26+
(new-pos (if pos (position-if test self :start pos) nil)))
27+
(cond
28+
((and pos new-pos)
29+
(cons (funcall post-process (subseq self position pos))
30+
(->list* new-pos)))
31+
(pos (list (funcall post-process (subseq self position pos))))
32+
(t (list (funcall post-process (subseq self position))))))))
33+
34+
(let ((pos (position-if test self :start start)))
35+
(if pos (->list* pos) nil))))
36+
37+
(defmethod ->symbols ((self string) &optional (package *package*))
38+
"Converts a string into a list of symbols interned into PACKAGE, ignoring
39+
everything but alphanumerics and dashes."
40+
(->list self
41+
:post-process #'(lambda (str)
42+
(intern (nstring-upcase str) package))
43+
:test #'(lambda (ch) (or (alphanumericp ch)
44+
(char= ch #\-)))))
45+
46+
(defmethod ->symbols ((self null) &optional (package *package*))
47+
(declare (ignore package)) nil)
48+
49+
50+

0 commit comments

Comments
 (0)