Interlisp.medley/internal/test/env/Program-Support/Auto/CLISP.TEST

;;; Automatic CLISP tests.
;;; This file tests the CLISP facility through direct calls to DWIMIFY. It does not
;;; attempt to simulate typein. It's probably not very useful to run this compiled.

(do-test-group ("Programmatic CLISP tests."
                :before (progn
                          (dolist (x '(il:a il:b il:c il:d il:x il:y il:foo il:record-1))
                            (fmakunbound x))
                          (il:record il:b (il:b1 il:b2) il:b1_10 il:b2_20)
                          (il:record il:rec (il:a il:b il:c)
                            il:a_100 il:c_200 (il:subrecord il:b))
                          (warn "Defining and compiling function ~S." 'eval-with-clisp)
                          (compile-definer
                            (defun eval-with-clisp (expr-string)
                              (eval (il:dwimify
                                      (with-profile "OLD-INTERLISP-T"
                                        (read-from-string expr-string))
                                      t)))
                            :functions)
                          (warn "~&Defining and compiling macro ~S." 'special-let)
                          (compile-definer
                            (defmacro special-let (bindings &body body)
                              (let ((vars ()) (vals ()))
                                (conditions::with-collection-sites (vars vals)
                                  (dolist (binding bindings)
                                    (etypecase binding
                                      ((and symbol (not null))
                                        (conditions::collect-into vars binding)
                                        (conditions::collect-into vals nil))
                                      (cons
                                        (conditions::collect-into vars (first binding))
                                        (conditions::collect-into vals
                                          (second binding))))
                                  ) ; dolist
                                ) ; with-collection-sites
                                `(progv ',vars (list ,@vals) 
                                   (locally (declare (special ,@vars))
                                     ,@body))))
                            :functions)
                        ))

  ;; Arithmetic operators.

  (do-test "Infix +"
    (eql (special-let ((il:a 30) (il:b 10)) (eval-with-clisp "(A + B)")) 40))
  (do-test "Infix -"
    (eql (special-let ((il:a 30) (il:b 10)) (eval-with-clisp "(A - B)")) 20))
  (do-test "Infix *"
    (eql (special-let ((il:a 30) (il:b 10)) (eval-with-clisp "(A * B)")) 300))
  (do-test "Infix /"
    (eql (special-let ((il:a 30) (il:b 10)) (eval-with-clisp "(A / B)")) 3))
  (do-test "Infix ^"
    (eql (special-let ((il:a 30) (il:b 10)) (eval-with-clisp "(A ^ B)"))
         590490000000000))
  (do-test "Infix ="
    (special-let ((il:a 30) (il:b 10))
      (and (eq (eval-with-clisp "(A = A)") t)
           (eq (eval-with-clisp "(A = B)") nil))
    )
  )
  (do-test "Infix GT"
    (eql (special-let ((il:a 30) (il:b 10)) (eval-with-clisp "(A GT B)")) t))
  (do-test "Infix LT"
    (eql (special-let ((il:a 30) (il:b 10)) (eval-with-clisp "(A LT B)")) nil))
  (do-test "Infix GE"
    (eql (special-let ((il:a 30) (il:b 10) (il:c 30))
           (eval-with-clisp "(AND (A GE B) (A GE C))"))
         t))
  (do-test "Infix LE"
    (eql (special-let ((il:a 30) (il:b 10) (il:c 10))
           (eval-with-clisp "(AND (B LE A) (B LE C))"))
         t))

  ;; List extractors
  (do-test "Infix : applied to list"
    (special-let ((il:foo '(a b c d e (f g) (h j k))))
      (and (eq (eval-with-clisp "(FOO:2)") 'b)
           (eq (eval-with-clisp "(FOO:-1:-1)") 'k))
    )
  )

  (do-test "Infix :: applied to list"
    (special-let ((il:foo '(a b c d e (f g) (h j k))))
      (eq (eval-with-clisp "(FOO::3)")
          (cdddr il:foo))
    )
  )

  ;; Record extractors

  (do-test "Infix : with . applied to record"
    (eql (special-let ((il:record-1 (il:create il:rec)))
           (eval-with-clisp "(RECORD-1:REC.B.B1)"))
         10))

  ;; List construction

  (do-test "Simple list construction"
    (special-let ((il:a 1) (il:b 2) (il:c 3) (il:d 4))
      (and (equal (eval-with-clisp "(<A B C D>)") '(1 2 3 4))
           (equal (eval-with-clisp "(<A B <C>>)") '(1 2 (3))))
    ))

  (do-test "List construction with !"
    (special-let ((il:a 1) (il:b 2) (il:c 3) (il:x '(5 4)) (il:y '(3 2)))
      (and (equal (eval-with-clisp "(<A B !C>)") '(1 2 . 3))
           (equal (eval-with-clisp "(<!X!Y A>)") '(5 4 3 2 1)))
    ))

  (do-test "List construction with !!"
    (and
      (special-let ((il:a (list 1 2 3)) (il:b (list 4 5 6)))
        (let ((result (eval-with-clisp "(<!!A B>)")))
          (and (equal result '(1 2 3 (4 5 6)))
               (eq result il:a)
               (tailp result il:a)
               (eq (nth 3 result) il:b))
        ))
      (special-let ((il:a (list 1 2)) (il:b (list 3 4)) (il:c (list 5 6)))
        (let ((result (eval-with-clisp "(<!!A !B !C>)")))
          (and (equal result '(1 2 3 4 5 6))
               (eq result il:a)
               (not (eq (nthcdr 2 result) il:b))
               (eq (nthcdr 4 result) il:c))
        ))
    ))

  ;; Structure modifiers

  (do-test "Simple _"
    (special-let (il:a)
      (and (eval-with-clisp "(A_T)") il:a)))

  (do-test "_ with : in lists"
    (special-let ((il:x (list 1 2 3 4 5)))
      (let* ((old-x il:x) (result (eval-with-clisp "(X:2_T)")))
        (and (equal result '(t 3 4 5))
             (equal il:x '(1 t 3 4 5))
             (eq result (cdr old-x))
             (eq il:x old-x)
             (tailp il:x old-x))
        (and (equal (setq result (eval-with-clisp "(X:-2_NIL)")) '(nil 5))
             (equal il:x '(1 t 3 nil 5))
             (eq result (nthcdr 3 old-x))
             (eq il:x old-x)
             (tailp il:x old-x))
      )
    ))

  (do-test "_ with :: in lists"
    (special-let ((il:x (list 1 2 3)))
      (let* ((old-x il:x) (result (eval-with-clisp "(X::1_NIL)")))
        (and (equal result '(1))
             (equal il:x '(1))
             (eq old-x il:x)
             (tailp old-x il:x)))
    ))

  (do-test "_ with : in records"
    (special-let ((il:myrec (il:create il:rec)))
     (let ((old-rec il:myrec))
        (and (eq (eval-with-clisp "(MYREC:REC.B.B1_T)") t)
             (equal il:myrec '(100 (t 20) 200))
             (eq old-rec il:myrec)
             (tailp old-rec il:myrec)
             (tailp (second old-rec) (second il:myrec))))
    ))

  (do-test "Left v. right precedence of _"
    (special-let ((il:a 1) (il:b 2) (il:c 3))
        (and (eql (eval-with-clisp "(A+B_C)") 4)
             (eql il:a 1) (eql il:b 3) (eql il:c 3)))
    (special-let ((il:a 1) (il:b 2) (il:c 3))
        (and (eql (eval-with-clisp "(A_B+C)") 5)
             (eql il:a 5) (eql il:b 2) (eql il:c 3)))
  )

  ;; Quoting

  (do-test "Quote operator"
    (special-let ((il:a 'il:b) (il:c 'il:don\'t))
      (and (eq (eval-with-clisp "(A='B)") t)
           (eq (eval-with-clisp "(C='DON'T)") t))))

  ;; Not

  (do-test "NOT operator"
    (special-let ((il:a 20) (il:b 10))
      (and (eval-with-clisp "(EQ ~NIL T)") (eval-with-clisp "(A ~LE B)"))))

  ;; Random operator precedence
  
  (do-test "CLISP operator precedence"
    (every #'(lambda (pair) (eql (eval-with-clisp (car pair)) (cdr pair)))
      '(("(1 + 3 * 2)" . 7)
        ("(10 - 4 ^ 2)" . -6)
        ("(1 + 3 ~= 5)" . t)
        ("(2 * 3 ^ 3)" . 54)
        ("(2 * 2 = 4)" . t)
        ("(4 - 1 LT 1 + 2 * 3)" . t)
        ("(~NIL AND T)" . t))
    ))

)