Add lexical-methods macro to define non-symbol based macros

When you're adding macros which should use content addresss
descriptions, you want to have the macro name held in a variable which
is populated based on the method description. Due to the normal
methods automatically making the method name a symbol, it needs a
different methods macro.

goblins/actor-lib/lexical-methods.rkt

@@ -0,0 +1,147 @@
+#lang racket/base
+
+;;; Copyright 2019-2021 Christine Lemmer-Webber
+;;; Copyright 2022 Jessica Tallon <tsyesika@tsyesika.se>
+;;;
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;;
+;;;    http://www.apache.org/licenses/LICENSE-2.0
+;;;
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(require (for-syntax racket/base
+                     syntax/parse
+                     racket/match)
+         racket/contract
+         "../core.rkt"
+         "select-swear.rkt")
+
+(provide lexical-methods)
+
+(define raise-method-not-found
+  (make-keyword-procedure
+   (lambda (kws kw-args method . args)
+     (error 'method-not-found "~a" method))))
+
+(define/contract (make-extends-handler extend-refr)
+  (-> live-refr? any/c)
+  (define $/<-
+    (select-$/<- extend-refr))
+  (define extends-handler
+    (make-keyword-procedure
+     (lambda (kws kw-args . args)
+       (keyword-apply $/<- kws kw-args extend-refr args))))
+  extends-handler)
+
+(define-syntax (lexical-methods stx)
+  (define-values (methods method-not-found-handler)
+    (let lp ([stx-to-process (cdr (syntax-e stx))]
+             [clauses '()]
+             [not-found-handler #f])
+      (match stx-to-process
+        ['()
+         (values (reverse clauses)
+                 (or not-found-handler
+                     #'raise-method-not-found))]
+        [(list clause rest-clauses ...)
+         (define clause-e
+           (syntax-e clause))
+         (cond
+           ;; Okay, we're setting up an fallback definition
+           [(eq? clause-e '#:extends)
+            (match rest-clauses
+              [(cons extends-refr rest-clauses)
+               (lp rest-clauses
+                   clauses
+                   extends-refr)]
+              ['()
+               (raise-syntax-error
+                'methods-invalid-extends-refr
+                "#:extends must be followed by an extension mechanism")])]
+           [else
+            (define new-clause
+              (syntax-parse clause
+                [((method-name method-args ...) body ...)
+                 #'(cons method-name
+                         (lambda (method-args ...)
+                           body ...))]
+                [((method-name method-args ... . rest) body ...)
+                 #'(cons method-name
+                         (lambda (method-args ... . rest)
+                           body ...))]
+                [(method-name proc)
+                 #'(cons method-name proc)]))
+            (lp rest-clauses
+                (cons new-clause clauses)
+                not-found-handler)])])))
+
+  #`(procedure-rename
+     (make-keyword-procedure
+      (let ([real-not-found-handler
+             ;; If it's a refr, we need to wrap it in something that will
+             ;; call the refr
+             (cond
+               [(live-refr? #,method-not-found-handler)
+                (make-extends-handler #,method-not-found-handler)]
+               [(not #,method-not-found-handler)
+                raise-method-not-found]
+               [else
+                #,method-not-found-handler])])
+        (lambda (kws kw-args method-name . args)
+          (define method
+            (assoc method-name (list #,@methods)))
+          (if method
+              (keyword-apply (cdr method) kws kw-args args)
+              (keyword-apply real-not-found-handler
+                             kws kw-args method-name args)))))
+     'methods))
+
+(module+ test
+  (require rackunit)
+
+  ;; Normally lexical methods are provided by cadifying a description.
+  (define foo 'foo-abc123)
+  (define bar 'bar-def456)
+  (define baz 'baz-ghi789)
+
+  (define some-methods
+    (lexical-methods
+     [(foo x)
+      (list 'foo x)]
+     [bar
+      (lambda (x)
+        (list 'bar x))]
+     [(baz . args)
+      (list 'baz args)]))
+  (check-equal?
+   (some-methods foo 'beep)
+   '(foo beep))
+  (check-equal?
+   (some-methods bar 'beep)
+   '(bar beep))
+  (check-equal?
+   (some-methods baz 'beep 'boop 'bop)
+   '(baz (beep boop bop)))
+
+  (define some-methods-with-custom-fallback
+    (lexical-methods
+     #:extends
+     (make-keyword-procedure
+      (lambda _ 'haha-fallback))
+     [(foo x)
+      (list 'foo x)]
+     [bar
+      (lambda (x)
+        (list 'bar x))]
+     [(baz . args)
+      (list 'baz args)]))
+
+  (check-equal?
+   (some-methods-with-custom-fallback 'blorp)
+   'haha-fallback))