From 562be5474c2f7510f8deced8aaaa74c8ec68b8ae Mon Sep 17 00:00:00 2001
From: Leonardo Varuzza <varuzza@gmail.com>
Date: Sun, 7 Oct 2007 02:29:24 -0300
Subject: [PATCH] Add hash reader-macro Add print-head function

---
 lambda-utils/hash.lisp | 39 +++++++++++++++++++++++++++++++++++++++
 lambda-utils/head.lisp | 41 +++++++++++++++++++++++++++++++++++++++++
 2 files changed, 80 insertions(+)
 create mode 100644 lambda-utils/hash.lisp
 create mode 100644 lambda-utils/head.lisp

diff --git a/lambda-utils/hash.lisp b/lambda-utils/hash.lisp
new file mode 100644
index 0000000..fdbc70a
--- /dev/null
+++ b/lambda-utils/hash.lisp
@@ -0,0 +1,39 @@
+(in-package :cl-user)
+
+(set-dispatch-macro-character #\# #\[                 ; Dispatch on the sequence #[ or #arg[
+  #'(lambda (stream subchar arg)                      ; Anonymous function to read/parse it
+      (declare (ignore subchar))                      ; We already know it is [
+      (let ((list (read-delimited-list #\] stream t)) ; Read in the rest of the list, up to ]
+	    (keys '())                                ; Empty list, filled below
+	    (values '())                              ; Empty list, filled below
+            (hashtab (gensym)))                       ; Gensym name for the hashtab so the values can't clobber it
+
+	(do ((key list (cddr key))                    ; Loop for keys being sublists, skipping 2 ahead each time
+	     (value (cdr list) (cddr value)))         ; ...and for values being sublists, skipping 2 ahead
+	    ((null key))                              ; Terminate loop when out of keys
+	  (push (car key) keys)                       ; Assemble the keys in reverse order
+	  (push (car value) values))                  ; Assemble value forms in reverse order
+	(setf keys (nreverse keys))                   ; Reverse the keys - push/nreverse is the fast way to do this
+	(setf values (nreverse values))               ; Reverse the value forms
+
+        ;;; The next 8 lines are the code template
+	`(let ((,hashtab ,(if arg                 ; If there is an argument given, make the hash-table that size
+			      `(make-hash-table :test #'equalp :size ,arg)
+			      '(make-hash-table :test #'equalp))))        ; Otherwise use the default size
+	   ,@(mapcar #'(lambda (key value)                                ; Map this function across keys/values
+			 `(setf (gethash ',key ,hashtab) ,value))         ; Add the item to the hash
+		     keys
+		     values)
+	   ,hashtab))))                                                   ; Return the generated hashtab
+
+(set-macro-character #\[                                                  ; Dispatch on [
+  #'(lambda (stream char)                                                 ; Anonymous function to read/parse
+      (declare (ignore char))                                             ; We already know that it's [
+      (let ((list (read-delimited-list #\] stream t)))                    ; Read up through ]
+	(when (/= (length list) 2)                                        ; Make sure that we have two elements
+	  (error "Invalid number of arguments to []"))
+	(when (not (symbolp (cadr list)))                                 ; Make sure that the key is a symbol
+	  (error "Key must be a symbol"))
+	`(gethash ',(cadr list) ,(car list)))))                           ; The actual code template
+
+(set-macro-character #\] (get-macro-character #\)))                       ; This is a helper for read-delimited-list
diff --git a/lambda-utils/head.lisp b/lambda-utils/head.lisp
new file mode 100644
index 0000000..951bbd6
--- /dev/null
+++ b/lambda-utils/head.lisp
@@ -0,0 +1,41 @@
+(in-package :lambda-utils)
+
+(defconstant +default-print-head-lines+ 5 "Default number of lines printed by print-head")
+
+(defgeneric print-head (obj &optional n)
+  (:documentation "Print the first n items of the obj"))
+
+(defmethod print-head ((filename string) &optional (n +default-print-head-lines+))
+  (print-file-head filename n))
+
+(defmethod print-head ((filename pathname) &optional (n +default-print-head-lines+))
+  (print-file-head filename n))
+
+(defmethod print-head ((filename string) &optional (n +default-print-head-lines+))
+  (print-file-head filename n))
+
+
+(defmethod print-head ((hash hash-table) &optional (n +default-print-head-lines+))
+  (loop for k being the hash-key using (hash-value v) of hash 
+        for i from 1 to n
+        do (format t "~s =>~T~s~%" k v))
+  (when (>= n (hash-table-count hash)) 
+    (format t "...~%")))
+
+
+
+(defmethod print-head ((vec simple-vector) &optional (n +default-print-head-lines+))
+  (let ((dim (array-dimension vec 0)))
+    (loop for i from 0 to (1- (min n dim))
+       do (format t "~a~%" (aref vec i)))
+    (when (> dim n) (format t "...~%"))))
+  
+  
+(defun print-file-head (filename &optional (n +default-print-head-lines+))
+  (with-open-file (file filename :direction :input)
+    (loop for line = (read-line file nil :eof)
+	  for i from 1 to n
+	  while line
+	  do (format t "~a~%" line))))
+    
+  
\ No newline at end of file
-- 
2.11.4.GIT