# HG changeset patch # User Steve Losh # Date 1458665189 0 # Node ID 3729fdede843824a391d0aab8678a443187760f5 # Parent 3a8ee0586fdfce67df0609f6398bb75626087cc6 Initial pass at the compiler Completed up to 12.2. diff -r 3a8ee0586fdf -r 3729fdede843 src/paip-compiled.lisp --- a/src/paip-compiled.lisp Tue Mar 22 14:31:35 2016 +0000 +++ b/src/paip-compiled.lisp Tue Mar 22 16:46:29 2016 +0000 @@ -1,5 +1,36 @@ (in-package #:bones.paip) +;;;; Utils +(defun find-all (item sequence + &rest keyword-args + &key (test #'eql) test-not &allow-other-keys) + "Find all elements of the sequence that match the item. + + Does not alter the sequence. + + " + (if test-not + (apply #'remove + item sequence :test-not (complement test-not) + keyword-args) + (apply #'remove + item sequence :test (complement test) + keyword-args))) + +(defun interned-symbol (&rest args) + (intern (format nil "~{~A~}" args))) + +(defun new-symbol (&rest args) + (make-symbol (format nil "~{~A~}" args))) + +(defun find-if-anywhere (test expr) + (cond ((funcall test expr) t) + ((consp expr) (or (find-if-anywhere test (car expr)) + (find-if-anywhere test (cdr expr)))) + (t nil))) + + +;;;; UNIFICATION -------------------------------------------------------------- ;;;; Variables (define-constant unbound "Unbound" :test #'equal @@ -84,3 +115,185 @@ ;; Otherwise they don't unify. (t nil))) + + +;;;; COMPILATION -------------------------------------------------------------- +(deftype relation () + 'list) + +(deftype clause () + '(trivial-types:proper-list relation)) + +(deftype non-negative-integer () + '(integer 0)) + + +(defun prolog-compile (symbol &optional (clauses (get-clauses symbol))) + "Compile a symbol; make a separate function for each arity." + (when (not (null clauses)) + (let* ((arity (relation-arity (clause-head (first clauses)))) + (matching-arity-clauses (clauses-with-arity clauses #'= arity)) + (other-arity-clauses (clauses-with-arity clauses #'/= arity))) + (compile-predicate symbol arity matching-arity-clauses) + (prolog-compile symbol other-arity-clauses)))) + +(defun* clauses-with-arity + ((clauses (trivial-types:proper-list clause)) + (test function) + (arity non-negative-integer)) + "Return all clauses whose heads have the given arity." + (find-all arity clauses + :key #'(lambda (clause) + (relation-arity (clause-head clause))) + :test test)) + + +(defun* relation-arity ((relation relation)) + (:returns non-negative-integer) + "Return the number of arguments of the given relation. + + For example: `(relation-arity '(likes sally cats))` => `2` + + " + (length (relation-arguments relation))) + +(defun* relation-arguments ((relation relation)) + (:returns list) + "Return the arguments of the given relation. + + For example: + + * (relation-arguments '(likes sally cats)) + (sally cats) + + " + (rest relation)) + + +(defun* compile-predicate + ((symbol symbol) + (arity non-negative-integer) + (clauses (trivial-types:proper-list clause))) + "Compile all the clauses for the symbol+arity into a single Lisp function." + (let ((predicate (make-predicate symbol arity)) + (parameters (make-parameters arity))) + (compile + (eval + `(defun ,predicate (,@parameters continuation) + .,(maybe-add-undo-bindings + (mapcar #'(lambda (clause) + (compile-clause parameters clause 'continuation)) + clauses))))))) + +(defun* make-parameters ((arity non-negative-integer)) + (:returns (trivial-types:proper-list symbol)) + "Return the list (?arg1 ?arg2 ... ?argN)." + (loop :for i :from 1 :to arity + :collect (new-symbol '?arg i))) + +(defun* make-predicate ((symbol symbol) + (arity non-negative-integer)) + (:returns symbol) + "Returns (and interns) the symbol with the Prolog-style name symbol/arity." + (values (interned-symbol symbol '/ arity))) + + +(defun make-= (x y) + `(= ,x ,y)) + +(defun compile-clause (parameters clause continuation) + "Transform away the head and compile the resulting body." + (bind-unbound-vars + parameters + (compile-body + (nconc + (mapcar #'make-= parameters (relation-arguments (clause-head clause))) + (clause-body clause)) + continuation))) + +(defun compile-body (body continuation) + "Compile the body of a clause." + (if (null body) + `(funcall ,continuation) + (let* ((goal (first body)) + (macro (prolog-compiler-macro (predicate goal))) + (macro-val (when macro + (funcall macro goal (rest body) continuation)))) + (if (and macro (not (eq macro-val :pass))) + macro-val + (compile-call + (make-predicate (predicate goal) + (relation-arity goal)) + (mapcar #'(lambda (arg) (compile-arg arg)) + (relation-arguments goal)) + (if (null (rest body)) + continuation + `#'(lambda () + ,(compile-body (rest body) continuation)))))))) + +(defun compile-call (predicate args continuation) + `(,predicate ,@args ,continuation)) + +(defun prolog-compiler-macro (name) + "Fetch the compiler macro for a Prolog predicate." + (get name 'prolog-compiler-macro)) + +(defmacro def-prolog-compiler-macro (name arglist &body body) + "Define a compiler macro for Prolog." + `(setf (get ',name 'prolog-compiler-macro) + #'(lambda ,arglist .,body))) + +(def-prolog-compiler-macro + = (goal body continuation) + (let ((args (relation-arguments goal))) + (if (/= (length args) 2) + :pass + `(when ,(compile-unify (first args) (second args)) + ,(compile-body body continuation))))) + +(defun compile-unify (x y) + "Return code that tests if the items unify." + `(unify! ,(compile-arg x) ,(compile-arg y))) + + +(defun compile-arg (arg) + "Generate code for an argument to a goal in the body." + (cond ((variable-p arg) arg) + ((not (has-variable-p arg)) `',arg) + ((proper-list-p arg) + `(list .,(mapcar #'compile-arg arg))) + (t `(cons ,(compile-arg (first arg)) + ,(compile-arg (rest arg)))))) + +(defun has-variable-p (x) + "Is there a variable anywhere in the expression x?" + (find-if-anywhere #'variable-p x)) + +(defun proper-list-p (x) + "Is x a proper (non-dotted) list?" + (or (null x) + (and (consp x) (proper-list-p (rest x))))) + + +(defun maybe-add-undo-bindings (compiled-expressions) + "Undo any bindings that need undoing. + + If there ARE any, also bind the trail before we start. + + " + (if (= (length compiled-expressions) 1) + compiled-expressions + `((let ((old-trail (fill-pointer *trail*))) + ,(first compiled-expressions) + ,@(loop :for expression :in (rest compiled-expressions) + :collect '(undo-bindings! old-trail) + :collect expression))))) + +(defun bind-unbound-vars (parameters expr) + "Bind any variables in expr (besides the parameters) to new vars." + (let ((expr-vars (set-difference (variables-in expr) parameters))) + (if expr-vars + `(let ,(mapcar #'(lambda (var) `(,var (?))) + expr-vars) + ,expr) + expr)))