Commit dc368f99 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Importing fare-matcher source from my personal monotone repository

parents
;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;;;; Fare's stuff for CLOS and its MOP
; This file contains enough to generate matchers of instances of classes
; known at macro-expansion-time.
(in-package :fare-clos-match)
;(eval-now
(defgeneric class-initarg-to-slot (class))
(defmethod class-initarg-to-slot ((class standard-class))
(loop
with hash = (make-hash-table)
with slots = (compute-slots class)
for slot in slots
do (loop for initarg in (slot-definition-initargs slot)
do (setf (gethash initarg hash) slot))
finally (return #'(lambda (x) (gethash x hash)))))
;)
(defun simple-load-form (&rest rest)
(mvbind (vars lforms iforms)
(values (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) rest)
(mapcar2 #'make-load-form rest))
`(let ,(mapcar #'list vars lforms)
,@iforms
(values ,@vars))))
#-gcl
(define-macro-matcher instance
#'(lambda (class &rest arglist)
(let ((initarg-to-slot (class-initarg-to-slot (find-class class)))
(*form (gensym))
(matchers '())
(var-lists '()))
(mapc #'(lambda (x)
(let* ((initarg (car x))
(pat (cdr x))
(slot (funcall initarg-to-slot initarg))
(slotname (slot-definition-name slot)))
(mvbind (matcher vars) (pattern-matcher pat)
(push `(funcall ,matcher
(slot-value ,*form ',slotname))
;; I don't dare use slot-value-using-class,
;; because the matched object's class
;; may be a subclass of class
matchers)
(push vars var-lists))))
(plist->alist arglist))
(values
`#'(lambda (,*form)
`(m%and (typep ,',*form ',',class)
,,@(nreverse matchers)))
(merge-matcher-variables var-lists)))))
#|
(load "fare")
(load "matcher")
(load "fare-clos")
(in-package :fare-clos)
(defclass foo ()
((x :initarg :x :accessor foo-x)
(y :initarg :y :accessor foo-y)))
(defclass bar (foo)
((z :initarg :z :accessor bar-z)))
(setf (symbol-function 'baz) (class-initarg-to-slot (find-class 'bar)))
(TTEST*
((ifmatch (instance foo :x x :y y) (make-instance 'foo :x 1 :y 2) (list x y))
:result '(1 2))
((ifmatch (instance foo :x x :y y) (make-instance 'bar :x 1 :y 2 :z 3)
(list x y))
:result '(1 2))
((ifmatch (slot* (x a) (z b)) (make-instance 'bar :x 1 :y 2 :z 3)
(list a b))
:result '(1 3))
((ifmatch (accessor* (foo-x a) (bar-z b)) (make-instance 'bar :x 1 :y 2 :z 3)
(list a b))
:result '(1 3)))
|#
;;; -*- Lisp -*-
(in-package :cl)
(asdf:defsystem :fare-matcher
:depends-on (:fare-utils)
:serial t
:components ((:file "packages")
(:file "matcher")
#-gcl ; it currently fails. quasiquote necessitates a big revamp anyway
(:file "quasiquote")
;;#-gcl ; 2.7.0-64.1 cannot defgeneric in a eval-now
(:file "clos-match")
(:file "mrd-extensions")))
This diff is collapsed.
This diff is collapsed.
(in-package #:cl-user)
(defpackage #:fare-matcher
(:use #:fare-utils #:common-lisp)
(:export #:match #:ifmatch #:ematch
#:_ ;;; #:*
#:like-when #:value #:of-type
#:slot* #:accessor* #:instance
;;; #:quote #:when #:or #:and #:values
;;; #:cons #:list #:list* #:vector #:satisfies
#:letm #:ifm
#:define-symbol-matcher
#:define-macro-matcher
#:define-function-matcher
#:define-constructor-matcher
#:define-varary-constructor-matcher
#:copy-symbol-matcher #:copy-symbol-and-matcher
#:copy-function-matcher #:copy-function-and-matcher
#:pattern-matcher
#:merge-matcher-variables
#:m%and #:m%fail #:m%when #:m%values
)
#-allegro ; breaks on acl50
(:documentation
"Lisp2-style Erlang/ML-like Pattern-Matcher for Common LISP")
(:export))
(defpackage #:fare-quasiquote
(:use #:fare-matcher #:fare-utils #:common-lisp)
(:shadow #:list #:append #:list* #:cons #:quote #:kwote #:quotep #:vector #:make-vector)
#-allegro ; breaks on acl50
(:documentation
"Quasiquote implementation with and for pattern-matching")
(:export #:quasiquote-expand #:quasiquote #:unquote #:unquote-splicing
#:enable-quasiquote))
(defpackage #:fare-clos-match
#+openmcl (:shadowing-import-from #:ccl #:quit)
(:use #:common-lisp #:fare-utils #:fare-matcher
#+cmu #:pcl #+sbcl #:sb-mop #+clisp :clos #+openmcl #:ccl)
(:export #:simple-load-form #:class-initarg-to-slot
#:instance
))
This diff is collapsed.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment