Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- (in-package :optima)
- ;;; Data Destructor
- (defstruct destructor
- bindings
- predicate-form
- accessor-forms)
- ;;; Pattern Data Structure
- (defstruct pattern)
- (defstruct (variable-pattern (:include pattern)
- (:constructor %make-variable-pattern (name)))
- name)
- (defun make-variable-pattern (&optional name)
- (when (or (eq name 'otherwise)
- (string= name "_"))
- (setq name nil))
- (%make-variable-pattern name))
- (defstruct (place-pattern (:include pattern)
- (:constructor make-place-pattern (name)))
- name)
- (defstruct (constant-pattern (:include pattern)
- (:constructor make-constant-pattern (value)))
- value)
- (defstruct (complex-pattern (:include pattern))
- subpatterns)
- (defstruct (guard-pattern (:include complex-pattern)
- (:constructor make-guard-pattern (subpattern test-form
- &aux (subpatterns (list subpattern)))))
- test-form)
- (defun guard-pattern-subpattern (pattern)
- (first (complex-pattern-subpatterns pattern)))
- (defstruct (not-pattern (:include complex-pattern)
- (:constructor make-not-pattern (subpattern
- &aux (subpatterns (list subpattern))))))
- (defun not-pattern-subpattern (pattern)
- (first (complex-pattern-subpatterns pattern)))
- (defstruct (or-pattern (:include complex-pattern)
- (:constructor make-or-pattern (&rest subpatterns))))
- (defstruct (and-pattern (:include complex-pattern)
- (:constructor make-and-pattern (&rest subpatterns))))
- (defstruct (constructor-pattern (:include complex-pattern)))
- (defun constructor-pattern-arity (pattern)
- (length (constructor-pattern-subpatterns pattern)))
- (defgeneric constructor-pattern-destructor-sharable-p (x y))
- (defgeneric constructor-pattern-make-destructor (pattern var))
- (defstruct (cons-pattern (:include constructor-pattern)
- (:constructor make-cons-pattern (car-pattern cdr-pattern
- &aux (subpatterns (list car-pattern
- cdr-pattern))))))
- (defun cons-pattern-car-pattern (pattern)
- (first (constructor-pattern-subpatterns pattern)))
- (defun cons-pattern-cdr-pattern (pattern)
- (second (constructor-pattern-subpatterns pattern)))
- (defmethod constructor-pattern-destructor-sharable-p ((x cons-pattern) (y cons-pattern))
- t)
- (defmethod constructor-pattern-make-destructor ((pattern cons-pattern) var)
- (make-destructor :predicate-form `(consp ,var)
- :accessor-forms (list `(car ,var) `(cdr ,var))))
- (defstruct (assoc-pattern (:include constructor-pattern)
- (:constructor make-assoc-pattern (item value-pattern
- &key key test
- &aux (subpatterns (list value-pattern)))))
- item key test)
- (defun assoc-pattern-value-pattern (pattern)
- (first (constructor-pattern-subpatterns pattern)))
- (defmethod constructor-pattern-destructor-sharable-p ((x assoc-pattern) (y assoc-pattern))
- (and (eq (assoc-pattern-key x)
- (assoc-pattern-key y))
- (eq (assoc-pattern-test x)
- (assoc-pattern-test y))
- ;; FIXME: Don't use EQL
- (eql (assoc-pattern-item x)
- (assoc-pattern-item y))))
- (defmethod constructor-pattern-make-destructor ((pattern assoc-pattern) var)
- (with-slots (item key test) pattern
- (with-unique-names (it)
- (make-destructor :bindings `((,it (%assoc ',item ,var
- ,@(when key `(:key #',key))
- ,@(when test `(:test #',test)))))
- :predicate-form it
- :accessor-forms (list `(cdr ,it))))))
- (defstruct (property-pattern (:include constructor-pattern)
- (:constructor make-property-pattern (item value-pattern
- &aux (subpatterns (list value-pattern)))))
- item)
- (defun property-pattern-value-pattern (pattern)
- (first (constructor-pattern-subpatterns pattern)))
- (defmethod constructor-pattern-destructor-sharable-p ((x property-pattern) (y property-pattern))
- (eq (property-pattern-item x) (property-pattern-item y)))
- (defmethod constructor-pattern-make-destructor ((pattern property-pattern) var)
- (with-slots (item) pattern
- (with-unique-names (it)
- (make-destructor :bindings `((,it (%get-property ',item ,var)))
- :predicate-form it
- :accessor-forms (list `(car ,it))))))
- (defstruct (vector-pattern (:include constructor-pattern)
- (:constructor make-vector-pattern (&rest subpatterns))))
- (defmethod constructor-pattern-destructor-sharable-p ((x vector-pattern) (y vector-pattern))
- (= (constructor-pattern-arity x)
- (constructor-pattern-arity y)))
- (defmethod constructor-pattern-make-destructor ((pattern vector-pattern) var)
- (make-destructor :predicate-form `(typep ,var '(vector * ,(constructor-pattern-arity pattern)))
- :accessor-forms (loop for i from 0 below (constructor-pattern-arity pattern)
- collect `(aref ,var ,i))))
- (defstruct (simple-vector-pattern (:include constructor-pattern)
- (:constructor make-simple-vector-pattern (&rest subpatterns))))
- (defmethod constructor-pattern-destructor-sharable-p ((x simple-vector-pattern) (y simple-vector-pattern))
- (= (constructor-pattern-arity x)
- (constructor-pattern-arity y)))
- (defmethod constructor-pattern-make-destructor ((pattern simple-vector-pattern) var)
- (make-destructor :predicate-form `(typep ,var '(simple-vector ,(constructor-pattern-arity pattern)))
- :accessor-forms (loop for i from 0 below (constructor-pattern-arity pattern)
- collect `(svref ,var ,i))))
- (defstruct (class-pattern (:include constructor-pattern)
- (:constructor %make-class-pattern))
- class-name slot-names)
- (defun make-class-pattern (class-name &rest slot-specs)
- (%make-class-pattern :class-name class-name
- :slot-names (mapcar #'first slot-specs)
- :subpatterns (mapcar #'second slot-specs)))
- (defmethod constructor-pattern-destructor-sharable-p ((x class-pattern) (y class-pattern))
- (and (eq (class-pattern-class-name x)
- (class-pattern-class-name y))
- (equal (class-pattern-slot-names x)
- (class-pattern-slot-names y))))
- (defmethod constructor-pattern-make-destructor ((pattern class-pattern) var)
- (make-destructor :predicate-form `(typep ,var ',(class-pattern-class-name pattern))
- :accessor-forms (loop for slot-name in (class-pattern-slot-names pattern)
- collect `(slot-value ,var ',slot-name))))
- (defstruct (structure-pattern (:include constructor-pattern)
- (:constructor %make-structure-pattern))
- conc-name slot-names)
- (defun make-structure-pattern (conc-name &rest slot-specs)
- (%make-structure-pattern :conc-name conc-name
- :slot-names (mapcar #'first slot-specs)
- :subpatterns (mapcar #'second slot-specs)))
- (defmethod constructor-pattern-destructor-sharable-p ((x structure-pattern) (y structure-pattern))
- (and (string= (structure-pattern-conc-name x)
- (structure-pattern-conc-name y))
- (equal (structure-pattern-slot-names x)
- (structure-pattern-slot-names y))))
- (defmethod constructor-pattern-make-destructor ((pattern structure-pattern) var)
- (make-destructor :predicate-form `(,(symbolicate (structure-pattern-conc-name pattern) :p) ,var)
- :accessor-forms (loop with conc-name = (structure-pattern-conc-name pattern)
- for slot-name in (structure-pattern-slot-names pattern)
- collect `(,(symbolicate conc-name slot-name) ,var))))
- ;;; Pattern Utilities
- (defun pattern-variables (pattern)
- "Returns the set of variables in PATTERN. If PATTERN is not linear,
- an error will be raised."
- (flet ((check (vars)
- (loop for var in vars
- if (find var seen)
- do (error "Non-linear pattern: ~S"
- (unparse-pattern pattern))
- collect var into seen
- finally (return vars))))
- (typecase pattern
- (variable-pattern
- (if-let ((name (variable-pattern-name pattern)))
- (list name)))
- (or-pattern
- (let ((vars (mappend #'pattern-variables (or-pattern-subpatterns pattern))))
- (check (remove-duplicates vars))))
- (complex-pattern
- (check (mappend #'pattern-variables (complex-pattern-subpatterns pattern)))))))
- (defun place-pattern-included-p (pattern)
- (typecase pattern
- (place-pattern t)
- (complex-pattern
- (some #'place-pattern-included-p
- (complex-pattern-subpatterns pattern)))))
- (defun check-patterns (patterns)
- "Check if PATTERNS are valid. Otherwise, an error will be raised."
- (loop for var in (mappend #'pattern-variables patterns)
- if (find var seen)
- do (error "Non-linear patterns: ~S"
- (mapcar #'unparse-pattern patterns))
- collect var into seen
- finally (return t)))
- (defun lift-guard-patterns-1 (pattern)
- "Lifts GUARD patterns in PATTERN so that the guards can see
- any variables in PATTERN. The transform looks like:
- (list x (guard y (equal x y)))
- => (guard (list x y) (equal x y))
- Multiple guards will be connected with conjunction in order of
- occurence like:
- (list (guard x (consp x)) (guard y (eq y (car x))))
- => (guard (list x (guard y (eq y (car x)))) (consp x))
- => (guard (guard (list x y) (eq y (car x))) (consp x))
- => (guard (list x y) (and (consp x) (eq y (car x))))"
- (cond
- ((guard-pattern-p pattern)
- (let ((subpattern (lift-guard-patterns (guard-pattern-subpattern pattern)))
- (test-form (guard-pattern-test-form pattern)))
- (if (guard-pattern-p subpattern)
- ;; Connect with conjunction like:
- ;; (guard (guard p g2) g1) => (guard p (and g1 g2))
- (let ((test-form `(and ,test-form ,(guard-pattern-test-form subpattern)))
- (subpattern (guard-pattern-subpattern subpattern)))
- (make-guard-pattern subpattern test-form))
- pattern)))
- ((not-pattern-p pattern)
- ;; Stop lifting on not pattern.
- (let* ((subpattern (not-pattern-subpattern pattern))
- (lifted-subpattern (lift-guard-patterns subpattern)))
- (if (and (not (guard-pattern-p subpattern))
- (guard-pattern-p lifted-subpattern))
- (make-not-pattern lifted-subpattern)
- pattern)))
- ((or-pattern-p pattern)
- ;; OR local lift.
- (let* ((subpatterns (or-pattern-subpatterns pattern))
- (lifted-subpatterns (mapcar #'lift-guard-patterns subpatterns)))
- (if (every #'eq subpatterns lifted-subpatterns)
- pattern
- (apply #'make-or-pattern lifted-subpatterns))))
- ((complex-pattern-p pattern)
- (let ((subpatterns (mapcar #'lift-guard-patterns (complex-pattern-subpatterns pattern))))
- (if (some #'guard-pattern-p subpatterns)
- ;; Lift guard patterns like:
- ;; (c ... (guard p g) ...) => (guard (c ... p ...) g)
- (loop for subpattern in subpatterns
- if (guard-pattern-p subpattern)
- collect (guard-pattern-test-form subpattern) into test-forms
- and do (setq subpattern (guard-pattern-subpattern subpattern))
- collect subpattern into new-subpatterns
- finally
- (let ((pattern (copy-structure pattern)))
- (setf (complex-pattern-subpatterns pattern) new-subpatterns)
- (return (make-guard-pattern pattern `(and ,.test-forms)))))
- ;; Otherwise, just return the original pattern
- pattern)))
- (t pattern)))
- (defun lift-guard-patterns-2 (pattern)
- "Lifts OR patterns that include guards like:
- (list 3 (or 1 (guard x (evenp x))))
- => (or (list 3 1) (list 3 (guard x (evenp x))))
- => (or (list 3 1) (guard (list 3 x) (evenp x)))"
- (flet ((guards-or-pattern-p (p)
- (and (or-pattern-p p)
- (some #'guard-pattern-p (or-pattern-subpatterns p)))))
- (cond
- ((or-pattern-p pattern)
- (let ((subpatterns (mapcar #'lift-guard-patterns (or-pattern-subpatterns pattern))))
- (if (some #'or-pattern-p subpatterns)
- ;; Expand nested OR patterns
- (loop for subpattern in subpatterns
- if (or-pattern-p subpattern)
- append (or-pattern-subpatterns subpattern) into new-subpatterns
- else
- collect subpattern into new-subpatterns
- finally (return (lift-guard-patterns (apply #'make-or-pattern new-subpatterns))))
- pattern)))
- ((complex-pattern-p pattern)
- (let ((subpatterns (mapcar #'lift-guard-patterns (complex-pattern-subpatterns pattern))))
- (if (some #'guards-or-pattern-p subpatterns)
- ;; Lift first OR pattern that include GUARD patterns like:
- ;; (c ... (or ... (guard p g) ...) ...) => (or ... (c ... (guard p g) ...) ...)
- (loop for i from 0
- for subpattern in subpatterns
- if (guards-or-pattern-p subpattern)
- return (loop for subpat in (or-pattern-subpatterns subpattern)
- for pat = (copy-structure pattern)
- for pat-subpats = (copy-list (complex-pattern-subpatterns pat))
- do (setf (nth i pat-subpats) subpat
- (complex-pattern-subpatterns pat) pat-subpats)
- collect pat into new-pats
- finally (return (lift-guard-patterns (apply #'make-or-pattern new-pats)))))
- ;; Otherwise, just return the original pattern
- pattern)))
- (t pattern))))
- (defun lift-guard-patterns (pattern)
- (let ((new-pattern (lift-guard-patterns-1 (lift-guard-patterns-2 (lift-guard-patterns-1 pattern)))))
- (if (eq pattern new-pattern)
- new-pattern
- (lift-guard-patterns new-pattern))))
- ;;; Pattern Specifier
- (defun pattern-expand-function (name)
- (get name 'pattern-expand-function))
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (defun (setf pattern-expand-function) (function name)
- (setf (get name 'pattern-expand-function) function)))
- (defun pattern-expand-1 (pattern)
- (if-let (it (and (consp pattern)
- (symbolp (car pattern))
- (pattern-expand-function (car pattern))))
- (apply it (cdr pattern))
- pattern))
- (defun pattern-expand (pattern)
- (let ((expansion (pattern-expand-1 pattern)))
- (if (eq pattern expansion)
- pattern
- (pattern-expand expansion))))
- (defun pattern-expand-all (pattern)
- (setq pattern (pattern-expand pattern))
- (if (consp pattern)
- (cons (car pattern)
- (mapcar #'pattern-expand-all (cdr pattern)))
- pattern))
- (defmacro defpattern (name lambda-list &body body)
- "Defines a derived pattern specifier named NAME. This is analogous
- to DEFTYPE.
- Examples:
- ;; Defines a LIST pattern.
- (defpattern list (&rest args)
- (when args
- `(cons ,(car args) (list ,@(cdr args)))))"
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (setf (pattern-expand-function ',name) (lambda ,lambda-list ,@body))))
- (defpattern list (&rest args)
- (when args
- `(cons ,(car args) (list ,@(cdr args)))))
- (defpattern list* (arg &rest args)
- (if (null args)
- `,arg
- `(cons ,arg (list* ,@args))))
- (defpattern satisfies (predicate-name)
- (with-unique-names (it)
- `(guard ,it (,predicate-name ,it))))
- (defpattern eq (arg)
- (with-unique-names (it)
- `(guard ,it (eq ,it ,arg))))
- (defpattern eql (arg)
- (with-unique-names (it)
- `(guard ,it (eql ,it ,arg))))
- (defpattern equal (arg)
- (with-unique-names (it)
- `(guard ,it (equal ,it ,arg))))
- (defpattern equalp (arg)
- (with-unique-names (it)
- `(guard ,it (equalp ,it ,arg))))
- (defpattern type (type-specifier)
- (with-unique-names (it)
- `(guard ,it (typep ,it ',type-specifier))))
- ;;; Pattern Specifier Parser
- (defun parse-pattern (pattern)
- (when (pattern-p pattern)
- (return-from parse-pattern pattern))
- (setq pattern (pattern-expand pattern))
- (typecase pattern
- ((or (eql t) null keyword)
- (make-constant-pattern pattern))
- (symbol
- (make-variable-pattern pattern))
- (cons
- (destructuring-case pattern
- ((variable name)
- (make-variable-pattern name))
- ((place name)
- (make-place-pattern name))
- ((quote value)
- (make-constant-pattern value))
- ((guard subpattern test-form)
- (make-guard-pattern (parse-pattern subpattern) test-form))
- ((not subpattern)
- (make-not-pattern (parse-pattern subpattern)))
- ((or &rest subpatterns)
- (if (= (length subpatterns) 1)
- (parse-pattern (first subpatterns))
- (let ((subpatterns (mapcar #'parse-pattern subpatterns)))
- (when (some #'place-pattern-included-p subpatterns)
- (error "Or-pattern can't include place-patterns."))
- (apply #'make-or-pattern subpatterns))))
- ((and &rest subpatterns)
- (if (= (length subpatterns) 1)
- (parse-pattern (first subpatterns))
- (apply #'make-and-pattern (mapcar #'parse-pattern subpatterns))))
- ((otherwise &rest args)
- (apply #'parse-constructor-pattern (car pattern) args))))
- (otherwise
- (make-constant-pattern pattern))))
- (defgeneric parse-constructor-pattern (name &rest args))
- (defmethod parse-constructor-pattern ((name (eql 'cons)) &rest args)
- (unless (= (length args) 2)
- (error "Malformed pattern: ~S" (list* 'cons args)))
- (apply #'make-cons-pattern (mapcar #'parse-pattern args)))
- (defmethod parse-constructor-pattern ((name (eql 'assoc)) &rest args)
- (destructuring-bind (item pattern &key key test) args
- (make-assoc-pattern item (parse-pattern pattern) :key key :test test)))
- (defmethod parse-constructor-pattern ((name (eql 'property)) &rest args)
- (destructuring-bind (item pattern) args
- (make-property-pattern item (parse-pattern pattern))))
- (defmethod parse-constructor-pattern ((name (eql 'vector)) &rest args)
- (apply #'make-vector-pattern (mapcar #'parse-pattern args)))
- (defmethod parse-constructor-pattern ((name (eql 'simple-vector)) &rest args)
- (apply #'make-simple-vector-pattern (mapcar #'parse-pattern args)))
- (defun parse-class-pattern (class-name &rest slot-specs)
- ;; Transform MAKE-INSTANCE style syntax. During the transformation,
- ;; we also resolve the slot names via MOP. If no slot found or too
- ;; many slots found, we will raise an error.
- (when (keywordp (first slot-specs))
- (let ((class (find-class class-name nil)))
- (unless (closer-mop:class-finalized-p class)
- (closer-mop:finalize-inheritance class))
- (setq slot-specs
- (loop with all-slot-names = (mapcar #'closer-mop:slot-definition-name
- (closer-mop:class-slots class))
- for (slot-name . pattern) in (plist-alist slot-specs)
- for slot-names = (remove-if (lambda (name) (string/= slot-name name))
- all-slot-names)
- collect (case (length slot-names)
- (0 (error "Slot ~S not found" slot-name))
- (1 `(,(first slot-names) ,pattern))
- (t (error "Ambiguous slot name ~S" slot-name)))))))
- (apply #'make-class-pattern class-name
- (loop for slot-spec in slot-specs
- do (setq slot-spec (ensure-list slot-spec))
- collect (let ((slot-name (first slot-spec)))
- (list slot-name
- (if (rest slot-spec)
- (parse-pattern `(and ,@(rest slot-spec)))
- (make-variable-pattern slot-name)))))))
- (defun parse-structure-pattern (conc-name &rest slot-specs)
- ;; Transform MAKE-INSTANCE style syntax.
- (when (keywordp (first slot-specs))
- (setq slot-specs (mapcar (lambda (assoc) (list (car assoc) (cdr assoc)))
- (plist-alist slot-specs))))
- (apply #'make-structure-pattern conc-name
- (loop for slot-spec in slot-specs
- do (setq slot-spec (ensure-list slot-spec))
- collect (let ((slot-name (first slot-spec)))
- (list slot-name
- (if (rest slot-spec)
- (parse-pattern `(and ,@(rest slot-spec)))
- (make-variable-pattern slot-name)))))))
- (defmethod parse-constructor-pattern ((name (eql 'class)) &rest args)
- (apply #'parse-class-pattern args))
- (defmethod parse-constructor-pattern ((name (eql 'structure)) &rest args)
- (apply #'parse-structure-pattern args))
- (defmethod parse-constructor-pattern (name &rest slot-specs)
- (if (find-class name nil)
- (apply #'parse-class-pattern name slot-specs)
- (apply #'parse-structure-pattern name slot-specs)))
- ;;; Pattern Specifier Parser
- (defgeneric unparse-pattern (pattern))
- (defmethod unparse-pattern ((pattern variable-pattern))
- (or (variable-pattern-name pattern) '_))
- (defmethod unparse-pattern ((pattern place-pattern))
- `(place ,(place-pattern-name pattern)))
- (defmethod unparse-pattern ((pattern constant-pattern))
- (with-slots (value) pattern
- (cond
- ((typep value '(and symbol (not keyword) (not (member nil t))))
- `(quote ,value))
- ((atom value)
- value)
- (t
- `(quote ,value)))))
- (defmethod unparse-pattern ((pattern guard-pattern))
- `(guard ,(unparse-pattern (guard-pattern-subpattern pattern))
- ,(guard-pattern-test-form pattern)))
- (defmethod unparse-pattern ((pattern not-pattern))
- `(not ,(unparse-pattern (not-pattern-subpattern pattern))))
- (defmethod unparse-pattern ((pattern or-pattern))
- `(or ,@(mapcar #'unparse-pattern (or-pattern-subpatterns pattern))))
- (defmethod unparse-pattern ((pattern and-pattern))
- `(and ,@(mapcar #'unparse-pattern (and-pattern-subpatterns pattern))))
- (defmethod unparse-pattern ((pattern cons-pattern))
- `(cons ,(unparse-pattern (cons-pattern-car-pattern pattern))
- ,(unparse-pattern (cons-pattern-cdr-pattern pattern))))
- (defmethod unparse-pattern ((pattern assoc-pattern))
- (with-slots (item key test) pattern
- `(assoc ,item
- ,(unparse-pattern (assoc-pattern-value-pattern pattern))
- ,@(when key (list :key key))
- ,@(when test (list :test test)))))
- (defmethod unparse-pattern ((pattern property-pattern))
- `(property ,(property-pattern-item pattern)
- ,(unparse-pattern (property-pattern-value-pattern pattern))))
- (defmethod unparse-pattern ((pattern vector-pattern))
- `(vector ,@(mapcar #'unparse-pattern (vector-pattern-subpatterns pattern))))
- (defmethod unparse-pattern ((pattern simple-vector-pattern))
- `(simple-vector ,@(mapcar #'unparse-pattern (simple-vector-pattern-subpatterns pattern))))
- (defmethod unparse-pattern ((pattern class-pattern))
- `(class ,(class-pattern-class-name pattern)
- ,@(loop for slot-name in (class-pattern-slot-names pattern)
- for subpattern in (class-pattern-subpatterns pattern)
- collect (list slot-name (unparse-pattern subpattern)))))
- (defmethod unparse-pattern ((pattern structure-pattern))
- `(structure ,(structure-pattern-conc-name pattern)
- ,@(loop for slot-name in (structure-pattern-slot-names pattern)
- for subpattern in (structure-pattern-subpatterns pattern)
- collect (list slot-name (unparse-pattern subpattern)))))
- (defmethod print-object ((pattern pattern) stream)
- ;; NOTE: printing the pattern specifier might not be valid but this
- ;; is useful for debugging the process of pattern matching compiler.
- (format stream "~S" (unparse-pattern pattern)))
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement