macros.lisp

   1
   2 (in-package :lalr-parser-generator)
   3
   4 ;;; It's too bad PSXHASH isn't available everywhere.
   5
   6 (defconstant +simple-hash-multiplier+ 31
   7   "Multiplication constant suggested by Kernighan and Pike for simple
   8 hashing applications.")
   9
  10 (defun simple-checksum (x)
  11   "Provides an SXHASH-style checksum of X, but also sloppily handles
  12 arrays and hash tables, like SBCL's PSXHASH.  However, this checksum
  13 was only designed for use in comparing relatively similar structures,
  14 so it shouldn't be used as a general replacement for something like
  15 PSXHASH."
  16   (typecase x
  17     (array (simple-array-sum x))
  18     (hash-table (simple-hash-sum x))
  19     (t (sxhash x))))
  20
  21 (defun simple-hash-sum (hash-table)
  22   (loop for x being each hash-value of hash-table
  23         summing (simple-checksum x)))
  24
  25 (defun simple-array-sum (array)
  26   (loop for x across array
  27         summing (simple-checksum x)))
  28
  29 ;;; Note: there are various ways we can make this much more efficient,
  30 ;;; but I don't think it really matters that much.
  31 (defmacro do-until-unchanged1 (var &body body)
  32   "Loop BODY until VAR doesn't change (according to EQUALP) between
  33 iterations."
  34   (let ((last-time (gensym)))
  35     `(let ((,last-time))
  36       (tagbody
  37        top
  38          (setf ,last-time (simple-checksum ,var))
  39          ,@body
  40          (unless (equal ,last-time (simple-checksum ,var))
  41            (go top)))
  42       ,var)))
  43
  44 (defmacro do-until-unchanged (vars &body body)
  45   "Loop BODY until each variable in VARS doesn't change (according to
  46 EQUALP) between iterations."
  47   (if vars
  48       `(do-until-unchanged1 ,(car vars)
  49         (do-until-unchanged ,(cdr vars)
  50           ,@body))
  51       `(progn ,@body)))
  52
  53
  54 (defmacro dovector ((var vector) &body body)
  55   "Iterate VAR across VECTOR."
  56   `(loop for ,var across ,vector
  57          do (progn ,@body)))
  58
  59
  60 (defmacro do-for-each-item ((var set) &body body)
  61   "Iterate VAR across the item-set SET."
  62   `(dovector (,var ,set) ,@body))
  63
  64 ;;; grammar traversal
  65
  66 (defmacro do-for-each-production ((lhs rhs grammar) &body body)
  67   "For each production in GRAMMAR, BODY is called with LHS and RHS
  68 bound to the left-hand side and right-hand side (in the form of a list
  69 of tokens) of the grammar rule."
  70   (let ((value (gensym)))
  71     `(maphash (lambda (,lhs ,value)
  72                 (declare (ignorable ,lhs ,value))
  73                 (dolist (,rhs ,value)
  74                   ,@body))
  75       ,grammar)))
  76
  77 (defmacro do-for-each-terminal ((var grammar) &body body)
  78   "Do BODY for each terminal symbol referenced in GRAMMAR."
  79   (let ((list (gensym))
  80         (unused (gensym)))
  81     `(do-for-each-production (,unused ,list ,grammar)
  82       (dolist (,var ,list)
  83         (when (not (non-terminal-p ,var))
  84           ,@body)))))
  85