;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - NFS Share File - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; LaHaShem HaAretz U'Mloah

;;; Screamer
;;; A portable efficient implementation of nondeterministic CommonLisp

;;; Written by:
;;; Jeffrey Mark Siskind
;;; MIT Artificial Intelligence Laboratory
;;; 545 Technology Square Room NE43-800b
;;; Cambridge MA 02139
;;; Qobi@AI.MIT.EDU
;;; 617/253-5659
;;; and:
;;; David Allen McAllester
;;; MIT Artificial Intelligence Laboratory
;;; 545 Technology Square Room NE43-412
;;; Cambridge MA 02139
;;; DAM@AI.MIT.EDU
;;; 617/253-6599

;;; To obtain a copy of the Screamer manual (called `Screaming Yellow Zonkers')
;;; send mail to Qobi@AI.MIT.EDU
;;; Report *ALL* bugs to Bug-Screamer@AI.MIT.EDU
;;; Send a message to Info-Screamer-Request@AI.MIT.EDU to be put on the
;;; Info-Screamer@AI.MIT.EDU mailing list.

(in-package 'user :use '(lisp))

(proclaim '(declaration arglist magic))

;;; Machines Supported or Not Supported
;;;  1. Genera 8.0.1 on Symbolics 36xx and Ivory: Kashket claims without
;;;     substantiation that interpreter fails. No other known bugs.
;;;  2. Lucid 3.0.2 on Sun-3, SPARC and DECstation5100: No known bugs.
;;;  3. Explorer I & II and microExplorer: COND fails. No other known bugs.
;;;  4. Franz (unknown version and machine): COND fails compiled but works
;;;     interpreted. No other known bugs.
;;;  5. AKCL 1.492 on SPARC: No known bugs.

;;; TTMTTD
;;;  1. Manual.
;;;  2. Submit paper to Lisp and Functional Programming Conference.
;;;  3. Should have way of having a stream of values.
;;;  4. There are some possible optimizations to LOCALLY-SETF, PROGN,
;;;     SETQ and IF when you know that the result is not needed and the form is
;;;     only being evaluated for side effects.
;;;  5. Could optimize CPS conversion of special forms if no subforms are
;;;     nondeterministic.
;;;  6. Kashket's constraint additions Fall90-158.
;;;  7. Change SYS:DOWNWARD-FUNCTION to DYNAMIC-EXTENT.

;;; Bugs to fix
;;;  1. VECTOR-POP bug Summer90-577.
;;;  2. Ellen Spertus's bug Summer90-656.
;;;  3. Sameer's bug Fall90-50,83.
;;;  4. Needs work to signal an error if FAIL or LOCALLY-SETF are called in a
;;;     deterministic context which is not nested in a choice point.
;;;  5. (LOCALLY-SETF X e) will signal an error of X is unbound because it
;;;     needs to trail the previous value of X and it has none.
;;;  6. May fail when lambda-list or its sublists are not proper, non-circular
;;;     lists.
;;;  7. APPLY-NONDETERMINISTIC conses.
;;;  8. Lucid gives a compiler warning about MEMBER-OF-VECTOR-NONDETERMINISTIC
;;;     not being defined.
;;;  9. Not sure that definitions, declarations and documentation strings
;;;     work in nondeterministic contexts.
;;; 10. An occurance of EITHER in a deterministic context nested in a
;;;     nondeterministic context will give only a run time error message.
;;; 11. A MAP-VALUES in a nondeterministic context will cause an error.

;;; Limitations
;;;  1. Overly stringent restriction on forms.
;;;  2. Does not handle SETF methods with multiple values for LOCALLY-SETF.
;;;  3. The ARGLIST hack is not portable.
;;;     c-sh-A on FUNCALL-NONDETERMINISTIC and APPLY-NONDETERMINISTIC and user
;;;     defined nondeterministic functions will return the wrong results on
;;;     machines that don't support the ARGLIST hack since it will have a flag
;;;     as the first argument and a continuation as the second argument.
;;;  4. Doesn't handle most Common Lisp special forms.
;;;     Currently handle:
;;;       QUOTE
;;;       FUNCTION
;;;       PROGN
;;;       SETQ
;;;       IF
;;;       LET
;;;       LET*
;;;     Maybe will someday handle:
;;;       CATCH
;;;       THROW
;;;       BLOCK
;;;       RETURN-FROM
;;;       TAGBODY
;;;       GO
;;;       UNWIND-PROTECT
;;;       MULTIPLE-VALUE-CALL
;;;       MULTIPLE-VALUE-PROG1
;;;     Probably will never handle:
;;;       COMPILER-LET
;;;       DECLARE
;;;       EVAL-WHEN
;;;       FLET
;;;       GENERIC-FLET
;;;       GENERIC-LABELS
;;;       LABELS
;;;       LOAD-TIME-VALUE
;;;       LOCALLY
;;;       MACROLET
;;;       PROGV
;;;       SYMBOL-MACROLET
;;;       THE
;;;       WITH-ADDED-METHODS

(defmacro DEFUN-COMPILE-TIME (function-spec lambda-list &body body)
  `(eval-when (compile load eval) (defun ,function-spec ,lambda-list ,@body)))

(defmacro DEFMACRO-COMPILE-TIME (function-spec lambda-list &body body)
  `(eval-when (compile load eval)
     (defmacro ,function-spec ,lambda-list ,@body)))

(defmacro DEFVAR-COMPILE-TIME (name &optional initial-value documentation)
  `(eval-when (compile load eval)
     (defvar ,name ,initial-value ,documentation)))

(defun-compile-time SCREAMER-ERROR (header trailer &rest args)
  (apply
   #'error
   (concatenate
    'string
    header
    "There are seven types of nondeterministic contexts: the body of a~%~
     function defined with DEFUN-NONDETERMINISTIC, the body of a~%~
     LAMBDA-NONDETERMINISTIC, the second argument of a call to the~%~
     MAP-VALUES macro, the first argument of a call to the ONE-VALUE macro,~%~
     the body of a call to the ALL-VALUES macro, the second argument of a~%~
     call to the NTH-VALUE macro and the body of a call to the PRINT-VALUES~%~
     macro. In particular, the body of a LAMBDA expression nested in a~%~
     nondeterministic context is a deterministic context. Likewise, the~%~
     default forms of &OPTIONAL and &KEY arguments and the initialization~%~
     forms of &AUX variables, are always deterministic contexts even though~%~
     they may appear in a DEFUN-NONDETERMINISTIC or LAMBDA-NONDETERMINISTIC."
    trailer)
   args))

(defvar-compile-time *NONDETERMINISM-FLAG* '*nondeterminism-flag*)

(defvar-compile-time *NONDETERMINISTIC-FUNCTIONS* '()
 "The list of all nondeterministic functions")

(defvar-compile-time *TRAIL* (make-array 0 :adjustable t :fill-pointer 0)
 "The trail")

(defmacro CHOICE-POINT (form)
  `(let ((trail-pointer (fill-pointer *trail*)))
     (catch 'fail
       (unwind-protect ,form
         (loop (when (= (fill-pointer *trail*) trail-pointer) (return))
               (funcall (vector-pop *trail*)))))))

(defun-compile-time IS-MAGIC-DECLARATION? (form)
  (equal form
         '(declare (#+symbolics sys:downward-function #-symbolics magic))))

(defun-compile-time POSSIBLY-BETA-CONVERT-FUNCALL (continuation form)
  (if (and (consp continuation)
           (eq (first continuation) 'function)
           (eql (list-length continuation) 2)
           (consp (second continuation))
           (eq (first (second continuation)) 'lambda)
           (not (null (list-length (second continuation))))
           (>= (list-length (second continuation)) 3)
           (consp (second (second continuation)))
           (eql (list-length (second (second continuation))) 1)
           (symbolp (first (second (second continuation))))
           (is-magic-declaration? (third (second continuation))))
      ;; The above checks that CONTINUATION is of the form:
      ;;   #'(lambda (X) (declare (magic)) ...) where X is a symbol
      ;; note: the subst version of beta conversion is only valid when
      ;;       a. it gets substituted only once
      ;;       b. what gets substituted in has no side effects
      ;;       since I don't know how to check the later, for now the subst
      ;;       form of beta conversion has to be performed only when what
      ;;       gets substituted is not a cons irrespective of whether it is
      ;;       substituted more than once.
      (if (consp form)
          `(let ((,(first (second (second continuation))) ,form))
             ,@(rest (rest (rest (second continuation)))))
          (subst form
                 (first (second (second continuation)))
                 (case (list-length (second continuation))
                   (3 ''nil)
                   (4 (fourth (second continuation)))
                   (otherwise
                    `(progn ,@(rest (rest (rest (second continuation)))))))
                 :test #'eq))
      `(funcall ,continuation ,form)))

(defun-compile-time CPS-CONVERT-FUNCTION-NAME (function-name)
  (intern (format nil "~A-NONDETERMINISTIC" (string function-name))
          (symbol-package function-name)))

(defun-compile-time CPS-CONVERT-EITHER (forms continuation environment)
  (case (length forms)
    (0 '(fail))
    (1 (cps-convert (first forms) continuation environment))
    (otherwise
     (if (symbolp continuation)
         `(progn
            ,@(mapcar #'(lambda (form)
                          `(choice-point
                            ,(cps-convert form continuation environment)))
                      (reverse (rest (reverse forms))))
            ,(cps-convert (first (last forms)) continuation environment))
         (let ((c (gensym "CONTINUATION-")))
           `(let ((,c ,continuation))
              ,c                                ;ignore
              ,@(mapcar #'(lambda (form)
                            `(choice-point ,(cps-convert form c environment)))
                        (reverse (rest (reverse forms))))
              ,(cps-convert (first (last forms)) c environment)))))))

(defun-compile-time CPS-CONVERT-LOCALLY-SETF
                    (arguments continuation environment)
  ;; note: Could optimize away LOCALLY-SETF CPS conversion if no subform of
  ;;       LOCALLY-SETF is nondeterministic.
  ;; note: There are some possible optimizations to LOCALLY-SETF when you know
  ;;       that the result is not needed and the form is only being evaluated
  ;;       for side effects.
  (if (null arguments)
      (possibly-beta-convert-funcall continuation 'nil)
      (let ((d (gensym "DUMMY-")))
        (multiple-value-bind (vars vals stores store-form access-form)
            (get-setf-method (first arguments))
          (cps-convert
           (second arguments)
           `#'(lambda (,(first stores))
                (declare (#+symbolics sys:downward-function #-symbolics magic))
                (let* (,@(mapcar #'list vars vals) (,d ,access-form))
                  (unwind-protect
                      ,(if (null (rest (rest arguments)))
                           (possibly-beta-convert-funcall
                            continuation store-form)
                           `(progn ,store-form
                                   ,(cps-convert-locally-setf
                                     (rest (rest arguments))
                                     continuation environment)))
                    ,(subst d (first stores) store-form))))
           environment)))))

(defun-compile-time CPS-CONVERT-CALL (function-name
                                      arguments
                                      dummy-arguments
                                      continuation
                                      environment)
  (if (null arguments)
      `(,(cps-convert-function-name function-name)
        ,continuation
        ,@(reverse dummy-arguments))
      (let ((dummy-argument (gensym "DUMMY-")))
        (cps-convert
         (first arguments)
         `#'(lambda (,dummy-argument)
              (declare (#+symbolics sys:downward-function #-symbolics magic))
              ,(cps-convert-call
                function-name
                (rest arguments)
                (cons dummy-argument dummy-arguments)
                continuation
                environment))
         environment))))

(defun-compile-time CPS-NON-CONVERT-CALL (function-name
                                          arguments
                                          dummy-arguments
                                          continuation
                                          environment)
  (if (null arguments)
      (possibly-beta-convert-funcall
       continuation `(,function-name ,@(reverse dummy-arguments)))
      (let ((dummy-argument (gensym "DUMMY-")))
        (cps-convert
         (first arguments)
         `#'(lambda (,dummy-argument)
              (declare (#+symbolics sys:downward-function #-symbolics magic))
              ,(cps-non-convert-call
                function-name
                (rest arguments)
                (cons dummy-argument dummy-arguments)
                continuation
                environment))
         environment))))

(defun-compile-time CPS-CONVERT-PROGN (arguments continuation environment)
  ;; note: Could optimize away PROGN CPS conversion if no subform of PROGN is
  ;;       nondeterministic.
  ;; note: There are some possible optimizations to PROGN when you know
  ;;       that the result is not needed and the form is only being evaluated
  ;;       for side effects.
  (cond ((null arguments)
         (possibly-beta-convert-funcall continuation 'nil))
        ((null (rest arguments))
         (cps-convert (first arguments) continuation environment))
        (t (let ((dummy-argument (gensym "DUMMY-")))
             (cps-convert
              (first arguments)
              `#'(lambda (,dummy-argument)
                   (declare (#+symbolics sys:downward-function
                             #-symbolics magic))
                   ,dummy-argument
                   ,(cps-convert-progn
                     (rest arguments) continuation environment))
              environment)))))

(defun-compile-time CPS-CONVERT-SETQ (arguments continuation environment)
  ;; note: Could optimize away SETQ CPS conversion if no subform of SETQ is
  ;;       nondeterministic.
  ;; note: There are some possible optimizations to SETQ when you know
  ;;       that the result is not needed and the form is only being evaluated
  ;;       for side effects.
  (if (null arguments)
      (possibly-beta-convert-funcall continuation 'nil)
      (let ((dummy-argument (gensym "DUMMY-")))
        (cps-convert
         (second arguments)
         `#'(lambda (,dummy-argument)
              (declare (#+symbolics sys:downward-function #-symbolics magic))
              ,(if (null (rest (rest arguments)))
                   (possibly-beta-convert-funcall
                    continuation `(setq ,(first arguments) ,dummy-argument))
                   `(progn (setq ,(first arguments) ,dummy-argument)
                           ,(cps-convert-setq (rest (rest arguments))
                                              continuation
                                              environment))))
         environment))))

(defun-compile-time CPS-CONVERT-IF
                    (antecedent consequent alternate continuation environment)
  ;; note: Could optimize away IF CPS conversion if no subform of IF is
  ;;       nondeterministic.
  ;; note: There are some possible optimizations to IF when you know
  ;;       that the result is not needed and the form is only being evaluated
  ;;       for side effects.
  (let ((dummy-argument (gensym "DUMMY-")))
    (if (symbolp continuation)
        (cps-convert
         antecedent
         `#'(lambda (,dummy-argument)
              (declare (#+symbolics sys:downward-function #-symbolics magic))
              (if ,dummy-argument
                  ,(cps-convert consequent continuation environment)
                  ,(cps-convert alternate continuation environment)))
         environment)
        (let ((c (gensym "CONTINUATION-")))
          `(let ((,c ,continuation))
             ,c                                 ;ignore
             ,(cps-convert
               antecedent
               `#'(lambda (,dummy-argument)
                    (declare (#+symbolics sys:downward-function
                              #-symbolics magic))
                    (if ,dummy-argument
                        ,(cps-convert consequent c environment)
                        ,(cps-convert alternate c environment)))
               environment))))))

(defun-compile-time CPS-CONVERT-LET (bindings
                                     body
                                     continuation
                                     environment
                                     &optional new-bindings)
  ;; note: Could optimize away LET CPS conversion if no subform of LET is
  ;;       nondeterministic.
  (if (null bindings)
      `(let ,new-bindings ,(cps-convert body continuation environment))
      (let* ((binding (first bindings))
             (binding-variable
              (if (symbolp binding) binding (first binding)))
             (binding-form
              (if (and (consp binding) (eql (list-length binding) 2))
                  (second binding)
                  ''nil))
             (dummy-argument (gensym "DUMMY-")))
        (cps-convert
         binding-form
         `#'(lambda (,dummy-argument)
              (declare (#+symbolics sys:downward-function #-symbolics magic))
              ,(cps-convert-let (rest bindings)
                                body
                                continuation
                                environment
                                (cons (list binding-variable dummy-argument)
                                      new-bindings)))
         environment))))

(defun-compile-time CPS-CONVERT-LET* (bindings body continuation environment)
  ;; note: Could optimize away LET* CPS conversion if no subform of LET* is
  ;;       nondeterministic.
  (if (null bindings)
      (cps-convert body continuation environment)
      (let* ((binding (first bindings))
             (binding-variable
              (if (symbolp binding) binding (first binding)))
             (binding-form
              (if (and (consp binding) (eql (list-length binding) 2))
                  (second binding)
                  ''nil)))
        (cps-convert
         binding-form
         `#'(lambda (,binding-variable)
              (declare (#+symbolics sys:downward-function #-symbolics magic))
              ,(cps-convert-let*
                (rest bindings) body continuation environment))
         environment))))

(defun-compile-time CPS-CONVERT-LAMBDA-NONDETERMINISTIC
                    (lambda-list body environment)
  (let ((continuation (gensym "CONTINUATION-"))
        (arguments (gensym "ARGUMENTS-")))
    `#'(lambda (&rest ,arguments)
         ;; note: really (,flag ,continuation ,@lambda-list)
         (declare (arglist ,@lambda-list))
         (if (and (consp ,arguments)
                  (eq (first ,arguments) *nondeterminism-flag*))
             (apply #'(lambda (,continuation ,@lambda-list)
                        ,continuation           ;ignore
                        ,(cps-convert-progn body continuation environment))
                    (rest ,arguments))
             (error "You attempted to call a LAMBDA-NONDETERMINISTIC~%~
                     expression either directly or indirectly via a~%~
                     deterministic FUNCALL or APPLY. You must use~%~
                     FUNCALL-NONDETERMINISTIC or APPLY-NONDETERMINISTIC~%~
                     instead.")))))

(defun-compile-time CPS-CONVERT (form continuation environment)
  (if (consp form)
      (cond
       ;; note: These three restrictions are safe but somewhat too stringent.
       ((null (list-length form)) (error "Form ~A is circular" form))
       ((not (null (cdr (last form)))) (error "Form ~A is improper" form))
       ((not (symbolp (first form)))
        (cond ((and (listp (first form))
                    (not (null (list-length (first form))))
                    (>= (list-length (first form)) 2)
                    (eq (first (first form)) 'lambda)
                    (listp (second (first form))))
               (if (not (every #'(lambda (argument)
                                   (and (symbolp argument)
                                        (not (member argument
                                                     lambda-list-keywords
                                                     :test #'eq))))
                               (second (first form))))
                   (error "Cannot (currently) handle a form ~A whose CAR is~%~
                           a LAMBDA expression with lambda list~%~
                           keywords or arguments that are not symbols"
                          form))
               (if (/= (length (second (first form))) (length (rest form)))
                   (error "The form ~A has a CAR which is a LAMBDA~%~
                           expression which takes a different number of~%~
                           arguments than it is called with"
                          form))
               (cps-convert-let
                (mapcar #'list (second (first form)) (rest form))
                (cond
                 ((null (rest (rest (first form)))) ''nil)
                 ((null (rest (rest (rest (first form)))))
                  (third (first form)))
                 (t `(progn ,@(rest (rest (first form))))))
                continuation
                environment))
              (t (error "CAR of form ~A is neither a symbol nor a~%~
                         valid LAMBDA expression"
                        form))))
       ((eq (first form) 'either)
        (cps-convert-either (rest form) continuation environment))
       ((eq (first form) 'fail)
        (if (not (eql (list-length form) 1))
            (error "FAIL does not take any arguments: ~A" form))
        (cps-convert-either '() continuation environment))
       ((eq (first form) 'locally-setf)
        (if (oddp (length (rest form)))
            (error "Odd number of arguments to LOCALLY-SETF: ~A" form))
        (cps-convert-locally-setf (rest form) continuation environment))
       (#-allegro
	(macro-function (first form))
	#+allegro
	(nth-value 1 (macroexpand-1 form))
        (let ((*macroexpand-hook* #'funcall))
          (cps-convert
           (macroexpand form environment) continuation environment)))
       ((special-form-p (first form))
        (case (first form)
          (quote
           (if (not (eql (list-length form) 2))
               (error "QUOTE must take one argument: ~A" form))
           (possibly-beta-convert-funcall continuation form))
          (function
           (if (not (eql (list-length form) 2))
               (error "FUNCTION must take one argument: ~A" form))
           (if (and (consp (second form))
                    (eq (first (second form)) 'lambda-nondeterministic))
               (if (and (not (null (list-length (second form))))
                        (>= (list-length (second form)) 2)
                        (listp (second (second form))))
                   (possibly-beta-convert-funcall
                    continuation
                    (cps-convert-lambda-nondeterministic
                     (second (second form))
                     (rest (rest (second form)))
                     environment))
                   (error "Invalid syntax for LAMBDA-NONDETERMINISTIC: ~A"
                          form))
               (possibly-beta-convert-funcall continuation form)))
          (progn (cps-convert-progn (rest form) continuation environment))
          (setq
           (if (oddp (length (rest form)))
               (error "Odd number of arguments to SETQ: ~A" form))
           (cps-convert-setq (rest form) continuation environment))
          (if
           (if (not (or (eql (list-length form) 3) (eql (list-length form) 4)))
               (error "IF must take two or three arguments: ~A" form))
           (cps-convert-if (second form)
                           (third form)
                           (if (null (rest (rest (rest form))))
                               'nil
                               (fourth form))
                           continuation
                           environment))
          (let
           (if (null (rest form))
            (error "LET must have BINDINGS: ~A" form))
            (if (or (not (listp (second form)))
                    (some #'(lambda (binding)
                              (not (or (symbolp binding)
                                       (and (consp binding)
                                            (or (eql (list-length binding) 1)
                                                (eql (list-length binding) 2))
                                            (symbolp (first binding))))))
                          (second form)))
                (error "Invalid BINDINGS for LET: ~A" form))
            (cps-convert-let
             (second form)
             (cond ((null (rest (rest form))) ''nil)
                   ((null (rest (rest (rest form)))) (third form))
                   (t `(progn ,@(rest (rest form)))))
             continuation
             environment))
          (let*
           (if (null (rest form))
            (error "LET* must have BINDINGS: ~A" form))
            (if (or (not (listp (second form)))
                    (some #'(lambda (binding)
                              (not (or (symbolp binding)
                                       (and (consp binding)
                                            (or (eql (list-length binding) 1)
                                                (eql (list-length binding) 2))
                                            (symbolp (first binding))))))
                          (second form)))
                (error "Invalid BINDINGS for LET*: ~A" form))
            (cps-convert-let*
             (second form)
             (cond ((null (rest (rest form))) ''nil)
                   ((null (rest (rest (rest form)))) (third form))
                   (t `(progn ,@(rest (rest form)))))
             continuation
             environment))
          (otherwise
           (screamer-error
            "Cannot (currently) handle the special form ~A inside a~%~
             nondeterministic context.~%"
            ""
            (first form)))))
       ((member (first form) *nondeterministic-functions* :test #'eq)
        (cps-convert-call
         (first form) (rest form) '() continuation environment))
       (t (cps-non-convert-call
           (first form) (rest form) '() continuation environment)))
      (possibly-beta-convert-funcall continuation form)))

(defun-compile-time LAMBDA-LIST-VARIABLES (lambda-list)
  ;; note: this kludge may fail when lambda-list or its sublists are not
  ;;       proper, non-circular lists
  (set-difference
   (reduce #'union
           (mapcar #'(lambda (arg)
                       (if (consp arg)
                           (if (eql (list-length arg) 3)
                               (list (if (and (consp (first arg))
                                              (eql (list-length arg) 2))
                                         (second (first arg))
                                         (first arg))
                                     (third arg))
                               (list (if (and (consp (first arg))
                                              (eql (list-length arg) 2))
                                         (second (first arg))
                                         (first arg))))
                           (list arg)))
                   lambda-list)
           :initial-value '())
   lambda-list-keywords
   :test #'eq))

(defun-compile-time DECLARE-NONDETERMINISTIC (function-name)
  (if (not (symbolp function-name))
      (error "Function name ~A must be a symbol" function-name))
  (setf *nondeterministic-functions*
        (adjoin function-name *nondeterministic-functions* :test #'eq)))

;;; note: The deterministic version of a nondeterministic function
;;;       must be capable of behaving as the nondeterministic function
;;;       itself when passed as a functional argument to procedures like
;;;       funcall-nondeterminisitic.  In most cases, however, the
;;;       determinisitic version should return an error.

(defun-compile-time DETERMINISTIC-DEFINITION (function-name lambda-list)
  `(defun ,function-name (&rest arguments)
     ;; note: really (,flag ,continuation ,@lambda-list)
     (declare (arglist ,@lambda-list))
     (if (and (consp arguments)
              (eq (first arguments) *nondeterminism-flag*))
         (apply #',(cps-convert-function-name function-name) (rest arguments))
         (screamer-error
          "Function ~A is a nondeterministic function. As such, it must be~%~
           called only from a nondeterministic context.~%"
          "~%A nondeterministic function cannot be FUNCALLed or APPLYed.~%~
           Use FUNCALL-NONDETERMINISTIC or APPLY-NONDETERMINISTIC instead.~%~
           Perhaps you forgot to declare ~A to be nondeterministic via a~%~
           FORWARD-DECLARE-NONDETERMINISTIC declaration."
          ',function-name
          ',function-name))))

;;; The protocol

(defun UNDEFUN-NONDETERMINISTIC (function-name)
  (cond
   ((member function-name *nondeterministic-functions* :test #'eq)
    (setf *nondeterministic-functions*
          (delete function-name *nondeterministic-functions* :test #'eq))
    (fmakunbound function-name)
    (fmakunbound (cps-convert-function-name function-name)))
   (t (error "There is no nondeterministic function named ~A" function-name))))

(defmacro FORWARD-DECLARE-NONDETERMINISTIC (function-name)
  `(eval-when (compile load eval) (declare-nondeterministic ',function-name)))

(defmacro DEFUN-NONDETERMINISTIC-INTERNAL
          (function-name lambda-list &body body &environment environment)
  (declare-nondeterministic function-name)
  (let ((continuation (gensym "CONTINUATION-")))
    `(eval-when (compile load eval)
       (declare-nondeterministic ',function-name)
       ,(deterministic-definition function-name lambda-list)
       (defun ,(cps-convert-function-name function-name)
              (,continuation ,@lambda-list)
         ,continuation                          ;ignore
         ,(cps-convert-progn body continuation environment)))))

(defmacro DEFUN-NONDETERMINISTIC (function-name lambda-list &body body)
  ;; note: EITHER-FUNCTION is intentionally undefined
  `(macrolet ((either (&body body) `(either-function ,@body)))
     (defun-nondeterministic-internal ,function-name ,lambda-list ,@body)))

(defmacro EITHER (&body forms)
  (case (length forms)
    (0 '(fail))
    (1 (first forms))
    (otherwise
     (screamer-error
      "You can only use the EITHER special form in a nondeterministic~%~
       context.~%"
      "~%Also, EITHER is a nondeterministic special form, not a function,~%~
       so it cannot be FUNCALLed or APPLYed."))))

;;; needs work: to signal an error if FAIL or LOCALLY-SETF are called in a
;;;             deterministic context which is not nested in a choice point.

(defmacro FAIL () '(throw 'fail nil))

;;; note: (LOCALLY-SETF X e) will signal an error of X is unbound because it
;;;       needs to trail the previous value of X and it has none.

(defmacro LOCALLY-SETF (reference value &rest more-pairs)
  (if (oddp (length more-pairs))
      (error "Odd number of arguments to LOCALLY-SETF: ~A"
             `(locally-setf ,reference ,value ,@more-pairs)))
  (let ((d (gensym "DUMMY-")))
    (multiple-value-bind (vars vals stores store-form access-form)
        (get-setf-method reference)
      `(let* (,@(mapcar #'list vars vals)
              (,(first stores) ,value)
              (,d ,access-form))
         (vector-push-extend
          #'(lambda () ,(subst d (first stores) store-form)) *trail*)
         ,@(if (null more-pairs)
               (list store-form)
               (list store-form `(locally-setf ,@more-pairs)))))))

(defmacro MAP-VALUES-INTERNAL (function form &environment environment)
  `(let ((function ,function))
     function                                   ;ignore
     (catch 'succeed
       (choice-point
        ,(cps-convert
          form
          '#'(lambda (value)
               (declare (#+symbolics sys:downward-function #-symbolics magic))
               (funcall function value)
               (fail))
          environment))
       nil)))

(defmacro MAP-VALUES (function form)
  ;; note: EITHER-FUNCTION is intentionally undefined
  `(macrolet ((either (&body body) `(either-function ,@body)))
     (map-values-internal ,function ,form)))

(defmacro ONE-VALUE (form1 &optional (form2 nil form2?))
  `(block one-value
     (map-values
      #'(lambda (value)
          (declare (#+symbolics sys:downward-function #-symbolics magic))
          (return-from one-value value))
      ,form1)
     ,(if form2? form2 '(fail))))

(defmacro ALL-VALUES (&body forms)
  `(let ((values '())
         (last-value-cons nil))
     (map-values
      #'(lambda (value)
          (declare (#+symbolics sys:downward-function #-symbolics magic))
          (cond ((null values)
                 (setf last-value-cons (list value))
                 (setf values last-value-cons))
                (t (setf (rest last-value-cons) (list value))
                   (setf last-value-cons (rest last-value-cons)))))
      (progn ,@forms))
     values))

(defmacro NTH-VALUE (n form1 &optional (form2 nil form2?))
  `(block nth-value
     (let* ((n ,n)
            (count n))
       (map-values
        #'(lambda (value)
            (declare (#+symbolics sys:downward-function #-symbolics magic))
            (if (zerop count) (return-from nth-value value) (decf count)))
        ,form1)
       ,(if form2? form2 '(fail)))))

(defmacro PRINT-VALUES (form)
  `(map-values
    #'(lambda (value)
        (declare (#+symbolics sys:downward-function #-symbolics magic))
        (print value)
        (unless (y-or-n-p "Do you want another solution? ")
          (throw 'succeed value)))
    ,form))

;;; note: Should have way of having a stream of values.

(defun-nondeterministic MEMBER-OF-VECTOR (vector i n)
  (if (= i n)
      (fail)
      (either (aref vector i) (member-of-vector vector (1+ i) n))))

(defun-nondeterministic MEMBER-OF (values)
  ;; note: This has to be IF rather than COND so Explorer and Franz work.
  (if (listp values)
      (if (null values)
          (fail)
          (either (first values) (member-of (rest values))))
      (if (vectorp values)
          (member-of-vector values 0 (length values))
          (error "VALUES must be a sequence"))))

(defun-nondeterministic INTEGER-BETWEEN (min max)
  (if (> min max) (fail) (either min (integer-between (1+ min) max))))

(forward-declare-nondeterministic funcall-nondeterministic)

(defun FUNCALL-NONDETERMINISTIC (&rest arguments)
  ;;note: really (flag continuation function &rest arguments)
  (declare (arglist function &rest arguments))
  (if (and (consp arguments)
           (eq (first arguments) *nondeterminism-flag*))
      (if (consp (rest (rest arguments)))
          (apply (third arguments)
                 (first arguments)
                 (second arguments)
                 (rest (rest (rest arguments))))
          (error "Wrong number of arguments to FUNCALL-NONDETERMINISTIC"))
      (screamer-error
       "FUNCALL-NONDETERMINISTIC is a nondeterministic function. As~%~
        such, it must be called only from a nondeterministic context.~%"
       "~%A nondeterministic function cannot be FUNCALLed or APPLYed. Use~%~
        FUNCALL-NONDETERMINISTIC or APPLY-NONDETERMINISTIC instead.")))

(defun FUNCALL-NONDETERMINISTIC-NONDETERMINISTIC
       (continuation function &rest arguments)
  (apply function *nondeterminism-flag* continuation arguments))

(forward-declare-nondeterministic apply-nondeterministic)

(defun APPLY-NONDETERMINISTIC (&rest arguments)
  ;; note: really (flag continuation function argument &rest arguments)
  (declare (arglist function argument &rest arguments))
  (if (and (consp arguments)
           (eq (first arguments) *nondeterminism-flag*))
      (if (and (consp (rest (rest arguments)))
               (consp (rest (rest (rest arguments)))))
          (apply (third arguments)
                 (first arguments)
                 (second arguments)
                 ;; note: I don't know how to avoid the consing here.
                 (apply #'list* (rest (rest (rest arguments)))))
          (error "Wrong number of arguments to APPLY-NONDETERMINISTIC"))
      (screamer-error
       "APPLY-NONDETERMINISTIC is a nondeterministic function. As~%~
        such, it must be called only from a nondeterministic context.~%"
       "~%A nondeterministic function cannot be FUNCALLed or APPLYed. Use~%~
        FUNCALL-NONDETERMINISTIC or APPLY-NONDETERMINISTIC instead.")))

(defun APPLY-NONDETERMINISTIC-NONDETERMINISTIC
       (continuation function argument &rest arguments)
  (apply function
         *nondeterminism-flag*
         continuation
         ;; note: I don't know how to avoid the consing here.
         (apply #'list* (cons argument arguments))))

(defmacro LAMBDA-NONDETERMINISTIC-INTERNAL
          (lambda-list &body body &environment environment)
  (cps-convert-lambda-nondeterministic lambda-list body environment))

(defmacro LAMBDA-NONDETERMINISTIC (lambda-list &body body)
  ;; note: you MUST use (LAMBDA-NONDETERMINISTIC (...) ...) in a deterministic
  ;;       context and NOT #'(LAMBDA-NONDETERMINISTIC (...) ...) since there
  ;;       is no way of getting FUNCTION to do the right thing in the latter
  ;;       case
  ;; note: EITHER-FUNCTION is intentionally undefined
  `(macrolet ((either (&body body) `(either-function ,@body)))
     (lambda-nondeterministic-internal ,lambda-list ,@body)))

;;; Tam V'Nishlam Shevah L'El Borei Olam