From rklochkov at common-lisp.net Wed Mar 20 17:22:23 2013 From: rklochkov at common-lisp.net (rklochkov at common-lisp.net) Date: Wed, 20 Mar 2013 10:22:23 -0700 Subject: [cl-table-cvs] r3 - Message-ID: Author: rklochkov Date: Wed Mar 20 10:22:22 2013 New Revision: 3 Log: Minor fixes Modified: table.lisp test.lisp Modified: table.lisp ============================================================================== --- table.lisp Thu Feb 9 08:05:54 2012 (r2) +++ table.lisp Wed Mar 20 10:22:22 2013 (r3) @@ -60,78 +60,14 @@ (when (equal f1 f2) (equal-rows (cdr cols) row1 row2))) t)) -(eval-when (:compile-toplevel :execute) - - (defun list-of-forms? (x) - (and (consp x) (consp (car x)) - (not (eq (caar x) 'lambda)))) - - (defun sharpL-reader (stream subchar n-args) - (declare (ignore subchar)) - (let* ((form (read stream t nil t)) - (bang-vars (sort (bang-vars form) #'< :key #'bang-var-num)) - (bang-var-nums (mapcar #'bang-var-num bang-vars)) - (max-bv-num (if bang-vars - (reduce #'max bang-var-nums :initial-value 0) - 0))) - (cond - ((null n-args) - (setq n-args max-bv-num)) - ((< n-args max-bv-num) - (error "#L: digit-string ~d specifies too few arguments" n-args))) - (let* ((bvars (let ((temp nil)) - (dotimes (i n-args (nreverse temp)) - (push (make-bang-var (1+ i)) temp)))) - (args (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) - bvars)) - (ignores (set-difference bvars bang-vars)) - (decl (if ignores `(declare (ignore .,ignores)) nil)) - (body (if (list-of-forms? form) - (if decl (cons decl form) form) - (if decl (list decl form) (list form)))) - (subbed-body (sublis (pairlis bvars args) body))) - `#'(lambda ,args ,.subbed-body)))) - - (defun make-bang-var (n) - (intern (format nil "!~d" n))) - - (defun bang-vars (form) - (delete-duplicates (bang-vars-1 form '()) :test #'eq)) - - (defun bang-vars-1 (form vars) - (cond - ((consp form) - (bang-vars-1 (cdr form) - (bang-vars-1 (car form) vars))) - ((and (symbolp form) (bang-var? form)) (cons form vars)) - (t vars))) - - (defun bang-var? (sym) - (char= (char (symbol-name sym) 0) #\!)) - - (defun bang-var-num (sym) - (let ((num (read-from-string (subseq (symbol-name sym) 1)))) - (if (not (and (integerp num) (> num 0))) - (error "#L: ~a is not a valid variable specifier" sym) - num))) - - (defun enable-sharpL-reader () - (set-dispatch-macro-character #\# #\L #'sharpL-reader)) - - ;; According to CLHS, *readtable* must be rebound when compiling - ;; so we are free to reassign it to a copy and modify that copy. - (setf *readtable* (copy-readtable *readtable*)) - (enable-sharpL-reader) - - ) ; end eval-when - (defun sort! (table columns) (setf (rows table) (stable-sort (rows table) - #L(compare-rows columns #'generic-lessp - (make-row :table table :data !1) - (make-row :table table :data !2))))) + (lambda (x y) + (compare-rows columns #'generic-lessp + (make-row :table table :data x) + (make-row :table table :data y)))))) ;; (defun add-columns (sum-columns dst-row src-row) ;; (mapc (lambda (column) Modified: test.lisp ============================================================================== --- test.lisp Thu Feb 9 08:05:54 2012 (r2) +++ test.lisp Wed Mar 20 10:22:22 2013 (r3) @@ -15,8 +15,8 @@ (setf (field str2 'a) "str21a" (field str2 'b) "str21b"))) (list (field (path->row tab '(0)) 'b) - (field (path->row tab 1) 'a) - (field (path->row tab '(1 0)) 'b)) + (field (path->row tab 1) 'a) + (field (path->row tab '(1 0)) 'b)) (path->row tab '(1 0))))