commit 05f5626f05f02ef5dbf2e89a1e05e02aa1c45d44
parent 0181dad8864a6573203eff6e2ee7f06f59d43e5a
Author: Yuval Langer <yuval.langer@gmail.com>
Date: Sat, 25 Jan 2025 20:11:36 +0200
Add GOOPS implementation and related stuff. Also the ares server script and copyright and AGPL-3-or-later licensing.
Diffstat:
4 files changed, 175 insertions(+), 202 deletions(-)
diff --git a/ares.sh b/ares.sh
@@ -0,0 +1,6 @@
+#!/bin/sh
+
+guix shell \
+ guile-next \
+ guile-ares-rs \
+ -- guile -c '((@ (ares server) run-nrepl-server))'
diff --git a/run-tests-goops.scm b/run-tests-goops.scm
@@ -1,7 +1,21 @@
-;;; generic-ref-set --- Generic accessor and modifier operators.
+;;; run-tests-goops.scm --- Part of the guile-srfi-123 generic accessor and modifier operators library.
+;; Copyright © 2025 Yuval Langer <yuval.langer@gmail.com>
;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU Affero General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU Affero General Public License for more details.
+
+;; You should have received a copy of the GNU Affero General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
;; Permission is hereby granted, free of charge, to any person obtaining
;; a copy of this software and associated documentation files (the
;; "Software"), to deal in the Software without restriction, including
@@ -23,16 +37,18 @@
(use-modules
((scheme base) #:select (bytevector))
+
+ (rnrs exceptions)
(rnrs hashtables)
+ (rnrs records inspection)
+ (rnrs records procedural)
+ (rnrs records syntactic)
+
(srfi srfi-4)
(srfi srfi-64)
(srfi srfi-111)
(srfi srfi-123 goops)
- (rnrs records syntactic)
- (rnrs records procedural)
- (rnrs records inspection)
- (rnrs exceptions)
-)
+ )
(define using-broken-srfi99 #f)
diff --git a/srfi/srfi-123.scm b/srfi/srfi-123.scm
@@ -25,11 +25,13 @@
(export ref ref* ~ register-getter-with-setter! $bracket-apply$ set! setter getter-with-setter)
(import
(scheme base)
+ (scheme case-lambda)
+
(rnrs hashtables)
(rnrs records inspection)
(rnrs records procedural)
(rnrs records syntactic)
- (scheme case-lambda)
+
(srfi 1)
(srfi 4)
(srfi 17)
diff --git a/srfi/srfi-123/goops.scm b/srfi/srfi-123/goops.scm
@@ -1,7 +1,21 @@
-;;; generic-ref-set --- Generic accessor and modifier operators.
+;;; goops.scm --- Part of the guile-srfi-123 generic accessor and modifier operators library.
+;; Copyright © 2025 Yuval Langer <yuval.langer@gmail.com>
;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
+;; This program is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU Affero General Public License as
+;; published by the Free Software Foundation, either version 3 of the
+;; License, or (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU Affero General Public License for more details.
+
+;; You should have received a copy of the GNU Affero General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
;; Permission is hereby granted, free of charge, to any person obtaining
;; a copy of this software and associated documentation files (the
;; "Software"), to deal in the Software without restriction, including
@@ -22,7 +36,16 @@
;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
(define-library (srfi srfi-123 goops)
- (export ref ref* ~ register-getter-with-setter! $bracket-apply$ set! setter getter-with-setter)
+ (export
+ ref
+ ref*
+ ~
+ register-getter-with-setter!
+ $bracket-apply$
+ set!
+ setter
+ getter-with-setter
+ )
(import
(scheme base)
(scheme case-lambda)
@@ -32,50 +55,21 @@
(rnrs records procedural)
(rnrs records syntactic)
- (srfi 1)
- (srfi 4)
- (srfi 17)
- (srfi 26)
- (srfi 31)
- (srfi 43)
- (srfi 111)
+ (srfi srfi-1)
+ (srfi srfi-4)
+ (srfi srfi-4 gnu)
+ (srfi srfi-17)
+ (srfi srfi-26)
+ (srfi srfi-31)
+ (srfi srfi-43)
+ (srfi srfi-111)
+
+ (ice-9 match)
(oop goops)
)
(begin
-;;; Helpers
-
- (define-syntax push!
- (syntax-rules ()
- ((_ <list-var> <x>)
- (set! <list-var> (cons <x> <list-var>)))))
-
- (define (alist->hashtable alist)
- (let ((table (make-eqv-hashtable 100)))
- (for-each (lambda (entry)
- (hashtable-set! table (car entry) (cdr entry)))
- alist)
- table))
-
- (define (pair-ref pair key)
- (cond
- ((eqv? 'car key)
- (car pair))
- ((eqv? 'cdr key)
- (cdr pair))
- (else
- (list-ref pair key))))
-
- (define (pair-set! pair key value)
- (cond
- ((eqv? 'car key)
- (set-car! pair value))
- ((eqv? 'cdr key)
- (set-cdr! pair value))
- (else
- (list-set! pair key value))))
-
;;; Record inspection support
(define (rtd-field-index rtd field)
@@ -115,168 +109,123 @@ Raise an error if the field does not exist."
;;; which possibly dispatch to an SRFI-4 type's getter/setter, but also
;;; inserting the SRFI-4 getters/setters into the top-level dispatch tables.
- (define srfi-4-getters
- (list (cons s8vector? s8vector-ref)
- (cons u8vector? u8vector-ref)
- (cons s16vector? s16vector-ref)
- (cons u16vector? u16vector-ref)
- (cons s32vector? s32vector-ref)
- (cons u32vector? u32vector-ref)
- (cons s64vector? s64vector-ref)
- (cons u64vector? u64vector-ref)))
- (define srfi-4-setters
- (list (cons s8vector? s8vector-set!)
- (cons u8vector? u8vector-set!)
- (cons s16vector? s16vector-set!)
- (cons u16vector? u16vector-set!)
- (cons s32vector? s32vector-set!)
- (cons u32vector? u32vector-set!)
- (cons s64vector? s64vector-set!)
- (cons u64vector? u64vector-set!)))
- (define srfi-4-types
- (list s8vector? u8vector? s16vector? u16vector? s32vector? u32vector?
- s64vector? u64vector?))
- (define srfi-4-getters-table (alist->hashtable srfi-4-getters))
- (define srfi-4-setters-table (alist->hashtable srfi-4-setters))
- (define (bytevector-ref bytevector index)
- (let* ((type (find (lambda (pred) (pred bytevector)) srfi-4-types))
- (getter (if type
- (ref srfi-4-getters-table type)
- bytevector-u8-ref)))
- (getter bytevector index)))
- (define (bytevector-set! bytevector index value)
- (let* ((type (find (lambda (pred) (pred bytevector)) srfi-4-types))
- (setter (if type
- (ref srfi-4-setters-table type)
- bytevector-u8-set!)))
- (setter bytevector index value)))
-
-;;; SRFI-111 boxes support
-
- (define (box-ref box _field)
- (unbox box))
- (define (box-set! box _field value)
- (set-box! box value))
- (define box-getter (list (cons box? box-ref)))
- (define box-setter (list (cons box? box-set!)))
- (define box-type (list box?))
-
-;;; Main
-
- (define %ref
- (case-lambda
- ((object field)
- (let ((getter (lookup-getter object))
- (sparse? (sparse-type? object)))
- (if sparse?
- (let* ((not-found (cons #f #f))
- (result (getter object field not-found)))
- (if (eqv? result not-found)
- (error "Object has no entry for field." object field)
- result))
- (getter object field))))
- ((object field default)
- (let ((getter (lookup-getter object)))
- (getter object field default)))))
-
- (define (%ref* object field . fields)
- (if (null? fields)
- (%ref object field)
- (apply %ref* (%ref object field) fields)))
-
- (define (%set! object field value)
- (let ((setter (lookup-setter object)))
- (setter object field value)))
-
- (define ref
- (getter-with-setter
- %ref
- (lambda (object field value)
- (%set! object field value))))
+ ;; XXX: (class-of (make-u8vector 0)) is the same as (class-of (make-u16vector 0)) or any of the rest.
+ (define-method (ref (object <uvec>) field)
+ (match object
+ ((? u8vector?) (u8vector-ref object field))
+ ((? s8vector?) (s8vector-ref object field))
+ ((? u16vector?) (u16vector-ref object field))
+ ((? s16vector?) (s16vector-ref object field))
+ ((? u32vector?) (u32vector-ref object field))
+ ((? s32vector?) (s32vector-ref object field))
+ ((? u64vector?) (u64vector-ref object field))
+ ((? s64vector?) (s64vector-ref object field))
+ ((? f32vector?) (f32vector-ref object field))
+ ((? f64vector?) (f64vector-ref object field))
+ ((? c32vector?) (c32vector-ref object field))
+ ((? c64vector?) (c64vector-ref object field))
+ ((? bytevector?) (bytevector-u8-ref object field))))
+
+ (define-method ((setter ref) (object <uvec>) field value)
+ (match object
+ ((? u8vector?) (u8vector-set! object field value))
+ ((? s8vector?) (s8vector-set! object field value))
+ ((? u16vector?) (u16vector-set! object field value))
+ ((? s16vector?) (s16vector-set! object field value))
+ ((? u32vector?) (u32vector-set! object field value))
+ ((? s32vector?) (s32vector-set! object field value))
+ ((? u64vector?) (u64vector-set! object field value))
+ ((? s64vector?) (s64vector-set! object field value))
+ ((? f32vector?) (f32vector-set! object field value))
+ ((? f64vector?) (f64vector-set! object field value))
+ ((? c32vector?) (c32vector-set! object field value))
+ ((? c64vector?) (c64vector-set! object field value))
+ ((? bytevector?) (bytevector-u8-set! object field value))))
+
+;;; pairs support.
+
+ (let ((type-class (class-of (cons '() '()))))
+ (define-method (ref (object type-class) field)
+ (cond
+ ((eqv? 'car field)
+ (car object))
+ ((eqv? 'cdr field)
+ (cdr object))
+ (else
+ (list-ref object field))))
+
+ (define-method (ref (object type-class) field value)
+ (cond
+ ((eqv? 'car field)
+ (set-car! object value))
+ ((eqv? 'cdr field)
+ (set-cdr! object value))
+ (else
+ (list-set! object field value)))))
+
+;;; string support.
+
+ (define-method (ref (object <string>) field)
+ (string-ref object field))
+
+ (define-method ((setter ref) (object <string>) field value)
+ (string-set! object field value))
+ ;; Wrong type argument in position 1 (expecting symbol): (setter ref)
+
+;;; bytevector support.
+
+ (define-method (ref (object <bytevector>) field)
+ (bytevector-u8-ref object field))
+
+ (define-method ((setter ref) (object <bytevector>) field value)
+ (bytevector-u8-set! object field value))
+
+;;; vector support.
+
+ (define-method (ref (object <vector>) field)
+ (vector-ref object field))
+
+ (define-method ((setter ref) (object <vector>) field value)
+ (vector-set! object field value))
+
+ ;; hashtable support.
+
+ (define-method (ref (object <hashtable>) field default)
+ (hashtable-ref object field default))
+
+ (define-method ((setter ref) (object <hashtable>) field default)
+ (hashtable-ref object field default))
+
+;;; box support
+
+ (let ((type-class (class-of (box '()))))
+ (define-method (ref (object type-class) field)
+ (unbox object))
+ (define-method ((setter ref) (object type-class) field value)
+ (set-box! object value)))
+
+ ;; TODO:
+ ;; record?
+ ;; record-getter
(define ref*
(getter-with-setter
- %ref*
- ;; XXX: Originally it used the SRFI-31 rec construct, but it just would not compile!
- ;;
- ;; (rec (set!* object field rest0 . rest)
- ;; (if (null? rest)
- ;; (%set! object field rest0)
- ;; (apply set!* (ref object field) rest0 rest)))
- ;;
- ;;
+ (let ()
+ (define (%ref* object field . fields)
+ (if (null? fields)
+ (ref object field)
+ (apply %ref* (ref object field) fields)))
+ %ref*)
(let ()
(define (set!* object field rest0 . rest)
- (if (null? rest)
- (%set! object field rest0)
- (apply set!* (ref object field) rest0 rest)))
+ (match (cons rest0 rest)
+ ((last-field new-value)
+ (set! (ref object last-field) new-value))
+ ((rest0 rest ooo)
+ (apply set!* (ref object field) rest0 rest))))
set!*)))
(define ~ ref*)
(define $bracket-apply$ ref*)
-
- (define (lookup-getter object)
- (or (hashtable-ref getter-table (type-of object) #f)
- (error "No generic getter for object's type." object)))
-
- (define (lookup-setter object)
- (or (hashtable-ref setter-table (type-of object) #f)
- (error "No generic setter for object's type." object)))
-
- (define (sparse-type? object)
- (memv (type-of object) sparse-types))
-
- (define (type-of object)
- (find (lambda (pred) (pred object)) type-list))
-
- (define getter-table
- (alist->hashtable
- (append
- (list (cons bytevector? bytevector-ref)
- (cons hashtable? hashtable-ref)
- (cons pair? pair-ref)
- (cons string? string-ref)
- (cons vector? vector-ref))
- record-getter
- srfi-4-getters
- box-getter)))
-
- (define setter-table
- (alist->hashtable
- (append
- (list (cons bytevector? bytevector-set!)
- (cons hashtable? hashtable-set!)
- (cons pair? pair-set!)
- (cons string? string-set!)
- (cons vector? vector-set!))
- record-setter
- srfi-4-setters
- box-setter)))
-
- (define sparse-types
- (list hashtable?))
-
- (define type-list
- ;; Although the whole SRFI intrinsically neglects performance, we still use
- ;; the micro-optimization of ordering this list roughly according to most
- ;; likely match.
- (append
- (list hashtable? vector? pair? bytevector? string?)
- srfi-4-types
- box-type
- ;; The record type must be placed last so specific record types (e.g. box)
- ;; take precedence.
- record-type
- ;; Place those types we don't support really last.
- (list boolean? char? eof-object? null? number? port? procedure? symbol?)))
-
- (define (register-getter-with-setter! type getter sparse?)
- (push! type-list type)
- (set! (~ getter-table type) getter)
- (set! (~ setter-table type) (setter getter))
- (when sparse?
- (push! sparse-types type)))
))
-
-;;; srfi-123.scm ends here
