mirror of
https://github.com/PDP-10/its.git
synced 2026-03-06 03:19:18 +00:00
279 lines
9.5 KiB
Common Lisp
279 lines
9.5 KiB
Common Lisp
;;; -*- LISP -*-
|
||
;;; PATTERN: A Library of Pattern Matching Routines
|
||
|
||
;;; MATCH
|
||
;;; This function allows the following syntax
|
||
;;;
|
||
;;; (MATCH <Pattern> <Thing>)
|
||
;;;
|
||
;;; Returns T iff <Thing> is of the form specified by <Pattern>
|
||
;;;
|
||
;;; <Pattern> is a list with the description...
|
||
;;;
|
||
;;; ( <Specifier> <Specifier> ...)
|
||
;;;
|
||
;;; <Specifier> is one of the following forms:
|
||
;;;
|
||
;;; <atom> Matches an atom that is EQ to it
|
||
;;;
|
||
;;; (?) Matches any single S-Expression
|
||
;;;
|
||
;;; (? <tag>) Matches any single S-Expression and assigns
|
||
;;; to tag the value of the thing matched
|
||
;;;
|
||
;;; (?= <pred>) Matches any single S-Expression for which
|
||
;;; <pred> is true
|
||
;;;
|
||
;;; (?= <pred> <tag>) Matches any single S-Expression for which
|
||
;;; <pred> is true, assigns matched thing to <tag>
|
||
;;;
|
||
;;; ($) Matches a single S-Expression or none.
|
||
;;;
|
||
;;; ($ <tag>) Matches a single S-Expression or none,
|
||
;;; assigning matched item to <tag>.
|
||
;;;
|
||
;;; ($= <pred>) Matches a single S-Expression if it makes
|
||
;;; <pred> true, or none.
|
||
;;;
|
||
;;; ($= <pred> <tag>) Matches a single S-Expression if it makes
|
||
;;; <pred> true, or none, assigns thing
|
||
;;; matched to <tag>
|
||
;;;
|
||
;;; (*) Matches any series of S-Expressions.
|
||
;;;
|
||
;;; (* <tag>) Matches any series of S-Expressions, assigning
|
||
;;; to <tag> a list of the matched things.
|
||
;;;
|
||
;;; (*= <pred>) Matches any series of things that return true
|
||
;;; for <pred>
|
||
;;;
|
||
;;; (*= <pred> <tag>) Matches any series of things that return true
|
||
;;; for <pred>; <tag> gets list of things matched
|
||
;;;
|
||
;;; <Thing> is a list
|
||
;;;
|
||
|
||
;;; MATCH
|
||
;;; This function looks at all constant terms in a pattern, and makes
|
||
;;; sure they at least occur in the same order in item being tested.
|
||
;;; If they don't, the match fails. If they do, the normal (hairy)
|
||
;;; matching scheme is attempted.
|
||
|
||
(DEFUN MATCH (PP XX)
|
||
(DO ((P PP (CDR P))
|
||
(X XX))
|
||
((NULL P) (MATCH1 PP XX))
|
||
(COND ((ATOM (CAR P))
|
||
(SETQ X (MEMQ (CAR P) X))
|
||
(COND ((NULL X) (RETURN NIL)))))))
|
||
|
||
;;; Macros needed for making my code size below a bit more compressed
|
||
|
||
;; (TAILSTRIP <expression>)
|
||
;; removes the last element of a list.
|
||
;; Equivalent to (DEFUN TAILSTRIP (X) (NREVERSE (CDR (REVERSE X))))
|
||
;; but a slight bit faster.
|
||
|
||
(DEFUN TAILSTRIP (X)
|
||
((LAMBDA (R)
|
||
(DO ((X X (CDR X))
|
||
(L (SETQ R (NCONS ())) (CDR L)))
|
||
((NULL (CDR X)) (CDR R))
|
||
(RPLACD L (NCONS (CAR X)))))
|
||
NIL))
|
||
|
||
;; (POP* <var1> <var2> ...)
|
||
;; Same as (PROGN (POP <var1>) (POP <var2>) ...)
|
||
|
||
(DEFUN POP* MACRO (X)
|
||
`(PROGN ,@(MAPCAR (FUNCTION (LAMBDA (X) `(SETQ ,X (CDR ,X))))
|
||
(CDR X))))
|
||
|
||
;;; MATCH1
|
||
;;; This is the real brains behind the matcher. It is called only from
|
||
;;; MATCH, however, which does some preprocessing.
|
||
|
||
(DEFUN MATCH1 (P X)
|
||
(DO ((PATTERN)
|
||
(FUNCTION-VALUE)
|
||
(STARFLAG))
|
||
((NULL P) (NULL X))
|
||
(COND ((ATOM (CAR P)) ; Atom must match exactly
|
||
(COND ((NULL X) (RETURN NIL))); This can't match a null list
|
||
(COND ((EQ (CAR P) (CAR X)) ; If matched...
|
||
(POP* P X) ; Pop pattern & test list
|
||
(SETQ STARFLAG NIL)) ; Terminate * search
|
||
(T ; Else (no atomic match)
|
||
(RETURN NIL)))) ; Match failed
|
||
((EQ (CAAR P) '?) ; ? may match any single thing
|
||
(COND ((NULL X) (RETURN NIL))); This can't match a null list
|
||
(COND ((CDAR P) ; Maybe assign match to a var
|
||
(SET (CADAR P) (CAR X))))
|
||
(POP* P X) ; Pop pattern & test list
|
||
(SETQ STARFLAG NIL)) ; Terminate * search
|
||
((EQ (CAAR P) '?=) ; Match w/ predication
|
||
(COND ((NULL X) (RETURN NIL))); This can't match a null list
|
||
(COND ((NOT (FUNCALL (CADAR P) (CAR X))) ; Try predicate
|
||
(RETURN NIL))) ; Fail if predicate loses
|
||
(COND ((CDDAR P) ; Maybe assign match to a var
|
||
(SET (CADDAR P) (CAR X))))
|
||
(POP* P X) ; Pop pattern & test list
|
||
(SETQ STARFLAG NIL)) ; Terminate * search
|
||
(T
|
||
(SETQ PATTERN (CAR (LAST P))) ; Work on last elements for
|
||
; a while...
|
||
(COND ((ATOM PATTERN) ; If last element is an atom
|
||
(COND ((NULL X) ; This can't match a null list
|
||
(RETURN NIL)))
|
||
(COND ((NOT (EQ (CAR (LAST X)) PATTERN))
|
||
(RETURN NIL))) ; Fail if doesn't match
|
||
(SETQ P (TAILSTRIP P)) ; Pop last element of pattern
|
||
(SETQ X (TAILSTRIP X)) ; Pop last element of test list
|
||
(SETQ STARFLAG NIL)) ; Terminate * search
|
||
((EQ (CAR PATTERN) '?) ; Last element of ? matches!
|
||
(COND ((NULL X) ; This can't match a null list
|
||
(RETURN NIL)))
|
||
(COND ((CDR PATTERN) ; Maybe assign match to a var
|
||
(SET (CADR PATTERN) (CAR (LAST X)))))
|
||
(SETQ P (TAILSTRIP P)) ; Pop last element of pattern
|
||
(SETQ X (TAILSTRIP X)) ; Pop last element of test list
|
||
(SETQ STARFLAG NIL)) ; Terminate * search
|
||
((EQ (CAR PATTERN) '?=) ; Predicated match last element
|
||
(COND ((NULL X) ; This can't match a null list
|
||
(RETURN NIL)))
|
||
(COND ((NOT (FUNCALL (CADR PATTERN) (CAR (LAST X))))
|
||
(RETURN NIL))) ; If pred fails, match fails
|
||
(COND ((CDDR PATTERN) ; Maybe assign match to a var
|
||
(SET (CADDR PATTERN) (CAR (LAST X)))))
|
||
(SETQ P (TAILSTRIP P)) ; Pop last element of pattern
|
||
(SETQ X (TAILSTRIP X)) ; Pop last of element test list
|
||
(SETQ STARFLAG NIL)) ; Terminate * search
|
||
((EQ (CAR (SETQ PATTERN (CAR P))) '$)
|
||
; $ can optionally match
|
||
(COND ((MATCH1 (CDR P) X) ; Test first ignoring $
|
||
(COND ((CDR PATTERN) ; Maybe set a variable
|
||
(SET (CADR PATTERN) NIL))) ; to match
|
||
(RETURN T))) ; We won without it
|
||
(COND ((CDR PATTERN) ; Maybe set a variable to
|
||
(SET (CADR PATTERN) (CAR X)))) ; thing matched
|
||
(POP* P X) ; Pop pattern and test list
|
||
(SETQ STARFLAG NIL)) ; Terminate * search
|
||
((EQ (CAR PATTERN) '$=) ; Match 1 or 0 with predication
|
||
(COND ((MATCH1 (CDR P) X) ; Try first without using $=
|
||
(COND ((CDDR PATTERN) ; Maybe set variable to
|
||
(SET (CADDR PATTERN) NIL))) ; match
|
||
(RETURN T))) ; We won
|
||
(COND ((NOT (FUNCALL (CADR PATTERN) (CAR X))) ; Apply
|
||
(RETURN NIL))) ; predicate - if NIL then fail
|
||
(COND ((CDDR PATTERN) ; Maybe set variable to
|
||
(SET (CADDR PATTERN) (CAR X)))) ; thing matched
|
||
(POP* P X) ; Pop pattern and test list
|
||
(SETQ STARFLAG NIL)) ; Terminate * search
|
||
((EQ (CAR PATTERN) '*) ; * matches any sequence
|
||
(COND ((NULL X) ; If no more elements,
|
||
(RETURN ; make sure no pending
|
||
(MATCH1 (CDR P) NIL))) ; patterns lose.
|
||
((MATCH1 (CDR P) X) ; Else match first without *
|
||
(COND ((AND (NOT STARFLAG)
|
||
(CDR PATTERN)) ;Maybe clear
|
||
(SET (CADR PATTERN) NIL))) ; variable
|
||
(RETURN T))) ; We won
|
||
(COND ((CDR PATTERN) ; If there's a var to set
|
||
(COND (STARFLAG ; add element to end of var
|
||
(SET (CADR PATTERN) ; add to var's val
|
||
(NCONC (EVAL (CADR PATTERN))
|
||
(NCONS (CAR X)))))
|
||
(T ; if var not initialized
|
||
(SET (CADR PATTERN) ;set to (<match>)
|
||
(NCONS (CAR X)))))))
|
||
(POP* X) ; Pop test list
|
||
(SETQ STARFLAG T)) ; Note * search in effect
|
||
((EQ (CAR PATTERN) '*=) ; Match any predicated sequence
|
||
(COND ((NULL X) ; If no more test list
|
||
(RETURN ; Insure no pending patterns
|
||
(MATCH1 (CDR P) NIL))) ; are violated
|
||
((MATCH1 (CDR P) X) ; Else try wihtout
|
||
(COND ((AND (NOT STARFLAG) (CDDR PATTERN))
|
||
(SET (CADDR PATTERN) NIL)))
|
||
(RETURN T)))
|
||
(SETQ FUNCTION-VALUE (FUNCALL (CADR PATTERN) (CAR X)))
|
||
(COND ((NOT FUNCTION-VALUE) (RETURN NIL)))
|
||
(COND ((CDDR PATTERN)
|
||
(COND (STARFLAG
|
||
(SET (CADDR PATTERN)
|
||
(NCONC (EVAL (CADDR PATTERN))
|
||
(NCONS (CAR X)))))
|
||
(T
|
||
(SET (CADDR PATTERN)
|
||
(NCONS (CAR X)))))))
|
||
(SETQ X (CDR X))
|
||
(SETQ STARFLAG T))
|
||
(T ; Unknown pattern form?
|
||
(RETURN NIL))))))) ; Fail
|
||
|
||
(DEFUN MATCH-VAR-GET (X)
|
||
(COND ((ATOM X) NIL)
|
||
((MEMQ (CAR X) '(* ?)) (AND (CDR X) (LIST (CADR X) NIL)))
|
||
(T (AND (CDDR X) (LIST (CADDR X) NIL)))))
|
||
|
||
(DEFUN ELIMINATE-REDUNDANCIES (X)
|
||
(DO ((L X (CDDR L))
|
||
(R NIL))
|
||
((NULL L) (NREVERSE R))
|
||
(COND ((NOT (MEMQ (CAR L) R))
|
||
(SETQ R (CONS (CADR L) (CONS (CAR L) R)))))))
|
||
|
||
(DEFUN MATCH-VARS (L)
|
||
(APPLY 'NCONC
|
||
(MAPCAR (FUNCTION (LAMBDA (P) (MAPCAN 'MATCH-VAR-GET P))) L)))
|
||
|
||
;;; MATCHES
|
||
;;; This is a convenience macro that takes the syntax:
|
||
;;;
|
||
;;; (MATCHES <form> <pattern1> <pattern2> <pattern3> ... <patternM>)
|
||
;;;
|
||
;;; <form> will be EVAL'ed
|
||
;;; <pattern>'s will not be EVAL'd
|
||
;;;
|
||
;;; It will expand to the following:
|
||
;;;
|
||
;;; (PROGN (SETQ <var1> NIL <var2> NIL <var3> NIL ... <varN> NIL)
|
||
;;; (OR (MATCH '<pattern1> <form>)
|
||
;;; (MATCH '<pattern2> <form>)
|
||
;;; (MATCH '<pattern3> <form>)
|
||
;;; ...
|
||
;;; (MATCH '<patternM> <form>)
|
||
;;; (SETQ <var1> NIL <var2> NIL ... <varN> NIL)))
|
||
;;;
|
||
;;; <var1> ... <varN> are the variables that may be set by the Matcher.
|
||
;;; The are initialized to NIL and if the Matches fail, they are
|
||
;;; re-initialized to NIL to avoid chance of getting garbage left over in
|
||
;;; them.
|
||
|
||
(DEFUN (MATCHES MACRO) (X)
|
||
(LET* (((OBJECT . PATTERNS) (CDR X))
|
||
(INITS (ELIMINATE-REDUNDANCIES (MATCH-VARS PATTERNS))))
|
||
(COND (INITS (PUSH 'SETQ INITS)))
|
||
(COND ((NULL PATTERNS) NIL)
|
||
((> (LENGTH PATTERNS) 1.)
|
||
`(OR ,@(MAPCAN
|
||
(FUNCTION
|
||
(LAMBDA (X)
|
||
(COND (INITS
|
||
`(,INITS (MATCH ',X ,OBJECT)))
|
||
(T
|
||
`((MATCH ',X ,OBJECT))))))
|
||
PATTERNS)
|
||
,@(COND (INITS (NCONS INITS)))))
|
||
(T
|
||
(COND (INITS
|
||
`(OR ,INITS
|
||
(MATCH ',(CAR PATTERNS) ,OBJECT)
|
||
,INITS))
|
||
(T
|
||
`(MATCH ',(CAR PATTERNS) ,OBJECT)))))))
|
||
|
||
|
||
;;; Note this package has loaded
|
||
|
||
(SSTATUS FEATURE PATTERN) |