From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: LdBeth Newsgroups: gmane.emacs.devel Subject: Re: pcase defuns Date: Wed, 22 Dec 2021 22:07:52 +0800 Message-ID: References: , <871r299e5j.fsf@gnu.org> Mime-Version: 1.0 (generated by SEMI-EPG 1.14.7 - "Harue") Content-Type: multipart/mixed; boundary="Multipart_Wed_Dec_22_22:07:52_2021-1" Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="38056"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: Wanderlust/2.15.9 (Almost Unreal) SEMI-EPG/1.14.7 (Harue) FLIM-LB/1.14.9 (=?ISO-8859-4?Q?Goj=F2?=) APEL-LB/10.8 EasyPG/1.0.0 Emacs/27.2 (x86_64-apple-darwin18.7.0) MULE/6.0 (HANACHIRUSATO) Cc: emacs-devel@gnu.org, Tassilo Horn To: Andrew Hyatt Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane-mx.org@gnu.org Wed Dec 22 15:11:36 2021 Return-path: Envelope-to: ged-emacs-devel@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1n02L9-0009jv-PG for ged-emacs-devel@m.gmane-mx.org; Wed, 22 Dec 2021 15:11:36 +0100 Original-Received: from localhost ([::1]:58906 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1n02L8-0001Qt-QW for ged-emacs-devel@m.gmane-mx.org; Wed, 22 Dec 2021 09:11:34 -0500 Original-Received: from eggs.gnu.org ([209.51.188.92]:46414) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1n02Hv-0005Qk-Ro for emacs-devel@gnu.org; Wed, 22 Dec 2021 09:08:15 -0500 Original-Received: from out162-62-57-210.mail.qq.com ([162.62.57.210]:51729) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1n02Hl-0004IT-0e; Wed, 22 Dec 2021 09:08:08 -0500 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=foxmail.com; s=s201512; t=1640182076; bh=7wtK3yr+awmidvWVgs004Ey82B2OTH02ETzFiojQhJY=; h=Date:From:To:Cc:Subject:In-Reply-To:References; b=h36aw6Jlla0DrWARVStN3vczacTeBVevT2os05F5QGPmBH3yZwhlMoJ2cpSEoLtYG OO6aZE/KqZZ1ERKSr6NoZ1nRHJzXsWPQB3b34VXfnelN7xVGU4q+sXxoZBUve9aJE4 fZ0LXkBSjnXt41VWanADvMworY7avpEyX+DsdLNw= Original-Received: from Costume-Party.local ([39.189.56.217]) by newxmesmtplogicsvrszc7.qq.com (NewEsmtp) with SMTP id 1F72EA87; Wed, 22 Dec 2021 22:07:55 +0800 X-QQ-mid: xmsmtpt1640182075tr8c0ji3g X-QQ-XMAILINFO: NrDiNNADEAQwzFO5sKznUdB20672Cf1+bck0VX8m7+DPB94xiBAShPuFJu5KQS sWLlv66SWKUx2zgnDHoHoHCs6MVyDWhujpYiFnXp6tjlMl+2R5ldpW4qEFKJttdmzftsN8HGtYi0 ZFZwFLpy3aFTReDgzZjn7TRhaJ1n+J6G+02BkW5aCBabnFr5aB0LtzxXJgv6XAGF/Y2PyTZuXyFT kawy5KOC6UOGoCOTumRR1/CyBFiXcfWSzVRJqDAARO5Tj6W1R04mwzpqGX+tf5/2wEY+ztaHF3TP RYq8a8KxYd8tNpasjPWwMHIaNnrIde9ByQ3iOgtL4ZsueMPboXMiYfv7c2Fgvb85gPuT9yvRlodv jJlPbLAdnfPWq6wUbii4EGjBqiQ1YDli2ffEx5N+Rjq+AnQLPrb6sXBFC6SA5gSAHG9gj1Lz7cDe VYX/04bWi/QPjw20j2mJuWKyZD6sLUCpBmYwwbKvC/yKcN1LjdooG8DKAhG/04XqDiB8RmmlFHat Ue2v+arzyYi3eVO3uXGdc8vCjEOoP+6zV+36rnvkJjgqqiGQB04jYGKFvWwrHDE6Z+/nJ/RJ5AcA 5eK/3cdeUicbmD8rhyF6N/jiRrUCFLQXK+m91KOPAJK/gCl/LmPkUaLe+vaFTF7SuipO6xKcKfx9 M//fi1sD09RFv88X2En4hFzDZPwCGcpuZo/6Tqq52dZZz0RFYQSaRxZhVe5BHUmnNaEpsbDwWu8T GI9xqblh+Ut06LNUmeyPm5ioCCkKgd8d942yggjnCJ5TS+3ZOK3OV8FqEYV1LbUVi0WepQiNBUP0 b8pLtv5/w9BBwBcFQjK78Sx17vBTCytKZphWjvKo Original-Received: by Costume-Party.local (Postfix, from userid 501) id CA749203D1B56F; Wed, 22 Dec 2021 22:07:52 +0800 (CST) X-OQ-MSGID: In-Reply-To: <871r299e5j.fsf@gnu.org> X-Face: $7|yD%Lji?.p'#Ya#/C7iZ!+-!NJjcGAgDR]\PSw$5:"t{7P+VEqKM:>~f#x)H2jckGF($uh>W~_Qc/,O|&mg(HAmk,P?*}P]1w1Y6R_Eu/njc; o>(_\1T$MB3M3oPTM:cv83P$`O)F{ID*m}x3S#}+?w!"kF@h<68U0'ti>$=J2.&mQw~Z^#:2FP(bF)(Y:}1r~W~@(5IR!|_C*Fy*gERgk6F!; m"e"hC`I; TMK1O_l&i+Ja)s9d2; {xTNv&gp/>w>#aSg)P:%$oVI*V[LFED=+xNrHX-!#}\U] X-Now-Playing: =?ISO-2022-JP?B?GyRCQEQ9QRsoQg==?= - =?ISO-2022-JP?B?GyRCQGlHLzg4QVs2PxsoQiA=?= =?EUC-KR?B?oqY=?= History of the Moon Received-SPF: pass client-ip=162.62.57.210; envelope-from=andpuke@foxmail.com; helo=out162-62-57-210.mail.qq.com X-Spam_score_int: 8 X-Spam_score: 0.8 X-Spam_bar: / X-Spam_report: (0.8 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, FREEMAIL_FROM=0.001, HELO_DYNAMIC_IPADDR=1.951, MSGID_FROM_MTA_HEADER=0.001, RCVD_IN_DNSWL_NONE=-0.0001, RCVD_IN_MSPIKE_H3=0.001, RCVD_IN_MSPIKE_WL=0.001, RDNS_DYNAMIC=0.982, SPF_HELO_NONE=0.001, SPF_PASS=-0.001 autolearn=no autolearn_force=no X-Spam_action: no action X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane-mx.org@gnu.org Original-Sender: "Emacs-devel" Xref: news.gmane.io gmane.emacs.devel:282746 Archived-At: --Multipart_Wed_Dec_22_22:07:52_2021-1 Content-Type: text/plain; charset=US-ASCII >>>>> In <871r299e5j.fsf@gnu.org> >>>>> Tassilo Horn wrote: Tassilo> Andrew Hyatt writes: Tassilo> Hi Andrew, > As a part of a personal project, I wrote a way to define functions in > an equivalent way to pcases. For example: > > (pcase-defun mytest (a b _) > "Match on 'a 'b with the third argument a wildcard" > "a b match") > > (pcase-defun mytest (c ,var _) > "Match on 'c binding VAR, with the third argument a wildcard" > (format "c %s match" var) ) > > (mytest 'a 'b 'c) -> "a b match" > (mytest 'c 100 'c) -> "c 100 match" Tassilo> So that's basically similar to cl-defgeneric / cl-defmethod just with Tassilo> pcase pattern matching, right? That reminds me of an old tiny piece of Common Lisp code from CMU AI Repository that implements single inheritance message passing OOP, which could be easily ported to Emacs Lisp. -- LDB --Multipart_Wed_Dec_22_22:07:52_2021-1 Content-Type: text/plain; name="boops.lisp"; charset=US-ASCII Content-Disposition: attachment; filename="boops.lisp" Content-Transfer-Encoding: 7bit ;;; -*-Mode: Lisp; Syntax: Common-lisp; Package: BOOPS -*- ;;; Copyright (c) 1992,1991,1990,1989,1988 Koenraad De Smedt ;;; Koenraad De Smedt ;;; Unit of Experimental and Theoretical Psychology ;;; Leiden University ;;; P.O. Box 9555 ;;; 2300 RB Leiden ;;; The Netherlands ;;; E-mail: desmedt@rulfsw.leidenuniv.nl ;;; BOOPS (Beginner's Object Oriented Programming System) is an ;;; applicative object-oriented programming system implemented as an ;;; extension of Common LISP. It is a scaled-down version of ORBIT ;;; (Steels 1983) and CommonORBIT (De Smedt 1987) modified under the ;;; influence of OOPS (Luger & Stubblefield 1989, "AI and the design ;;; of expert systems", Chapter 14). ;;; BOOPS is distributed in the hope that it will be useful, but ;;; without any warranty. No author or distributor accepts ;;; responsibility to anyone for the consequences of using it or for ;;; whether it serves any particular purpose or works at all, unless ;;; he says so in writing. ;;; Copyright Release Statement: ;;; Everyone is granted permission to copy, modify and redistribute ;;; BOOPS but only under the conditions that (1) distribution is free ;;; and without cost, (2) any modifications are also sent to the above ;;; address, and (3) this entire notice is preserved on all copies. (defpackage "BOOPS" (:use "COMMON-LISP") (:export "A" "AN" "DEFASPECT" "DEFOBJECT" "EEN" "ISA" "ISA?" "MESSAGE" "OBJECT" "SET-VALUE" "SHOW" "TRACE-MESSAGE" "UNDEFINED" "UNTRACE-MESSAGE" )) (in-package "BOOPS") ;;; ----- Print herald ----- (COND (*LOAD-VERBOSE* (TERPRI) (PRINC "BOOPS (c) 1992,1990,1989,1988 Koenraad De Smedt"))) ;;; ----- Undefined ----- (DEFCONSTANT UNDEFINED 'UNDEFINED "The value returned from an object-oriented function call when the aspect is not defined for the object.") ;;; ----- Access to internal components of objects ----- ;;; the ISA of an object is another object ;;; only single inheritance is supported (DEFMACRO OBJECT-ISA (OBJECT) "Find isa in an object." `(GET ,OBJECT 'ISA)) ;;; ASPECTS of an object are a list ;;; each aspect consists of a name and a definition ;;; a definition consists of a type and a filler (DEFMACRO OBJECT-ASPECTS (OBJECT) "Find aspects in an object." `(GET ,OBJECT 'ASPECTS)) (DEFMACRO FIND-ASPECT (OBJECT ASPECT-NAME) "Find aspect in an object." `(ASSOC ,ASPECT-NAME (OBJECT-ASPECTS ,OBJECT))) (DEFMACRO ASPECT-NAME (ASPECT) "Return the name of this aspect." `(FIRST ,ASPECT)) (DEFMACRO ASPECT-DEFINITION (ASPECT) "Return the definition of this aspect, in terms of type and filler." `(REST ,ASPECT)) (DEFMACRO ASPECT-TYPE (ASPECT-DEFINITION) "Return the type of this aspect definition." `(FIRST ,ASPECT-DEFINITION)) (DEFMACRO ASPECT-FILLER (ASPECT-DEFINITION) "Return the filler of this aspect definition." `(REST ,ASPECT-DEFINITION)) (DEFMACRO MAKE-ASPECT-DEFINITION (TYPE FILLER) "Make aspect definition with given type and filler." `(CONS ,TYPE ,FILLER)) (DEFMACRO MAKE-ASPECT (NAME TYPE FILLER) "Make aspect with given name, type and filler." `(CONS ,NAME (MAKE-ASPECT-DEFINITION ,TYPE ,FILLER))) ;;; ----- Making delegation links ----- (DEFUN ISA (OBJECT ISA) "Establish an isa relation. The OBJECT will then by default delegate all aspects to the ISA." (COND ((OR (EQ OBJECT ISA) (ISA? ISA OBJECT)) (WARN "Making ~A inherit from ~A would cause circularity." OBJECT ISA)) (T (SETF (OBJECT-ISA OBJECT) ISA)))) (DEFUN ISA? (OBJECT ISA) "True if OBJECT is indeed a object of ISA." (LET ((CURRENT-ISA (OBJECT-ISA OBJECT))) (COND ((EQ ISA CURRENT-ISA) T) ((NULL CURRENT-ISA) NIL) (T (ISA? CURRENT-ISA ISA))))) ;;; ----- Adding and removing aspects ----- (DEFUN ADD-ASPECT (OBJECT ASPECT-NAME FILLER TYPE) "Add an aspect to an object." (LET ((CURRENT-ASPECT (FIND-ASPECT OBJECT ASPECT-NAME))) (COND ((NULL CURRENT-ASPECT) ;; new aspect (SETF (OBJECT-ASPECTS OBJECT) (CONS (MAKE-ASPECT ASPECT-NAME TYPE FILLER) (OBJECT-ASPECTS OBJECT)))) (T ;there is already an aspect (LET ((CURRENT-DEFINITION (ASPECT-DEFINITION CURRENT-ASPECT))) (UNLESS (AND (EQ (ASPECT-TYPE CURRENT-DEFINITION) TYPE) (EQ (ASPECT-FILLER CURRENT-DEFINITION) FILLER)) ;; if type and filler are eq to those in current aspect, ;; do nothing ;; else replace the definition (SETF (ASPECT-DEFINITION CURRENT-ASPECT) (MAKE-ASPECT-DEFINITION TYPE FILLER))))))) ASPECT-NAME) ;;; ----- Defining aspects ----- (DEFMACRO DEFASPECT (OBJECT ASPECT-NAME &REST DEFINITION) "Define an aspect. The aspect name and object are not evaluated. This macro has the following syntax: DEFASPECT aspect object [type] filler The aspect definition is associated with the given object. If the type is omitted, the default is :VALUE. The following keywords for explicit aspect types are possible: :VALUE filler The filler can be any Lisp object which is simply returned. :FUNCTION filler or :FUNCTION ([var ...]) form ... The filler is a function which is to be applied. The filler is a function with the given lambda list and forms. :IF-NEEDED filler or :IF-NEEDED ([var ...]) form ... Like :FUNCTION but the result is to be memoized." (EXPAND-DEFASPECT ASPECT-NAME `',OBJECT DEFINITION)) (DEFUN EXPAND-DEFASPECT (ASPECT-NAME OBJECT DEFINITION) "Expansion for DEFASPECT." (COND (DEFINITION ;not an empty definition (EXPAND-ASPECT-DEFINITION `',ASPECT-NAME OBJECT (FIRST DEFINITION) (REST DEFINITION))))) (DEFUN EXPAND-ASPECT-DEFINITION (ASPECT-NAME OBJECT TYPE FILLER-LIST) "Expansion for definition in DEFASPECT." (COND ((NULL FILLER-LIST) ;implicit type :VALUE `(ADD-ASPECT ,OBJECT ,ASPECT-NAME ,TYPE :VALUE)) (T ;explicit type (CASE TYPE (:VALUE `(ADD-ASPECT ,OBJECT ,ASPECT-NAME ,(FIRST FILLER-LIST) ,TYPE)) ((:FUNCTION :IF-NEEDED) ;expand both the same `(ADD-ASPECT ,OBJECT ,ASPECT-NAME ,(COND ((NULL (REST FILLER-LIST)) ;just one element? ;; assume it contains a function (FIRST FILLER-LIST)) (T ;; assume it contains a variable list and body `#'(LAMBDA ,(FIRST FILLER-LIST) ,@(REST FILLER-LIST)))) ,TYPE)))))) ;;; ----- Defining named objects ----- (DEFMACRO DEFOBJECT (NAME ISA &BODY ASPECTS) "Define a named BOOPS object by assigning isas and defining aspects. The arguments are not evaluated. A symbol is a isa, lists are aspect definitions. Example: (DEFOBJECT WOMAN PERSON (SEX 'FEMALE)) Aspect definitions are processed as by DEFASPECT." `(PROGN (ISA ',NAME ',ISA) (SETF (OBJECT-ASPECTS ',NAME) NIL) ,@(EXPAND-ASPECT-DEFINITIONS ASPECTS `',NAME) ',NAME)) (DEFUN EXPAND-ASPECT-DEFINITIONS (ASPECT-DEFINITIONS OBJECT) "Expand isa and aspect definitions in object definition." (MAPCAR #'(LAMBDA (ASPECT-DEFINITION) (EXPAND-DEFASPECT (FIRST ASPECT-DEFINITION) OBJECT (REST ASPECT-DEFINITION))) ASPECT-DEFINITIONS)) ;;; ----- Defining anonymous objects ----- (DEFMACRO A (ISA &REST ASPECTS) "Define an anonymous BOOPS object by assigning isas and defining aspects. The arguments are not evaluated. A symbol is a isa, lists are aspect definitions. Example: (A PERSON (SEX 'FEMALE)) Aspect definitions are processed as by DEFASPECT." (LET ((OBJECT (GENSYM))) `(LET ((,OBJECT (GENSYM (STRING ',ISA)))) (ISA ,OBJECT ',ISA) ,@(EXPAND-ASPECT-DEFINITIONS ASPECTS OBJECT) ,OBJECT))) (DEFMACRO AN (ISA &REST ASPECTS) "Synonym of A." `(A ,ISA ,@ASPECTS)) (DEFMACRO EEN (ISA &REST ASPECTS) "Synonym of A for Dutch." `(A ,ISA ,@ASPECTS)) ;;; ----- Message passing ----- (DEFUN MESSAGE (OBJECT ASPECT-NAME &REST ARGS) "Message passing. Get the definition of the aspect for the object (the first argument) and if it is a function, apply that function to all the arguments." (COND ((GET ASPECT-NAME 'TRACED) (FORMAT *TRACE-OUTPUT* "~%-> ~A ~A ~A" ASPECT-NAME OBJECT ARGS))) (LET ((DEFINITION (GET-DEFINITION ASPECT-NAME OBJECT))) (LET ((TYPE (ASPECT-TYPE (FIRST DEFINITION))) (FILLER (ASPECT-FILLER (FIRST DEFINITION))) (SOURCE (SECOND DEFINITION))) ;; perform action according to type (LET ((RESULT (CASE TYPE (:VALUE FILLER) (:FUNCTION (APPLY FILLER (CONS OBJECT ARGS))) (:IF-NEEDED (SETQ FILLER ;reuse variable filler (APPLY FILLER (CONS OBJECT ARGS))) (COND ((AND SOURCE (NOT (EQ FILLER UNDEFINED))) ;; inherited and not undefined, so memoize (ADD-ASPECT OBJECT ASPECT-NAME FILLER :VALUE))) FILLER) (OTHERWISE UNDEFINED)))) (COND ((GET ASPECT-NAME 'TRACED) (FORMAT *TRACE-OUTPUT* "~%<- ~A ~A ~A" ASPECT-NAME OBJECT RESULT))) RESULT)))) ;;; ----- Retrieving the definition of an aspect for an object ----- (DEFUN GET-DEFINITION (ASPECT-NAME OBJECT) "Get the definition of an aspect for an object. Return a list of the definition and the object providing it (if found AND inherited, otherwise NIL)." (LET ((OWN-DEFINITION (ASPECT-DEFINITION (FIND-ASPECT OBJECT ASPECT-NAME)))) (COND (OWN-DEFINITION (LIST OWN-DEFINITION NIL)) (T (GET-DEFINITION-FROM-ISA ASPECT-NAME (OBJECT-ISA OBJECT)))))) (DEFUN GET-DEFINITION-FROM-ISA (ASPECT-NAME OBJECT) "Get the definition of an aspect from the isa of an object. Return a list of the definition and the object providing it or NIL." (COND ((NULL OBJECT) (LIST NIL NIL)) (T (LET ((ASPECT (FIND-ASPECT OBJECT ASPECT-NAME))) (COND (ASPECT (LIST (ASPECT-DEFINITION ASPECT) OBJECT)) (T (GET-DEFINITION-FROM-ISA ASPECT-NAME (OBJECT-ISA OBJECT)))))))) ;;; ----- Tracing messages ----- (DEFMACRO TRACE-MESSAGE (MESSAGE) "Trace a message upon receipt and return of result." `(SETF (GET ',MESSAGE 'TRACED) T)) (DEFMACRO UNTRACE-MESSAGE (MESSAGE) "Untrace a message." `(SETF (GET ',MESSAGE 'TRACED) NIL)) ;;; ----- The vanilla object ----- (DEFOBJECT OBJECT NIL (SHOW :FUNCTION #'(LAMBDA (SELF &OPTIONAL (OUTPUT-STREAM *STANDARD-OUTPUT*)) "Display a description of the object to the output stream." (COND ((OBJECT-ISA SELF) (FORMAT OUTPUT-STREAM "~&~S is a ~S" SELF (OBJECT-ISA SELF)))) (DOLIST (ASPECT (OBJECT-ASPECTS SELF)) (LET ((TYPE (ASPECT-TYPE (ASPECT-DEFINITION ASPECT))) (FILLER (ASPECT-FILLER (ASPECT-DEFINITION ASPECT)))) (FORMAT OUTPUT-STREAM "~& aspect ~A ~S = ~S" (ASPECT-NAME ASPECT) TYPE FILLER))) SELF)) (SET-VALUE :FUNCTION #'(LAMBDA (SELF ASPECT-NAME NEW-VALUE) "Give the aspect a new value." (ADD-ASPECT SELF ASPECT-NAME NEW-VALUE :VALUE) (LIST ASPECT-NAME NEW-VALUE))) ) ;;; possible extensions: ;;; - make objects inherit from vanilla object if not otherwise defined ;;; - make messages generic functions: (friend 'peter) ;;; (advantage = you can apply, map, trace etc. like normal functions) ;;; - add roles (whose 'friend 'peter) ;;; - do multiple inheritance ;;; - implement DELETE-ASPECT, NOT-ISA, etc. --Multipart_Wed_Dec_22_22:07:52_2021-1--