LISP9

Example Programs

Reverse and concatenate lists

(defun (reconc a b)
  (if (null a)
      b
      (reconc (cdr a)
              (cons (car a) b))))

LET* Macro

(defmac (let* bs x . xs)
  (if (null bs)
      @(let () ,x . ,xs)
      @(let (,(car bs))
         (let* ,(cdr bs) ,x . ,xs))))

Read a line from an I/O-port

(defun (readln . p)
  (let loop ((c (apply readc p))
             (a nil))
    (cond ((eofp c)
            (if (null a)
                c
                (liststr (nrever a))))
          ((c= #\nl c)
            (liststr (nrever a)))
          (else
            (loop (apply readc p)
                  (cons c a))))))

COND Macro

(defmac (cond . cs)
  (cond ((null cs) nil)
        ((null (cdar cs))
          @(if* ,(caar cs)
                (cond . ,(cdr cs))))
        ((eq '=> (cadar cs))
          (let ((g (gensym)))
            @(let ((,g ,(caar cs)))
               (if ,g (,(caddr (car cs)) ,g)
                   (cond . ,(cdr cs))))))
        ((eq 'else (caar cs))
          @(prog . ,(cdar cs)))
        ((null (cdr cs))
          @(if ,(caar cs)
               (prog . ,(cdar cs))))
        (else
          @(if ,(caar cs)
               (prog . ,(cdar cs))
               (cond . ,(cdr cs))))))

Structural equality test (EQUAL)

(defun (equal a b)
  (defun (equvec a b)
    (and (= (vsize a) (vsize b))
         (let loop ((i (- (vsize a) 1)))
           (cond ((< i 0))
                 ((equal (vref a i) (vref b i))
                   (loop (- i 1)))
                 (else nil)))))
  (cond ((eq a b))
        ((and (pair a)
              (pair b)
              (equal (car a) (car b))
              (equal (cdr a) (cdr b))))
        ((and (stringp a)
              (stringp b)
              (s= a b)))
        ((and (vectorp a)
              (vectorp b)
              (equvec a b)))
        (else (eqv a b))))

Hash Table

(defun (htsize n)
  (cond ((<= n 101)    101)
        ((<= n 199)    199)
        ((<= n 499)    499)
        ((<= n 997)    997)
        ((<= n 1997)  1997)
        ((<= n 4999)  4999)
        ((<= n 9973)  9973)
        (else        19997)))

(defun (mkht z)
  (cons 0 (mkvec (htsize z) nil)))

(defun (hash x k)
  (let* ((s  (symname x))
         (ks (ssize s)))
    (let loop ((h 0)
               (i 0))
      (if (>= i ks)
          h
          (loop (rem (+ (* 31 h) (charval (sref s i)))
                     k)
                (+ 1 i))))))

(defun (htref h k)
  (let ((i (hash k (vsize (cdr h)))))
    (cond ((assq k (vref (cdr h) i))
            => cdr)
          (else
            nil))))

(defun (htgrow h)
  (let* ((k  (htsize (+ 1 (vsize (cdr h)))))
         (h* (mkht k)))
    (let loop ((i 0)
               (k (vsize (cdr h))))
      (cond ((>= i k)
              (setcar h (car h*))
              (setcdr h (cdr h*)))
            (else
              (foreach (lambda (x)
                         (htset h* (car x) (cdr x)))
                       (vector-ref (cdr h) i))
              (loop (+ 1 i) k))))))

(defun (htset h k v)
  (if (> (car h) (vsize (cdr h)))
      (htgrow h))
  (let ((i (hash k (vsize (cdr h)))))
    (cond ((assq k (vref (cdr h) i))
            => (lambda (x)
                 (setcdr x v)))
          (else
            (setcar h (+ 1 (car h)))
            (vset (cdr h)
                  i
                  (cons (cons k v)
                        (vref (cdr h) i)))))))

contact  |  privacy