New version for srfi-17.

collects/srfi/17/set.rkt

@@ -1,95 +1,42 @@
-;;;
-;;; <set.ss> ---- SRFI 17 Generalized set!
-;;; Time-stamp: <02/07/22 20:28:59 solsona>
-;;;
-;;; Copyright (C) Per Bothner (1999, 2000). All Rights Reserved.
-;;; See: http://srfi.schemers.org/srfi-17/srfi-17.html
-;;;
-;;; Based on the implementation for Scheme48.
+#lang racket/base
 
-#lang scheme/base
-(provide (rename-out [my-set! s:set!])
-         setter
-         set-setter!
-         getter-with-setter)
+;; Simple implementation by Eli Barzilay,
+;;   (compatible names to the srfi version.)
 
-(define-syntax my-set!
-  (syntax-rules ()
-    ((my-set! (?e0 ?e1 ...) ?v)
-     ((setter ?e0) ?e1 ... ?v))
-    ((my-set! ?i ?v)
-     (set! ?i ?v))))
+(provide s:set! setter set-setter! getter-with-setter)
 
-(define (getter-with-setter get set)
-  (let ((proc (lambda args (apply get args))))
-    (set-setter! proc set)
-    proc))
+(require (for-syntax racket/base))
+
+(define setters (make-weak-hasheq)) ; weak => usable for local functions
 
 (define (setter proc)
-  (let ((probe (assv proc setters)))
-    (if probe
-      (cdr probe)
-      (error (object-name proc) "No setter found"))))
+  (hash-ref setters proc
+            (lambda () (error 'setter "could not find a setter for ~e" proc))))
 
 (define (set-setter! proc setter)
-  (set! setters
-        (let loop ([setters setters])
-          (cond
-            [(null? setters)
-             (list (cons proc setter))]
-            [(eqv? proc (caar setters))
-             (cons (cons proc setter)
-                   (cdr setters))]
-            [else (cons (car setters)
-                        (loop (cdr setters)))]))))
+  ;; it seems better to throw an error if a setter already exists, but I
+  ;; didn't do that to keep it compatible with the original srfi code.
+  (hash-set! setters proc setter))
 
-#|
-(define (car-setter proc)
-  (lambda (p v)
-    (set-car! (proc p) v)))
+(define-syntax (s:set! stx)
+  (syntax-case stx ()
+    [(s:set! (E0 E1 ...) V) #'((setter E0) E1 ... V)]
+    [(s:set! x V) (identifier? #'x) #'(set! x V)]))
 
-(define (cdr-setter proc)
-  (lambda (p v)
-    (set-cdr! (proc p) v)))
-|#
+(define (getter-with-setter getter setter)
+  ;; I don't see any reason why the sample version returns a wrapped
+  ;; getter function, it seems like it would kill any chance of inlining
+  ;; with any compiler (eg, the resulting arity can be different).  In
+  ;; fact, I don't see any reason for this thing at all...  (Keeping it
+  ;; just to be compatible...)
+  (set-setter! getter setter)
+  getter)
 
-(define setters
-  (list (cons setter     set-setter!)
-        (cons vector-ref vector-set!)
-        (cons string-ref string-set!)
-#|
-        (cons car        set-car!)
-        (cons cdr        set-cdr!)
-
-        (cons caar   (car-setter car))
-        (cons cdar   (cdr-setter car))
-        (cons cadr   (car-setter cdr))
-        (cons cddr   (cdr-setter cdr))
-
-        (cons caaar  (car-setter caar))
-        (cons cdaar  (cdr-setter caar))
-        (cons cadar  (car-setter cdar))
-        (cons cddar  (cdr-setter cdar))
-        (cons caadr  (car-setter cadr))
-        (cons cdadr  (cdr-setter cadr))
-        (cons caddr  (car-setter cddr))
-        (cons cdddr  (cdr-setter cddr))
-
-        (cons caaaar (car-setter caaar))
-        (cons cdaaar (cdr-setter caaar))
-        (cons cadaar (car-setter cdaar))
-        (cons cddaar (cdr-setter cdaar))
-        (cons caadar (car-setter cadar))
-        (cons cdadar (cdr-setter cadar))
-        (cons caddar (car-setter cddar))
-        (cons cdddar (cdr-setter cddar))
-        (cons caaadr (car-setter caadr))
-        (cons cdaadr (cdr-setter caadr))
-        (cons cadadr (car-setter cdadr))
-        (cons cddadr (cdr-setter cdadr))
-        (cons caaddr (car-setter caddr))
-        (cons cdaddr (cdr-setter caddr))
-        (cons cadddr (car-setter cdddr))
-        (cons cddddr (cdr-setter cdddr))
-|#
-        ))
+;; Initialize the table
+(for ([x (in-list `([,setter     ,set-setter!]
+                    [,vector-ref ,vector-set!]
+                    [,string-ref ,string-set!]
+                    [,mcar       ,set-mcar!]
+                    [,mcdr       ,set-mcdr!]
+                    [,hash-ref   ,hash-set!]))])
+  (set-setter! (car x) (cadr x)))