Skip to content

[200_21] 升级到Goldfish Scheme v17.11.32 #3023

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
wumoin merged 1 commit into from
Mar 23, 2026
+14,654 −3,975
Merged

[200_21] 升级到Goldfish Scheme v17.11.32 #3023

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
359 changes: 288 additions & 71 deletions TeXmacs/plugins/goldfish/goldfish/guenchi/json.scm
View file
Open in desktop

Large diffs are not rendered by default.

24 changes: 19 additions & 5 deletions TeXmacs/plugins/goldfish/goldfish/liii/alist.scm
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -8,21 +8,29 @@
(begin

(define (alist? l)
(and (list? l) (every pair? l)))
(and (list? l) (every pair? l))
) ;define

(define alist-ref
(case-lambda ((alist key) (alist-ref alist key
(lambda ()
(key-error "alist-ref: key not found " key))))
(key-error "alist-ref: key not found " key)))
) ;lambda
((alist key thunk) (alist-ref alist key thunk eqv?))
((alist key thunk =) (let ((value (assoc key alist =)))
(if value (cdr value) (thunk))))))
(if value (cdr value) (thunk)))
) ;
) ;case-lambda
) ;define

(define alist-ref/default
(case-lambda ((alist key default)
(alist-ref alist key (lambda () default)))
((alist key default =)
(alist-ref alist key (lambda () default) =))))
(alist-ref alist key (lambda () default) =)
) ;
) ;case-lambda
) ;define

; MIT License
; Copyright guenchi (c) 2018 - 2019
Expand All @@ -32,5 +40,11 @@
'()
(let loop ((x (vector->list x))
(n 0))
(cons (cons n (car x)) (if (null? (cdr x)) '() (loop (cdr x) (+ n 1))))))))))
(cons (cons n (car x)) (if (null? (cdr x)) '() (loop (cdr x) (+ n 1))))
) ;let
) ;if
) ;typed-lambda
) ;define
) ;begin
) ;define-library

110 changes: 81 additions & 29 deletions TeXmacs/plugins/goldfish/goldfish/liii/argparse.scm
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -16,12 +16,14 @@

(define-library (liii argparse)
(import (liii base) (liii error) (liii list) (liii string) (liii hash-table) (liii alist)
(liii sys))
(liii sys)
) ;import
(export make-argument-parser)
(begin

(define (make-arg-record name type short-name default)
(list name type short-name default default))
(list name type short-name default default)
) ;define

(define (convert-value value type)
(case type
Expand All @@ -31,56 +33,82 @@
(let ((num (string->number value)))
(if num
num
(error "Invalid number format" value)))))
(error "Invalid number format" value)
) ;if
) ;let
) ;if
) ;
((string) (if (string? value) value (error "Value is not a string")))
(else (error "Unsupported type" type))))
(else (error "Unsupported type" type))
) ;case
) ;define

(define (arg-type? type)
(unless (symbol? type)
(type-error "type of the argument must be symbol"))
(member type '(string number)))
(type-error "type of the argument must be symbol")
) ;unless
(member type '(string number))
) ;define

(define (%add-argument args-ht args)
(let* ((options (car args))
(name (alist-ref options 'name
(lambda ()
(value-error "name is required for an option"))))
(value-error "name is required for an option"))
) ;lambda
) ;name
(type (alist-ref/default options 'type 'string))
(short-name (alist-ref/default options 'short #f))
(default (alist-ref/default options 'default #f))
(arg-record (make-arg-record name type short-name default)))
(unless (string? name)
(type-error "name of the argument must be string"))
(type-error "name of the argument must be string")
) ;unless
(unless (arg-type? type)
(value-error "Invalid type of the argument" type))
(value-error "Invalid type of the argument" type)
) ;unless
(unless (or (not short-name)
(string? short-name))
(type-error
"short name of the argument must be string if given"))
"short name of the argument must be string if given"
) ;type-error
) ;unless
(hash-table-set! args-ht name arg-record)
(when short-name
(hash-table-set! args-ht short-name arg-record))))
(hash-table-set! args-ht short-name arg-record)
) ;when
) ;let*
) ;define

(define (%get-argument args-ht args)
(let ((found (hash-table-ref/default args-ht (car args) #f)))
(if found
(fifth found)
(error "Argument not found" (car args)))))
(error "Argument not found" (car args))
) ;if
) ;let
) ;define

(define (long-form? arg)
(and (string? arg)
(>= (string-length arg) 3)
(string-starts? arg "--")))
(string-starts? arg "--")
) ;and
) ;define

(define (short-form? arg)
(and (string? arg)
(>= (string-length arg) 2)
(char=? (string-ref arg 0) #\-)))
(char=? (string-ref arg 0) #\-)
) ;and
) ;define

(define (retrieve-args args)
(if (null? args)
(cddr (argv))
(car args)))
(car args)
) ;if
) ;define

(define (%parse-args args-ht prog-args)
(let loop ((args (retrieve-args prog-args)))
Expand All @@ -95,9 +123,14 @@
(error "Missing value for argument" name)
(begin
(let ((value (convert-value (cadr args) (cadr found))))
(set-car! (cddddr found) value))
(loop (cddr args))))
(value-error (string-append "Unknown option: --" name)))))
(set-car! (cddddr found) value)
) ;let
(loop (cddr args))
) ;begin
) ;if
(value-error (string-append "Unknown option: --" name)))
) ;if
) ;let*
((short-form? arg)
(let* ((name (substring arg 1))
(found (hash-table-ref args-ht name)))
Expand All @@ -106,22 +139,41 @@
(error "Missing value for argument" name)
(begin
(let ((value (convert-value (cadr args) (cadr found))))
(set-car! (cddddr found) value))
(loop (cddr args))))
(value-error (string-append "Unknown option: -" name)))))
(else (loop (cdr args))))))))
(set-car! (cddddr found) value)
) ;let
(loop (cddr args))
) ;begin
) ;if
(value-error (string-append "Unknown option: -" name))
) ;if
) ;let*
) ;
(else (loop (cdr args)))
) ;cond
) ;let
) ;if
) ;let
) ;define

(define (make-argument-parser)
(let ((args-ht (make-hash-table)))
(lambda (command . args)
(case command
((add) (%add-argument args-ht args))
((add-argument) (%add-argument args-ht args))
((get) (%get-argument args-ht args))
((get-argument) (%get-argument args-ht args))
((parse) (%parse-args args-ht args))
((parse-args) (%parse-args args-ht args))
((:add) (%add-argument args-ht args))
((:add-argument) (%add-argument args-ht args))
((:get) (%get-argument args-ht args))
((:get-argument) (%get-argument args-ht args))
((:parse) (%parse-args args-ht args))
((:parse-args) (%parse-args args-ht args))
(else
(if (and (null? args) (symbol? command))
(%get-argument args-ht (list (symbol->string command)))
(error "Unknown parser command" command)))))))))
(error "Unknown parser command" command)
) ;if
) ;else
) ;case
) ;lambda
) ;let
) ;define
) ;begin
) ;define-library
83 changes: 57 additions & 26 deletions TeXmacs/plugins/goldfish/goldfish/liii/array-buffer.scm
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -22,37 +22,49 @@
(define-case-class array-buffer
((data vector?)
(size integer?)
(capacity integer?))
(capacity integer?)
) ;

(chained-define (@from-vector vec)
(let ((len (vector-length vec)))
(array-buffer (copy vec) len len)))
(array-buffer (copy vec) len len)
) ;let
) ;chained-define

(chained-define (@from-list lst)
(let ((len (length lst)))
(array-buffer (copy lst (make-vector len)) len len)))
(array-buffer (copy lst (make-vector len)) len len)
) ;let
) ;chained-define

(typed-define (check-bound (n integer?))
(when (or (< n 0) (>= n size))
(index-error
($ "access No." :+ n :+ " of array-buffer [0:" :+ size :+ ")" :get))))
($ "access No." :+ n :+ " of array-buffer [0:" :+ size :+ ")" :get)
) ;index-error
) ;when
) ;typed-define

(define (%collect)
(copy data (make-vector size)))
(copy data (make-vector size))
) ;define

(define (%length) size)

(define (%apply n)
(check-bound n)
(vector-ref data n))
(vector-ref data n)
) ;define

(chained-define (%set! n v)
(check-bound n)
(vector-set! data n v)
(%this))
(%this)
) ;chained-define

(define (%update! . args)
(apply %set! args))
(apply %set! args)
) ;define

(chained-define (%extend! n)
(when (< capacity n)
Expand All @@ -61,40 +73,51 @@
(let loop ()
(when (< capacity n)
(set! capacity (* 2 capacity))
(loop))))
(set! data (copy data (make-vector capacity) 0 size)))
(%this))
(loop)
) ;when
) ;let
) ;if
(set! data (copy data (make-vector capacity) 0 size))
) ;when
(%this)
) ;chained-define

(define (%size-hint! . args) (apply %extend! args))

(chained-define (%resize! n)
(%extend! n)
(set! size n)
(%this))
(%this)
) ;chained-define

(chained-define (%trim-to-size! n)
(%extend! n)
(set! size n)
(when (> capacity (* 2 size))
(set! data (copy data (make-vector size)))
(set! capacity size))
(%this))
(set! capacity size)
) ;when
(%this)
) ;chained-define

(chained-define (%add-one! x)
(%extend! (+ size 1))
(vector-set! data size x)
(set! size (+ size 1))
(%this))
(%this)
) ;chained-define

(chained-define (%clear!)
(set! size 0)
(%this))
(%this)
) ;chained-define

(chained-define (%clear/shrink!)
(set! size 0)
(set! capacity 1)
(set! data (make-vector 1))
(%this))
(%this)
) ;chained-define

(chained-define (%insert! index elem)
(%extend! (+ size 1))
Expand All @@ -103,25 +126,33 @@
(let loop ((p (- size 1)))
(when (> p index)
(vector-set! data p (vector-ref data (- p 1)))
(loop (- p 1))))
(loop (- p 1))
) ;when
) ;let
(vector-set! data index elem)
(%this))
(%this)
) ;chained-define

(typed-define (%equals (that case-class?))
(and (that :is-instance-of 'array-buffer)
((%to-vector) :equals (that :to-vector))))
((%to-vector) :equals (that :to-vector))
) ;and
) ;typed-define

(define (%to-vector)
(rich-vector (copy data (make-vector size))))
(rich-vector (copy data (make-vector size)))
) ;define

(define (%to-list)
(vector->list data 0 size))
(vector->list data 0 size)
) ;define

(define (%to-rich-list)
(box (%to-list)))
(box (%to-list))
) ;define

) ; end of array-buffer
) ;define-case-class

) ; end of begin
) ; end of define-library
) ;begin
) ;define-library

Loading
Loading