diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/array-buffer.scm b/TeXmacs/plugins/goldfish/goldfish/liii/array-buffer.scm deleted file mode 100644 index 5f605a88d5..0000000000 --- a/TeXmacs/plugins/goldfish/goldfish/liii/array-buffer.scm +++ /dev/null @@ -1,158 +0,0 @@ -; -; Copyright (C) 2024 The Goldfish Scheme Authors -; -; 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. -; - -(define-library (liii array-buffer) - (import (liii lang) (liii error)) - (export array-buffer) - (begin - - (define-case-class array-buffer - ((data vector?) - (size integer?) - (capacity integer?) - ) ; - - (chained-define (@from-vector vec) - (let ((len (vector-length vec))) - (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) - ) ;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) - ) ;index-error - ) ;when - ) ;typed-define - - (define (%collect) - (copy data (make-vector size)) - ) ;define - - (define (%length) size) - - (define (%apply n) - (check-bound n) - (vector-ref data n) - ) ;define - - (chained-define (%set! n v) - (check-bound n) - (vector-set! data n v) - (%this) - ) ;chained-define - - (define (%update! . args) - (apply %set! args) - ) ;define - - (chained-define (%extend! n) - (when (< capacity n) - (if (= capacity 0) - (set! capacity n) - (let loop () - (when (< capacity n) - (set! capacity (* 2 capacity)) - (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) - ) ;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) - ) ;when - (%this) - ) ;chained-define - - (chained-define (%add-one! x) - (%extend! (+ size 1)) - (vector-set! data size x) - (set! size (+ size 1)) - (%this) - ) ;chained-define - - (chained-define (%clear!) - (set! size 0) - (%this) - ) ;chained-define - - (chained-define (%clear/shrink!) - (set! size 0) - (set! capacity 1) - (set! data (make-vector 1)) - (%this) - ) ;chained-define - - (chained-define (%insert! index elem) - (%extend! (+ size 1)) - (set! size (+ size 1)) - (check-bound index) - (let loop ((p (- size 1))) - (when (> p index) - (vector-set! data p (vector-ref data (- p 1))) - (loop (- p 1)) - ) ;when - ) ;let - (vector-set! data index elem) - (%this) - ) ;chained-define - - (typed-define (%equals (that case-class?)) - (and (that :is-instance-of 'array-buffer) - ((%to-vector) :equals (that :to-vector)) - ) ;and - ) ;typed-define - - (define (%to-vector) - (rich-vector (copy data (make-vector size))) - ) ;define - - (define (%to-list) - (vector->list data 0 size) - ) ;define - - (define (%to-rich-list) - (box (%to-list)) - ) ;define - - ) ;define-case-class - - ) ;begin -) ;define-library - diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/datetime.scm b/TeXmacs/plugins/goldfish/goldfish/liii/datetime.scm deleted file mode 100644 index 94adbf3f70..0000000000 --- a/TeXmacs/plugins/goldfish/goldfish/liii/datetime.scm +++ /dev/null @@ -1,427 +0,0 @@ -; -; Copyright (C) 2024-2025 The Goldfish Scheme Authors -; -; 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. -; - -(define-library (liii datetime) - (import (liii oop) (liii error) (liii string)) - (export datetime date years days) - (begin - - (define-object years - (define (@leap? year) - (when (not (integer? year)) - (type-error "years@leap? must accept integer") - ) ;when - (or (and (zero? (modulo year 4)) - (not (zero? (modulo year 100)))) - (zero? (modulo year 400))) - ) ;or - - ;define - ) ;define-object - - (define (weekday-for-date year month day) - (let* ((m (if (> month 2) month (+ month 12))) - (y (if (> month 2) year (- year 1))) - (century (quotient y 100)) - (year-of-century (remainder y 100))) - (modulo - (- (+ day - (quotient (+ (* 13 (- m 2)) 13) 5) - year-of-century - (quotient year-of-century 4) - (quotient century 4) - (* 5 century) 6) - 3 - ) ;- - 7 - ) ;modulo - ) ;let* - ) ;define - - (define-case-class datetime - ((year integer?) - (month integer?) - (day integer?) - (hour integer? 0) - (minute integer? 0) - (second integer? 0) - (micro-second integer? 0) - ) ; - - (chained-define (@now) - (let ((time-vec (g_datetime-now))) - (datetime - :year (vector-ref time-vec 0) - :month (vector-ref time-vec 1) - :day (vector-ref time-vec 2) - :hour (vector-ref time-vec 3) - :minute (vector-ref time-vec 4) - :second (vector-ref time-vec 5) - :micro-second (vector-ref time-vec 6) - ) ;datetime - ) ;let - ) ;chained-define - - (define (%to-string) - (define (pad6 n) ; 补零到 6 位（微秒） - (let ((s (number->string n))) - (string-append (make-string (- 6 (string-length s)) #\0) s) - ) ;let - ) ;define - (if (zero? micro-second) - (%format "yyyy-MM-dd HH:mm:ss") - (string-append (%format "yyyy-MM-dd HH:mm:ss") "." (pad6 micro-second)) - ) ;if - ) ;define - - (define (%plus-days days-to-add) - - (define (days-in-month m y) - (cond ((member m '(4 6 9 11)) 30) - ((= m 2) (if (years :leap? y) 29 28)) - (else 31) - ) ;cond - ) ;define - - (let loop ((y year) - (m month) - (d day) - (remaining-days days-to-add)) - (cond - ;; No more days to add - ((zero? remaining-days) - (datetime :year y - :month m - :day d - :hour hour - :minute minute - :second second - :micro-second micro-second - ) ;datetime - ) ; - - ;; Adding days (positive) - ((> remaining-days 0) - (let ((days-in-current-month (days-in-month m y))) - (if (<= (+ d remaining-days) days-in-current-month) - ;; Simple case: result is within the same month - (loop y m (+ d remaining-days) 0) - ;; Complex case: need to move to next month - (let ((next-month (if (= m 12) 1 (+ m 1))) - (next-year (if (= m 12) (+ y 1) y))) - (loop next-year - next-month - 1 - (- (+ remaining-days d) days-in-current-month 1) - ) ;loop - ) ;let - ) ;if - ) ;let - ) ; - - ;; Subtracting days (negative) - (else - (if (> d (abs remaining-days)) - ;; Simple case: result is within the same month - (loop y m (+ d remaining-days) 0) - ;; Complex case: need to move to previous month - (let* ((prev-month (if (= m 1) 12 (- m 1))) - (prev-year (if (= m 1) (- y 1) y)) - (days-in-prev-month (days-in-month prev-month prev-year))) - (loop prev-year - prev-month - days-in-prev-month - (+ remaining-days d) - ) ;loop - ) ;let* - ) ;if - ) ;else - ) ;cond - ) ;let - ) ;define - - (define (%plus-months months-to-add) - (define (days-in-month m y) - (cond ((member m '(4 6 9 11)) 30) - ((= m 2) (if (years :leap? y) 29 28)) - (else 31) - ) ;cond - ) ;define - - ;; Calculate new year and month - (let* ((total-months (+ (+ (* year 12) month -1) months-to-add)) - (new-year (quotient total-months 12)) - (new-month (+ (remainder total-months 12) 1)) - ;; Adjust day if necessary - (days-in-new-month (days-in-month new-month new-year)) - (new-day (min day days-in-new-month))) - - (datetime :year new-year - :month new-month - :day new-day - :hour hour - :minute minute - :second second - :micro-second micro-second - ) ;datetime - ) ;let* - ) ;define - - (define (%plus-years years-to-add) - (define (days-in-month m y) - (cond ((member m '(4 6 9 11)) 30) - ((= m 2) (if (years :leap? y) 29 28)) - (else 31) - ) ;cond - ) ;define - - ;; Calculate new year - (let* ((new-year (+ year years-to-add)) - ;; Adjust day if necessary (for Feb 29 in leap years) - (days-in-new-month (days-in-month month new-year)) - (new-day (min day days-in-new-month))) - - (datetime :year new-year - :month month - :day new-day - :hour hour - :minute minute - :second second - :micro-second micro-second - ) ;datetime - ) ;let* - ) ;define - - (define (%weekday) - (weekday-for-date year month day) - ) ;define - - (define (%format format-str) - (define (pad2 n) - (if (< n 10) - (string-append "0" (number->string n)) - (number->string n) - ) ;if - ) ;define - - (define (pad3 n) - (let ((s (number->string (quotient n 1000)))) ; Convert micro-second to milli-second - (let ((len (string-length s))) - (cond ((>= len 3) (substring s 0 3)) - ((= len 2) (string-append "0" s)) - ((= len 1) (string-append "00" s)) - (else "000") - ) ;cond - ) ;let - ) ;let - ) ;define - - (define (format-is-valid? format-str) - (or (string-contains format-str "yyyy") - (string-contains format-str "MM") - (string-contains format-str "dd") - (string-contains format-str "HH") - (string-contains format-str "mm") - (string-contains format-str "ss") - (string-contains format-str "SSS") - ) ;or - ) ;define - - (unless (format-is-valid? format-str) - (value-error "datetime%format: invalid format string") - ) ;unless - - (let loop ((result "") - (remaining format-str)) - (if (string-null? remaining) - result - (cond - ((string-starts? remaining "yyyy") - (loop (string-append result (number->string year)) - (substring remaining 4 (string-length remaining)) - ) ;loop - ) ; - ((string-starts? remaining "MM") - (loop (string-append result (pad2 month)) - (substring remaining 2 (string-length remaining)) - ) ;loop - ) ; - ((string-starts? remaining "dd") - (loop (string-append result (pad2 day)) - (substring remaining 2 (string-length remaining)) - ) ;loop - ) ; - ((string-starts? remaining "HH") - (loop (string-append result (pad2 hour)) - (substring remaining 2 (string-length remaining)) - ) ;loop - ) ; - ((string-starts? remaining "mm") - (loop (string-append result (pad2 minute)) - (substring remaining 2 (string-length remaining)) - ) ;loop - ) ; - ((string-starts? remaining "ss") - (loop (string-append result (pad2 second)) - (substring remaining 2 (string-length remaining)) - ) ;loop - ) ; - ((string-starts? remaining "SSS") - (loop (string-append result (pad3 micro-second)) - (substring remaining 3 (string-length remaining)) - ) ;loop - ) ; - (else - (loop (string-append result (substring remaining 0 1)) - (substring remaining 1 (string-length remaining)) - ) ;loop - ) ;else - ) ;cond - ) ;if - ) ;let - ) ;define - - (define (%to-date) - (date :year year :month month :day day) - ) ;define - - ;define - ) ;define-case-class - - (define-case-class date - ((year integer?) - (month integer?) - (day integer?) - ) ; - - (chained-define (@now) - (let ((time-vec (g_date-now))) - (date - :year (vector-ref time-vec 0) - :month (vector-ref time-vec 1) - :day (vector-ref time-vec 2) - ) ;date - ) ;let - ) ;chained-define - - (define (%to-string) - (%format "yyyy-MM-dd") - ) ;define - - (define (%format format-str) - (let ((pad2 (lambda (n) - (if (< n 10) - (string-append "0" (number->string n)) - (number->string n)))) - ) ;if - - (unless (or (string-contains format-str "yyyy") - (string-contains format-str "MM") - (string-contains format-str "dd")) - (value-error "date%format: invalid format string") - ) ;unless - - (let loop ((result "") - (remaining format-str)) - (if (string-null? remaining) - result - (cond - ((string-starts? remaining "yyyy") - (loop (string-append result (number->string year)) - (substring remaining 4 (string-length remaining)) - ) ;loop - ) ; - ((string-starts? remaining "MM") - (loop (string-append result (pad2 month)) - (substring remaining 2 (string-length remaining)) - ) ;loop - ) ; - ((string-starts? remaining "dd") - (loop (string-append result (pad2 day)) - (substring remaining 2 (string-length remaining)) - ) ;loop - ) ; - (else - (loop (string-append result (substring remaining 0 1)) - (substring remaining 1 (string-length remaining)) - ) ;loop - ) ;else - ) ;cond - ) ;if - ) ;let - ) ;let - ) ;define - - (define (%to-datetime) - (datetime :year year :month month :day day - :hour 0 :minute 0 :second 0 :micro-second 0 - ) ;datetime - ) ;define - - (define (%weekday) - (weekday-for-date year month day) - ) ;define - - ;define - ) ;define-case-class - - - (define-object days - (define (julian-day-number year month day) - (let* ((a (quotient (- 14 month) 12)) - (y (+ year 4800 (- a))) - (m (+ month (* 12 a) (- 3))) - (jdn (+ day - (quotient (+ (* 153 m) 2) 5) - (* 365 y) - (quotient y 4) - (- (quotient y 100)) - (quotient y 400) - (- 32045))) - ) ;jdn - jdn - ) ;let* - ) ;define - - (define (@between start end) - (define (extract-date-fields obj) - (cond - ((datetime :is-type-of obj) - (list (obj 'year) (obj 'month) (obj 'day)) - ) ; - ((date :is-type-of obj) - (list (obj 'year) (obj 'month) (obj 'day)) - ) ; - (else - (type-error "days@between expects datetime or date objects") - ) ;else - ) ;cond - ) ;define - - (let* ((start-fields (extract-date-fields start)) - (end-fields (extract-date-fields end)) - (start-jdn (apply julian-day-number start-fields)) - (end-jdn (apply julian-day-number end-fields)) - (days-difference (- end-jdn start-jdn))) - days-difference - ) ;let* - ) ;define - - ) ;define-object - - ) ;begin -) ;define-library - diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/either.scm b/TeXmacs/plugins/goldfish/goldfish/liii/either.scm index 7e771ef4ba..3ded43f2fd 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/either.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/either.scm @@ -24,7 +24,7 @@ either-get-or-else either-or-else either-filter-or-else - either-contains + either-contains? either-every either-any ) ;export @@ -160,8 +160,8 @@ ) ;define ;; 包含：如果是右值且内部值等于 x - (define (either-contains either x) - (check-either either "either-contains") + (define (either-contains? either x) + (check-either either "either-contains?") (and (either-right? either) (equal? x (car either)) ) ;and @@ -225,4 +225,4 @@ ) ;begin -) ;define-library \ No newline at end of file +) ;define-library diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/lang.scm b/TeXmacs/plugins/goldfish/goldfish/liii/lang.scm deleted file mode 100644 index c5c9afce8f..0000000000 --- a/TeXmacs/plugins/goldfish/goldfish/liii/lang.scm +++ /dev/null @@ -1,232 +0,0 @@ -; -; Copyright (C) 2024 The Goldfish Scheme Authors -; -; 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. -; - -(define-library (liii lang) - - (import (only (liii base) - utf8-string-length any? receive u8-substring) - (only (liii oop) - define-case-class display* @ typed-define case-class? chained-define - define-object define-class chain-apply object->string - ) ;only - (only (liii sort) list-stable-sort vector-stable-sort) - (only (liii hash-table) - hash-table-update!/default hash-table-for-each hash-table-ref/default hash-table-contains? hash-table-delete! - hash-table-count - ) ;only - (only (liii bitwise) bitwise-and bitwise-ior arithmetic-shift) - (liii error) - (liii list) - (rename (liii rich-option) (rich-option option) (rich-none none)) - (liii rich-either) - (liii rich-list) - (liii rich-char) - (liii rich-vector) - (liii rich-string) - (liii rich-hash-table) - ) ;import - - (export - @ typed-define define-case-class define-object define-class - case-class? class=? chained-define display* object->string - option none either left right - rich-integer rich-float rich-char rich-string - rich-vector rich-list array rich-hash-table - box $ - ) ;export - (begin - - (define (class=? left right) - (cond - ((and (case-class? left) (case-class? right)) - (left :equals right) - ) ; - ((case-class? left) - (left :equals ($ right)) - ) ; - ((case-class? right) - ($ left :equals right) - ) ; - (else - (equal? left right) - ) ;else - ) ;cond - ) ;define - - (define (box x) - (cond ((integer? x) (rich-integer x)) - ((rational? x) (rich-rational x)) - ((float? x) (rich-float x)) - ((char? x) (rich-char x)) - ((string? x) (rich-string x)) - ((list? x) (rich-list x)) - ((vector? x) (rich-vector x)) - ((hash-table? x) (rich-hash-table x)) - (else (type-error "box: x must be integer?, rational?, float?, char?, string?, list?, vector?, hash-table?")) - ) ;cond - ) ;define - - #| -$ -通用装箱及方法调用器，为原始数据类型提供对象式操作接口。 - -语法 ----- -($ obj) -($ obj method arg1 arg2 ...) - -参数 ----- -obj : any -待装箱的原始数据对象。支持整数、浮点数、字符、字符串、列表、向量、哈希表等类型。 - -method : symbol -方法名称。当obj为case-class实例时，可直接调用其方法；否则通过box函数创建rich对象后再调用。 - -arg1, arg2, ... : any -方法调用的参数列表，个数取决于具体调用的方法。 - -返回值 ------ -当仅传入obj时，返回对应类型的rich对象；当调用方法时，返回方法执行结果。 - -功能 ----- -该函数是连接原始数据与丰富对象接口的桥梁。它通过box根据数据类型自动选择合适的rich-wrapper， -并支持链式调用语法。若没有额外参数，则返回rich对象本身；若有参数则使用apply执行方法调用。 - -边界条件 --------- -- 当传入未支持的类型时，抛出type-error异常 -- 空XS参数返回装箱后的rich对象实例 -- 非空XS参数执行方法调用 - -错误处理 --------- -对未支持的类型抛出type-error异常："box: x must be integer?, rational?, float?, char?, string?, list?, vector?, hash-table?" - -兼容性 ------- -- 与(liii lang)库中的所有rich类型完全兼容 -- 支持case-class实例的直接方法调用 -- 与chain-apply模式无缝协作 -|# - (define ($ x . xs) - (if (null? xs) (box x) (apply (box x) xs)) - ) ;define - - (define-case-class rich-integer ((data integer?)) - - (define (%get) data) - - (define (%to n) - (unless (integer? n) - (type-error - (format #f "In funtion #<~a ~a>: argument *~a* must be *~a*! **Got ~a**" - %to '(n) 'n "integer" (object->string n) - ) ;format - ) ;type-error - ) ;unless - (if (< n data) - (rich-list (list)) - (rich-list (iota (+ (- n data) 1) data)) - ) ;if - ) ;define - - (define (%until n) - (unless (integer? n) - (type-error - (format #f "In funtion #<~a ~a>: argument *~a* must be *~a*! **Got ~a**" - %until '(n) 'n "integer" (object->string n) - ) ;format - ) ;type-error - ) ;unless - (if (<= n data) - (rich-list (list)) - (rich-list (iota (+ (- n data)) data)) - ) ;if - ) ;define - - (define (%to-rich-char) - (rich-char data) - ) ;define - - (define (%to-string) - (number->string data) - ) ;define - - (define (@max-value) 9223372036854775807) - - (define (@min-value) -9223372036854775808) - - ;;return exact integer - (define (%sqrt) - (if (< data 0) - (value-error - (format #f "sqrt of negative integer is undefined! ** Got ~a **" data) - ) ;value-error - (inexact->exact (floor (sqrt data)))) - ) ;if - - ;define - ) ;define-case-class - - (define-case-class rich-rational ((data rational?)) - - (define (%get) data) - - (define (%abs) - (if (< data 0) - (- 0 data) - data) - ) ;if - - ;define - ) ;define-case-class - - (define-case-class rich-float ((data float?)) - - (define (%get) data) - - (define (%abs) - (if (< data 0) - (- 0 data) - data - ) ;if - ) ;define - - (define (%to-string) - (number->string data) - ) ;define - - (define (%sqrt) - (if (< data 0) - (value-error - (format #f "sqrt of negative float is undefined! ** Got ~a **" data) - ) ;value-error - (sqrt data)) - ) ;if - - ) ;define - - - (define array rich-vector) - - - - ) ;define-case-class - ) ;begin - diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/list.scm b/TeXmacs/plugins/goldfish/goldfish/liii/list.scm index 6e98521120..e9673f6490 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/list.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/list.scm @@ -48,8 +48,6 @@ (import (srfi srfi-1) (srfi srfi-13) (liii error) - (liii case) - (only (liii oop) define-case-class chain-apply) ) ;import (begin diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/logging.scm b/TeXmacs/plugins/goldfish/goldfish/liii/logging.scm deleted file mode 100644 index 741d4ff882..0000000000 --- a/TeXmacs/plugins/goldfish/goldfish/liii/logging.scm +++ /dev/null @@ -1,185 +0,0 @@ -; -; Copyright (C) 2024 The Goldfish Scheme Authors -; -; 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. -; - -(define-library (liii logging) - (import (liii lang) - (liii rich-path) - (liii datetime) - (liii error) - ) ;import - (export logging) - (begin - - (define-constant NOTSET 0) - (define-constant DEBUG 10) - (define-constant INFO 20) - (define-constant WARNING 30) - (define-constant ERROR 40) - (define-constant CRITICAL 50) - - (define loggers-registry (make-hash-table)) - (define-class logging - ((name string? "default") - (log-path string? "") - (level integer? WARNING) - ) ; - - - (define (%set-path! p) - (cond ((string? p) - (set! log-path p)) - - ((path :is-type-of p) - (set! log-path (p :to-string)) - ) ; - - (else - (type-error "path should be a string or path object") - ) ;else - ) ;cond - ) ;define - - (define (%set-level! l) - (define (check-valid-level val) - (member val '(0 10 20 30 40 50)) - ) ;define - - (cond ((integer? l) - (if (check-valid-level l) - (set! level l) - (value-error "invalid level number" l)) - ) ;if - - ((rich-integer :is-type-of l) - (if (check-valid-level (l :get)) - (set! level (l :get)) - (value-error "invalid level number" (l :get)) - ) ;if - ) ; - - (else - (type-error "level should be an integer") - ) ;else - ) ;cond - ) ;define - - (define (@apply p-name) - ;; Check if logger with this name already exists in registry - (let ((existing-logger (hash-table-ref loggers-registry p-name))) - (if (eq? existing-logger #f) - ;; If not, create a new logger and store in registry - (let ((new-logger (logging))) - (new-logger :set-name! p-name) - (hash-table-set! loggers-registry p-name new-logger) - new-logger - ) ;let - ;; If exists, return existing logger - existing-logger - ) ;if - ) ;let - ) ;define - - (define (format-timestamp) - (let ((now (datetime :now))) - (now :to-string) - ) ;let - ) ;define - - (define (print-log level-name . args) - (let* ((timestamp (format-timestamp)) - (prefix (string-append timestamp " [" level-name "] " name ": ")) - (message (apply string-append - (map (lambda (arg) - (if (string? arg) - arg - (arg :get)) - ) ;if - args)) - ) ;map - ) ;message - (let ((line (string-append prefix message "\n"))) - (if (string=? log-path "") - (display line) - (path-append-text log-path line) - ) ;if - ) ;let - ) ;let* - ) ;define - - (define (%get-level) - (cond - ((= level 0) "NOTSET") - ((= level 10) "DEBUG") - ((= level 20) "INFO") - ((= level 30) "WARNING") - ((= level 40) "ERROR") - ((= level 50) "CRITICAL") - ) ;cond - ) ;define - - (define (%debug?) - (<= level DEBUG) - ) ;define - - (define (%info?) - (<= level INFO) - ) ;define - - (define (%warning?) - (<= level WARNING) - ) ;define - - (define (%error?) - (<= level ERROR) - ) ;define - - (define (%critical?) - (<= level CRITICAL) - ) ;define - - (define (%debug . args) - (when (%debug?) - (apply print-log "DEBUG" args) - ) ;when - ) ;define - - (define (%info . args) - (when (%info?) - (apply print-log "INFO" args) - ) ;when - ) ;define - - (define (%warning . args) - (when (%warning?) - (apply print-log "WARNING" args) - ) ;when - ) ;define - - (define (%error . args) - (when (%error?) - (apply print-log "ERROR" args) - ) ;when - ) ;define - - (define (%critical . args) - (when (%critical?) - (apply print-log "CRITICAL" args)) - ) ;when - - ) ;define - - ) ;define-class - ) ;begin diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/oop.scm b/TeXmacs/plugins/goldfish/goldfish/liii/oop.scm deleted file mode 100644 index 819899cd22..0000000000 --- a/TeXmacs/plugins/goldfish/goldfish/liii/oop.scm +++ /dev/null @@ -1,725 +0,0 @@ -; -; Copyright (C) 2025 The Goldfish Scheme Authors -; -; 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. -; - -(define-library (liii oop) - (import (srfi srfi-2) (srfi srfi-1) (liii string) (liii error)) - (export - @ typed-define define-case-class define-object define-class - case-class? chained-define display* object->string - chain-apply define-final-class transform-instance-methods - ) - (begin - - (define-macro (@ . paras) - (letrec* - ( - (slot? (lambda (x) (equal? '_ x))) - (exprs (filter (lambda (x) (not (slot? x))) paras)) - (slots (filter slot? paras)) - - (exprs-sym-list (map (lambda (x) (gensym)) exprs)) - (slots-sym-list (map (lambda (x) (gensym)) slots)) - - (lets (map list exprs-sym-list exprs)) - - (parse - (lambda (exprs-sym-list slots-sym-list paras) - (cond - ((null? paras) paras) - ((not (list? paras)) paras) - ((slot? (car paras)) - `(,(car slots-sym-list) - ,@(parse exprs-sym-list (cdr slots-sym-list) (cdr paras)))) - (else - `(,(car exprs-sym-list) - ,@(parse (cdr exprs-sym-list) slots-sym-list (cdr paras)))))))) - - `(let ,lets - (lambda ,slots-sym-list - ,(parse exprs-sym-list slots-sym-list paras))))) - - (define-macro (typed-define name-and-params body . rest) - (let* ((name (car name-and-params)) - (params (cdr name-and-params)) - (param-names (map car params))) - - `(define* - (,name - ,@(map - (lambda (param) - (let ((param-name (car param)) - (type-pred (cadr param)) - (default-value (cddr param))) - (if (null? default-value) - param-name - `(,param-name ,(car default-value))))) - params)) - - ;; Runtime type check - ,@(map (lambda (param) - (let* ((param-name (car param)) - (type-pred (cadr param)) - ;;remove the '?' in 'type?' - (type-name-str - (let ((s (symbol->string type-pred))) - (if (and (positive? (string-length s)) - (char=? (string-ref s (- (string-length s) 1)) #\?)) - (substring s 0 (- (string-length s) 1)) - s)))) - - `(unless - (,type-pred ,param-name) - (type-error - (format #f "In funtion #<~a ~a>: argument *~a* must be *~a*! **Got ~a**" - ,name - ',param-names - ',param-name - ,type-name-str - (object->string ,param-name)))))) - params) - ,body - ,@rest))) - - (define-macro (define-case-class class-name fields . private-fields-and-methods) - (let* ((key-fields - (map (lambda (field) (string->symbol (string-append ":" (symbol->string (car field))))) - fields)) - - (field-names (map car fields)) - (field-count (length field-names)) - - (private-fields (filter (lambda (x) - (and (list? x) - (>= (length x) 2) - (symbol? (x 1)))) - private-fields-and-methods)) - - (methods (filter (lambda (x) - (and (list? x) - (>= (length x) 2) - (pair? (x 1)))) - private-fields-and-methods)) - - (method-names - (map (lambda (method) - (let* ((method-sym (caadr method)) - (method-name (symbol->string method-sym))) - (cond - ((string-starts? method-name "@") - (string-remove-prefix method-name "@")) - ((string-starts? method-name "%") - (string-remove-prefix method-name "%")) - (else method-name)))) - methods)) - - (conflicts-names - (filter (lambda (method-name) - (let ((name (string->symbol method-name))) - (member name field-names))) - method-names)) - - (check-conflicts-names (unless (null? conflicts-names) - (let ((conflict-str (apply string-append - (map (lambda (c) (string-append " <" c ">")) - conflicts-names)))) - (error 'syntax-error (string-append "In class [" - (symbol->string class-name) - "]: Method name" - (if (= (length conflicts-names) 1) "" "s") - conflict-str - " conflicts with field name" - (if (= (length conflicts-names) 1) "" "s")))))) - - (instance-methods - (filter (lambda (method) (string-starts? (symbol->string (caadr method)) "%")) - methods)) - (instance-method-symbols (map caadr instance-methods)) - (instance-messages - (map (lambda (method) - (let ((name (string-remove-prefix (symbol->string method) "%"))) - (string->symbol (string-append ":" name)))) - instance-method-symbols)) - (static-methods - (filter (lambda (method) (string-starts? (symbol->string (caadr method)) "@")) - methods)) - (static-method-symbols (map caadr static-methods)) - (static-messages - (map (lambda (method) - (let ((name (string-remove-prefix (symbol->string method) "@"))) - (string->symbol (string-append ":" name)))) - static-method-symbols)) - ;(default-static-messages '(:is-type-of)) - (internal-methods - (filter (lambda (method) (not (or (string-starts? (symbol->string (caadr method)) "%") - (string-starts? (symbol->string (caadr method)) "@")))) - methods)) - (this-symbol (gensym)) - (f-make-case-class (string->symbol (string-append "make-case-class-" (symbol->string class-name))))) - - `(define (,class-name . args) - - (define (@is-type-of obj) - (and (case-class? obj) - (obj :is-instance-of ',class-name))) - - ,@static-methods - - - (define (static-dispatcher msg . args) - (cond - ((eq? msg :is-type-of) (apply @is-type-of args)) - ,@(map (lambda (method expected) `((eq? msg ,expected) (apply ,method args))) - static-method-symbols static-messages) - (else (value-error "No such static method " msg)))) - - (define* (,f-make-case-class - ,@(map - (lambda (param) - (let ((param-name (car param)) - (type-pred (cadr param)) - (default-value (cddr param))) - (if (null? default-value) - param-name - `(,param-name ,(car default-value))))) - fields)) - ,@(map (lambda (param) - (let* ((param-name (car param)) - (type-pred (cadr param)) - ;;remove the '?' in 'type?' - (type-name-str - (let ((s (symbol->string type-pred))) - (if (and (positive? (string-length s)) - (char=? (string-ref s (- (string-length s) 1)) #\?)) - (substring s 0 (- (string-length s) 1)) - s)))) - - `(unless - (,type-pred ,param-name) - (type-error - (format #f "In funtion #<~a ~a>: argument *~a* must be *~a*! **Got ~a**" - ,f-make-case-class - ',field-names - ',param-name - ,type-name-str - (object->string ,param-name)))))) - fields) - - (define ,this-symbol #f) - (define (%this . xs) - (if (null? xs) - ,this-symbol - (apply ,this-symbol xs))) - - (define (%is-instance-of x) - (eq? x ',class-name)) - - (define (%equals that) - (unless (case-class? that) - (type-error - (format #f "In funtion #<~a ~a>: argument *~a* must be *~a*! **Got ~a**" - %equals '(that) 'that "case-class" (object->string that)))) - (and (that :is-instance-of ',class-name) - ,@(map (lambda (field) `(equal? ,(car field) (that ',(car field)))) - fields))) - - (define (%apply . args) - (cond ((null? args) - (value-error ,class-name "Apply on zero args is not implemented")) - ((keyword? (car args)) - (value-error ,class-name "No such method: " (car args))) - (else (value-error ,class-name "No such field: " (car args))))) - - (define (%to-string) - (let ((field-strings - (list ,@(map (lambda (field key-field) - `(string-append - ,(symbol->string key-field) " " - (object->string ,(car field)))) - fields key-fields)))) - (let loop ((strings field-strings) - (acc "")) - (if (null? strings) - (string-append "(" ,(symbol->string class-name) " " acc ")") - (loop (cdr strings) - (if (zero? (string-length acc)) - (car strings) - (string-append acc " " (car strings)))))))) - - ,@private-fields - ,@internal-methods - ,@instance-methods - - (define (instance-dispatcher) - (lambda (msg . args) - (cond - ((eq? msg :is-instance-of) (apply %is-instance-of args)) - ((eq? msg :equals) (apply %equals args)) - ((eq? msg :to-string) (%to-string)) - ((eq? msg :this) (apply %this args)) - ,@(map (lambda (field key-field) - `((eq? msg ,key-field) - (,class-name - ,@(map (lambda (f) (if (eq? (car f) (car field)) '(car args) (car f))) - fields)))) - fields key-fields) - ((keyword? msg) - (case msg - ,@(map (lambda (method expected) - `((,expected) (apply ,method args))) - instance-method-symbols instance-messages) - (else (value-error ,class-name "No such method: " msg)))) - ,@(map (lambda (field) `((eq? msg ',(car field)) ,(car field))) fields) - (else (apply %apply (cons msg args)))))) - - (set! ,this-symbol (instance-dispatcher)) - ,this-symbol - ) ; end of the internal typed define - - (if (null? args) - (,f-make-case-class) - (let ((msg (car args))) - (cond ((member msg (list ,@static-messages :is-type-of)) - (apply static-dispatcher args)) - ((and (zero? ,field-count) (member :apply (list ,@static-messages))) - (apply static-dispatcher (cons :apply args))) - (else - (apply ,f-make-case-class args))))) - - ) ; end of define - ) ; end of let - ) ; end of define-macro - - (define-macro (define-object object-name . definitions) - (let* ((static-methods (filter (lambda (def) - (and (list? def) (>= (length def) 3) - (eq? (car def) 'define) - (list? (cadr def)) - (caadr def) - (symbol? (caadr def)) - (let ((name-str (symbol->string (caadr def)))) - (and (> (string-length name-str) 0) - (char=? (string-ref name-str 0) #\@))))) - definitions)) - (method-infos (map (lambda (def-form) - (let* ((static-name-sym (caadr def-form)) - (static-name-str (symbol->string static-name-sym)) - (method-name-str (substring static-name-str 1 (string-length static-name-str))) - (dispatch-keyword (string->symbol (string-append ":" method-name-str)))) - (list dispatch-keyword static-name-sym))) - static-methods)) - (varlet-bindings (map (lambda (def-form) - (let ((defined-sym - (if (list? (cadr def-form)) - (caadr def-form) - (cadr def-form)))) - `(varlet (curlet) ',defined-sym ,defined-sym))) - definitions))) - - `(begin - (define (,object-name . msgs-and-args) - (let ((env (funclet ,object-name))) - (if (null? msgs-and-args) - (value-error (string-append "Object '" (symbol->string ',object-name) "' called with no arguments")) - (let ((msg (car msgs-and-args)) - (args (cdr msgs-and-args))) - (cond - ,@(map (lambda (info) - (let ((dispatch-key (car info)) - (static-method-sym (cadr info))) - `((eq? msg ',dispatch-key) (apply (env ',static-method-sym) args)))) - method-infos) - (else (value-error (string-append "No such static method '" - (if (symbol? msg) (symbol->string msg) (object->string msg)) - "' in object '" (symbol->string ',object-name) "'")))))))) - (with-let (funclet ,object-name) - ,@definitions - ,@varlet-bindings - #t - )))) - - (define-macro (define-class class-name private-fields . private-fields-and-methods) - (let* ((field-defs '()) - (getter-defs '()) - (setter-defs '()) - (field-names (map car private-fields)) - - ;; generate define, getter, setter - (process-fields - (map (lambda (field-spec) - (let* ((field-name (car field-spec)) - (type-pred (cadr field-spec)) - (default-value (if (>= (length field-spec) 3) - (caddr field-spec) - ''())) - (getter-name (string->symbol - (string-append "%get-" (symbol->string field-name)))) - (setter-name (string->symbol - (string-append "%set-" (symbol->string field-name) "!")))) - - (set! field-defs - (cons `(define ,field-name ,default-value) field-defs)) - - (set! getter-defs - (cons `(define (,getter-name) ,field-name) getter-defs)) - - (set! setter-defs - (cons `(typed-define (,setter-name (x ,type-pred)) - (set! ,field-name x)) - setter-defs)))) - private-fields)) - - ;; generate %equals method - (equals-def - `(define (%equals that) - (unless (case-class? that) - (type-error - (format #f "In funtion #<~a ~a>: argument *~a* must be *~a*! **Got ~a**" - %equals '(that) 'that "case-class" (object->string that)))) - (and (that :is-instance-of ',class-name) - ,@(map (lambda (field-name) - (let ((getter-name (string->symbol - (string-append ":get-" (symbol->string field-name))))) - `(equal? ,field-name (that ,getter-name)))) - field-names))))) - - `(define-case-class ,class-name () - ;; define - ,@(reverse field-defs) - - ;; Getter - ,@(reverse getter-defs) - - ;; Setter - ,@(reverse setter-defs) - - ;; %equals method - ,equals-def - - ;; else - ,@private-fields-and-methods))) - - (define (case-class? x) - (and-let* ((is-proc? (procedure? x)) - (source (procedure-source x)) - (source-at-least-3? (and (list? source) (>= (length source) 3))) - (body (source 2)) - (body-at-least-3? (and (list? body) (>= (length body) 3))) - (is-cond? (eq? (car body) 'cond)) - (pred1 ((body 1) 0)) - (pred2 ((body 2) 0))) - (and (equal? pred1 '(eq? msg :is-instance-of)) - (equal? pred2 '(eq? msg :equals))))) - - (define-macro (chained-define head . body) - (let ((xs (gensym)) - (result (gensym))) - `(define ,(append head xs) - (let ((,result (begin ,@body))) - (if (null? ,xs) - ,result - (apply ,result ,xs)))))) - - (define (chain-apply args r) - (if (null? args) - r - (apply r args))) - - (define (display* . params) - (define (%display x) - (if (case-class? x) - (display (x :to-string)) - (display x))) - (for-each %display params)) - - (define s7-object->string object->string) - - (define (object->string x) - (if (case-class? x) - (x :to-string) - (s7-object->string x))) - - ;; 转换 instance-methods 中的方法调用 - ;; 将 (%method-name args...) 转换为 ((object-name :method-name field-names) args...) - (define (transform-instance-methods methods object-name field-names) - - ;; 转换方法体中的方法调用 - (define (transform-method-body body object-name field-names) - ;; 转换表达式中的方法调用 - (define (transform-expr expr object-name field-names) - (cond - ;; 处理 (%method-name args...) 形式 - ((and (list? expr) - (>= (length expr) 1) - (symbol? (car expr)) - (string-starts? (symbol->string (car expr)) "%")) - (let* ((method-sym (car expr)) - (method-name (string-remove-prefix (symbol->string method-sym) "%")) - (method-keyword (string->symbol (string-append ":" method-name))) - (args (cdr expr))) - `((,object-name ,method-keyword ,@field-names) ,@args))) - - ;; 递归处理嵌套表达式 - ((list? expr) - (map (lambda (sub-expr) - (transform-expr sub-expr object-name field-names)) - expr)) - - ;; 其他情况直接返回 - (else expr))) - (map (lambda (expr) - (if (list? expr) - (transform-expr expr object-name field-names) - expr)) - body)) - - (map (lambda (method) - (let* ((method-def (cadr method)) - (method-name (car method-def)) - (method-params (cdr method-def)) - (method-body (cddr method)) - (transformed-body (transform-method-body method-body object-name field-names))) - `(define ,method-def - ,@transformed-body))) - methods)) - - - (define-macro (define-final-class class-name fields . private-fields-and-methods) - (let* ((key-fields - (map (lambda (field) (string->symbol (string-append ":" (symbol->string (car field))))) - fields)) - - (field-names (map car fields)) - (field-count (length field-names)) - - (methods (filter (lambda (x) - (and (list? x) - (>= (length x) 2) - (pair? (x 1)))) - private-fields-and-methods)) - - (method-names - (map (lambda (method) - (let* ((method-sym (caadr method)) - (method-name (symbol->string method-sym))) - (cond - ((string-starts? method-name "@") - (string-remove-prefix method-name "@")) - ((string-starts? method-name "%") - (string-remove-prefix method-name "%")) - (else method-name)))) - methods)) - - (conflicts-names - (filter (lambda (method-name) - (let ((name (string->symbol method-name))) - (member name field-names))) - method-names)) - - (check-conflicts-names (unless (null? conflicts-names) - (let ((conflict-str (apply string-append - (map (lambda (c) (string-append " <" c ">")) - conflicts-names)))) - (error 'syntax-error (string-append "In class [" - (symbol->string class-name) - "]: Method name" - (if (= (length conflicts-names) 1) "" "s") - conflict-str - " conflicts with field name" - (if (= (length conflicts-names) 1) "" "s")))))) - - (instance-methods - (filter (lambda (method) - (let ((method-name (symbol->string (caadr method)))) - (and (string-starts? method-name "%") - (not (equal? method-name "%equals")) - (not (equal? method-name "%apply"))))) - methods)) - (instance-method-symbols (map caadr instance-methods)) - - ;; 筛选出 %equals 和 %apply 方法 - (equals-methods - (filter (lambda (method) (equal? (symbol->string (caadr method)) "%equals")) - methods)) - (apply-methods - (filter (lambda (method) (equal? (symbol->string (caadr method)) "%apply")) - methods)) - - (instance-messages - (map (lambda (method) - (let ((name (string-remove-prefix (symbol->string method) "%"))) - (string->symbol (string-append ":" name)))) - instance-method-symbols)) - (static-methods - (filter (lambda (method) (string-starts? (symbol->string (caadr method)) "@")) - methods)) - (static-method-symbols (map caadr static-methods)) - (static-messages - (map (lambda (method) - (let ((name (string-remove-prefix (symbol->string method) "@"))) - (string->symbol (string-append ":" name)))) - static-method-symbols)) - ;(default-static-messages '(:is-type-of)) - (internal-methods - (filter (lambda (method) (not (or (string-starts? (symbol->string (caadr method)) "%") - (string-starts? (symbol->string (caadr method)) "@")))) - methods)) - (f-make-case-class (string->symbol (string-append "make-case-class-" (symbol->string class-name)))) - (object-name (string->symbol (string-append (symbol->string class-name) "-object")))) - - `(begin - (define-object ,object-name - ,@internal-methods - - (define (@to-string ,@field-names) - (define (%to-string) - (let ((field-strings - (list ,@(map (lambda (field key-field) - `(string-append - ,(symbol->string key-field) " " - (object->string ,(car field)))) - fields key-fields)))) - (let loop ((strings field-strings) - (acc "")) - (if (null? strings) - (string-append "(" ,(symbol->string class-name) " " acc ")") - (loop (cdr strings) - (if (zero? (string-length acc)) - (car strings) - (string-append acc " " (car strings)))))))) - %to-string) - - - ,@(map (lambda (method) - (let* ((method-def (cadr method)) - (method-name (car method-def)) - (method-params (cdr method-def)) - (method-body (cddr method)) - (external-method-name (string->symbol (string-append "@" (string-remove-prefix (symbol->string method-name) "%"))))) - `(define (,external-method-name ,@field-names) - ,method - ,method-name))) - (transform-instance-methods instance-methods object-name field-names))) - - (define (,class-name . args) - - (define (@is-type-of obj) - (and (case-class? obj) - (obj :is-instance-of ',class-name))) - - ,@static-methods - - - (define (static-dispatcher msg . args) - (cond - ((eq? msg :is-type-of) (apply @is-type-of args)) - ,@(map (lambda (method expected) `((eq? msg ,expected) (apply ,method args))) - static-method-symbols static-messages) - (else (value-error "No such static method " msg)))) - - (define* (,f-make-case-class - ,@(map - (lambda (param) - (let ((param-name (car param)) - (type-pred (cadr param)) - (default-value (cddr param))) - (if (null? default-value) - param-name - `(,param-name ,(car default-value))))) - fields)) - ,@(map (lambda (param) - (let* ((param-name (car param)) - (type-pred (cadr param)) - ;;remove the '?' in 'type?' - (type-name-str - (let ((s (symbol->string type-pred))) - (if (and (positive? (string-length s)) - (char=? (string-ref s (- (string-length s) 1)) #\?)) - (substring s 0 (- (string-length s) 1)) - s)))) - - `(unless - (,type-pred ,param-name) - (type-error - (format #f "In funtion #<~a ~a>: argument *~a* must be *~a*! **Got ~a**" - ,f-make-case-class - ',field-names - ',param-name - ,type-name-str - (object->string ,param-name)))))) - fields) - - (define (%is-instance-of x) - (eq? x ',class-name)) - - (define (%equals that) - (unless (case-class? that) - (type-error - (format #f "In funtion #<~a ~a>: argument *~a* must be *~a*! **Got ~a**" - %equals '(that) 'that "case-class" (object->string that)))) - (and (that :is-instance-of ',class-name) - ,@(map (lambda (field) `(equal? ,(car field) (that ',(car field)))) - fields))) - - (define (%apply . args) - (cond ((null? args) - (value-error ,class-name "Apply on zero args is not implemented")) - ((keyword? (car args)) - (value-error ,class-name "No such method: " (car args))) - (else (value-error ,class-name "No such field: " (car args))))) - - ,@equals-methods - ,@apply-methods - - (define (instance-dispatcher) - (lambda (msg . args) - (cond - ((eq? msg :is-instance-of) (apply %is-instance-of args)) - ((eq? msg :equals) (apply %equals args)) - ((eq? msg :apply) (apply %apply args)) - ((eq? msg :to-string) (apply (,object-name :to-string ,@field-names))) - ,@(map (lambda (field key-field) - `((eq? msg ,key-field) - (,class-name - ,@(map (lambda (f) (if (eq? (car f) (car field)) '(car args) (car f))) - fields)))) - fields key-fields) - ((keyword? msg) - (case msg - ,@(map (lambda (method expected) - `((,expected) (apply (,object-name ,expected ,@field-names) args))) - instance-method-symbols instance-messages) - (else (value-error ,class-name "No such method: " msg)))) - ,@(map (lambda (field) `((eq? msg ',(car field)) ,(car field))) fields) - (else (apply %apply (cons msg args)))))) - - (instance-dispatcher)) ; end of the internal typed define - - (if (null? args) - (,f-make-case-class) - (let ((msg (car args))) - (cond ((member msg (list ,@static-messages :is-type-of)) - (apply static-dispatcher args)) - ((and (zero? ,field-count) (member :apply (list ,@static-messages))) - (apply static-dispatcher (cons :apply args))) - (else - (apply ,f-make-case-class args))))) - - ) ; end of define - ) ; end of let - ) ; end of define-macro - ) - ) ; end of begin -) ; end of define-library diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/path.scm b/TeXmacs/plugins/goldfish/goldfish/liii/path.scm index 4d309249e0..65eab4d3da 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/path.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/path.scm @@ -16,14 +16,14 @@ (define-library (liii path) (export - path path-from-string + path path? path-copy path-dir? path-file? path-exists? path-getsize path-read-text path-read-bytes path-write-text path-append-text path-touch path-root path-of-drive path-from-parts path-from-env path-cwd path-home path-temp-dir - path-parts path-type path-drive path-copy - path->string path-to-string + path-parts path-type path-drive + path->string path-from-string path-name path-stem path-suffix path-equals? path=? path-absolute? path-relative? @@ -34,213 +34,634 @@ (import (liii base) (liii error) (liii os) - (prefix (liii rich-path) rich-) + (liii string) + (liii vector) + (scheme base) ) ;import (begin - (define (normalize-string-path value) - (if (os-windows?) - (string-map (lambda (ch) - (if (char=? ch #\/) - #\\ - ch - ) ;if - ) ;lambda - value - ) ;string-map - value - ) ;if + ;;; Path record type + (define-record-type + (make-path-record parts type drive) + path? + (parts path-record-parts path-record-set-parts!) + (type path-record-type path-record-set-type!) + (drive path-record-drive path-record-set-drive!) + ) ;define-record-type + + (define (string-split-vec str sep) + (let loop ((chars (string->list str)) + (current '()) + (result '())) + (cond + ((null? chars) + (list->vector (reverse (cons (list->string (reverse current)) result))) + ) ; + ((char=? (car chars) sep) + (loop (cdr chars) '() (cons (list->string (reverse current)) result)) + ) ; + (else + (loop (cdr chars) (cons (car chars) current) result) + ) ;else + ) ;cond + ) ;let ) ;define - (define (path-object? value) - (rich-path :is-type-of value) + ;;; Parse string path into parts + ;; For absolute paths like "/home/da", the first part is "" to indicate leading / + ;; On Windows, also handles backslash as separator + (define (parse-path-string s) + (cond + ((string-null? s) #(".")) + ((string=? s ".") #(".")) + ((string=? s "/") #("/")) + ((string=? s "\\") #("\\")) + (else + (let ((sep (os-sep))) + ;; Normalize path: replace / with \ on Windows, then split + (let ((normalized (if (os-windows?) + (string-replace s "/" "\\") + s))) + (if (and (> (string-length normalized) 0) + (char=? (string-ref normalized 0) sep)) + ;; Absolute path: start with empty string part + (let ((parts (string-split-vec normalized sep))) + (if (or (vector-empty? parts) + (not (string-null? (vector-ref parts 0)))) + (vector-append #("" ) parts) + parts + ) ;if + ) ;let + ;; Relative path + (string-split-vec normalized sep) + ) ;if + ) ;let + ) ;let + ) ;else + ) ;cond ) ;define - (define (path->object value func-name) - (cond ((path-object? value) value) - ((string? value) (rich-path (normalize-string-path value))) - (else - (type-error (string-append func-name ": path must be string or path")) - ) ;else - ) ;cond + ;;; Check if string is a Windows absolute path with drive letter + (define (windows-path-with-drive? s) + (and (>= (string-length s) 2) + (char-alphabetic? (string-ref s 0)) + (char=? (string-ref s 1) #\:) + ) ;and + ) ;define + + ;;; Extract drive letter from Windows path string + (define (extract-drive s) + (string (char-upcase (string-ref s 0))) + ) ;define + + ;;; Parse Windows path string into parts + (define (parse-windows-path s) + (let ((sep (os-sep))) + (if (and (> (string-length s) 2) + (or (char=? (string-ref s 2) #\\) + (char=? (string-ref s 2) #\/)) + ) ;or + ;; Absolute Windows path like "C:\Users\..." + (let* ((rest (substring s 3 (string-length s))) + (parts (if (string-null? rest) + #() + (string-split-vec rest sep))) + ) ;parts + parts + ) ;let* + ;; Relative to drive like "C:file.txt" + (string-split-vec s sep) + ) ;if + ) ;let ) ;define - (define (path->input-string value func-name) - (cond ((path-object? value) (value :to-string)) - ((string? value) (normalize-string-path value)) + ;;; Create a path object + (define (path . args) + (if (null? args) + (make-path-record #(".") 'posix "") + (let ((arg (car args))) + (cond + ((string? arg) + (if (windows-path-with-drive? arg) + ;; Windows path with drive letter like "C:\Users" + (let ((parts (parse-windows-path arg)) + (drive (extract-drive arg))) + (make-path-record parts 'windows drive) + ) ;let + ;; Regular path - use platform-specific type + (let ((parts (parse-path-string arg)) + (type (if (os-windows?) 'windows 'posix))) + (make-path-record parts type "") + ) ;let + ) ;if + ) ; + ((path? arg) + (path-copy arg) + ) ; (else - (type-error (string-append func-name ": path must be string or path")) + (type-error "path: argument must be string or path") ) ;else - ) ;cond + ) ;cond + ) ;let + ) ;if ) ;define - (define* (path (value ".")) - (if (path-object? value) - (value :copy) - (path->object value "path") + ;;; Copy a path object + (define (path-copy p) + (if (path? p) + (make-path-record + (vector-copy (path-record-parts p)) + (path-record-type p) + (path-record-drive p) + ) ;make-path-record + (type-error "path-copy: argument must be path") ) ;if - ) ;define* - - (define path-from-string path) - - (define (path-dir? value) - (rich-path-dir? (path->input-string value "path-dir?")) ) ;define - (define (path-file? value) - (rich-path-file? (path->input-string value "path-file?")) + ;;; Get parts as vector + (define (path-parts p) + (if (path? p) + (vector-copy (path-record-parts p)) + (type-error "path-parts: argument must be path") + ) ;if ) ;define - (define (path-exists? value) - (rich-path-exists? (path->input-string value "path-exists?")) + ;;; Get type ('posix or 'windows) + (define (path-type p) + (if (path? p) + (path-record-type p) + (type-error "path-type: argument must be path") + ) ;if ) ;define - (define (path-getsize value) - (rich-path-getsize (path->input-string value "path-getsize")) + ;;; Get drive letter (for Windows paths) + (define (path-drive p) + (if (path? p) + (path-record-drive p) + (type-error "path-drive: argument must be path") + ) ;if ) ;define - (define (path-read-text value) - (rich-path-read-text (path->input-string value "path-read-text")) + ;;; Convert path to string + (define (path->string p) + (cond + ((path? p) + (let ((parts (path-record-parts p)) + (type (path-record-type p)) + (drive (path-record-drive p))) + (case type + ((posix) + (if (vector-empty? parts) + "" + (let ((first (vector-ref parts 0))) + ;; POSIX type paths always use forward slash + (parts->string parts "/") + ) ;let + ) ;if + ) ; + ((windows) + (let ((s (parts->string parts "\\"))) + (if (string-null? drive) + s + (string-append drive ":\\" s) + ) ;if + ) ;let + ) ; + (else + (value-error "path->string: unknown type") + ) ;else + ) ;case + ) ;let + ) ; + ((string? p) + p + ) ; + (else + (type-error "path->string: argument must be path or string") + ) ;else + ) ;cond ) ;define - (define (path-read-bytes value) - (rich-path-read-bytes (path->input-string value "path-read-bytes")) + (define (path-from-string s) + (path s) + ) ;define + + ;;; Helper: convert parts vector to string + ;;; For absolute paths, first part is "" or "/" which should result in leading / + (define (parts->string parts sep) + (let ((len (vector-length parts))) + (if (= len 0) + "" + (let ((first (vector-ref parts 0))) + (cond + ;; Absolute path indicated by empty first part + ((string-null? first) + (if (= len 1) + sep + (let loop ((i 1) (result "")) + (if (>= i len) + result + (let ((part (vector-ref parts i))) + (if (string-null? result) + (loop (+ i 1) (string-append sep part)) + (loop (+ i 1) (string-append result sep part)) + ) ;if + ) ;let + ) ;if + ) ;let + ) ;if + ) ; + ;; Absolute path indicated by "/" as first part (from path-from-parts) + ((string=? first "/") + (if (= len 1) + sep + ;; Join remaining parts with sep, then prepend / + (let loop ((i 1) (result "")) + (if (>= i len) + (string-append sep result) + (let ((part (vector-ref parts i))) + (if (string-null? result) + (loop (+ i 1) part) + (loop (+ i 1) (string-append result sep part)) + ) ;if + ) ;let + ) ;if + ) ;let + ) ;if + ) ; + ;; Relative path + (else + (let loop ((i 0) (result "")) + (if (>= i len) + result + (let ((part (vector-ref parts i))) + (if (string-null? result) + (loop (+ i 1) part) + (loop (+ i 1) (string-append result sep part)) + ) ;if + ) ;let + ) ;if + ) ;let + ) ;else + ) ;cond + ) ;let + ) ;if + ) ;let ) ;define - (define (path-write-text value content) - (if (not (string? content)) - (type-error "path-write-text: content must be string") - (rich-path-write-text (path->input-string value "path-write-text") content) - ) ;if + ;;; Check if two paths are equal + (define (path-equals? p1 p2) + (let ((s1 (path->string (path p1))) + (s2 (path->string (path p2)))) + (string=? s1 s2) + ) ;let ) ;define - (define (path-append-text value content) - (if (not (string? content)) - (type-error "path-append-text: content must be string") - (rich-path-append-text (path->input-string value "path-append-text") content) - ) ;if - ) ;define + (define path=? path-equals?) - (define (path-touch value) - (rich-path-touch (path->input-string value "path-touch")) + ;;; Check if path is absolute + (define (path-absolute? p) + (if (path? p) + (let ((type (path-record-type p)) + (drive (path-record-drive p)) + (parts (path-record-parts p))) + (case type + ((windows) + ;; Windows absolute path has a drive letter + (not (string-null? drive)) + ) ; + ((posix) + ;; POSIX absolute path starts with empty part (leading /) or is just "/" + (and (> (vector-length parts) 0) + (let ((first (vector-ref parts 0))) + (or (string-null? first) + (string=? first "/") + ) ;or + ) ;let + ) ;and + ) ; + (else #f) + ) ;case + ) ;let + (let ((s (path->string p))) + (cond + ((os-windows?) + (and (>= (string-length s) 2) + (char=? (string-ref s 1) #\:) + ) ;and + ) ; + (else + (and (> (string-length s) 0) + (char=? (string-ref s 0) (os-sep)) + ) ;and + ) ;else + ) ;cond + ) ;let + ) ;if ) ;define - (define (path-root) - (rich-path :root) + ;;; Check if path is relative + (define (path-relative? p) + (not (path-absolute? p)) + ) ;define + + ;;; Get the last component of path (filename) + (define (path-name p) + (let ((s (path->string p))) + ;; Handle special cases: empty string and "." both represent current dir + (if (or (string-null? s) (string=? s ".")) + "" + (let ((sep (os-sep))) + (let loop ((i (- (string-length s) 1))) + (cond + ((< i 0) s) + ((char=? (string-ref s i) sep) + (substring s (+ i 1) (string-length s)) + ) ; + (else (loop (- i 1))) + ) ;cond + ) ;let + ) ;let + ) ;if + ) ;let ) ;define - (define (path-of-drive ch) - (rich-path :of-drive ch) + ;;; Get the stem (filename without extension) + (define (path-stem p) + (let ((name (path-name p))) + (let ((splits (string-split name #\.))) + (let ((count (length splits))) + (cond + ((<= count 1) name) + ((string=? name ".") "") + ((string=? name "..") "..") + ((and (string=? (car splits) "") + (= count 2)) + name + ) ; + (else + ;; Take all parts except the last one and join with "." + (let loop ((i 0) (result "")) + (if (>= i (- count 1)) + result + (let ((part (list-ref splits i))) + (if (string-null? result) + (loop (+ i 1) part) + (loop (+ i 1) (string-append result "." part)) + ) ;if + ) ;let + ) ;if + ) ;let + ) ;else + ) ;cond + ) ;let + ) ;let + ) ;let ) ;define - (define (path-from-parts x) - (rich-path :from-parts x) + ;;; Get the suffix (file extension) + (define (path-suffix p) + (let ((name (path-name p))) + (let ((splits (string-split name #\.))) + (let ((count (length splits))) + (cond + ((<= count 1) "") + ((string=? name ".") "") + ((string=? name "..") "") + ((and (string=? (car splits) "") + (= count 2)) + "" + ) ; + (else + (string-append "." (list-ref splits (- count 1))) + ) ;else + ) ;cond + ) ;let + ) ;let + ) ;let ) ;define - (define (path-from-env name) - (rich-path :from-env name) + ;;; Join paths + (define (path-join base . segments) + (let ((sep (string (os-sep)))) + (let loop ((result (path->string base)) + (rest segments)) + (if (null? rest) + result + (let ((part (path->string (car rest)))) + (if (or (string-null? result) + (string-ends? result sep)) + (loop (string-append result part) (cdr rest)) + (loop (string-append result sep part) (cdr rest)) + ) ;if + ) ;let + ) ;if + ) ;let + ) ;let ) ;define - (define (path-cwd) - (rich-path :cwd) + ;;; Get parent directory + (define (path-parent p) + (let ((s (path->string p))) + (let ((sep (os-sep))) + ;; First, remove trailing separator if present (except for root) + (let ((s-trimmed + (if (and (> (string-length s) 1) + (char=? (string-ref s (- (string-length s) 1)) sep)) + (substring s 0 (- (string-length s) 1)) + s)) + ) ;if + (let loop ((i (- (string-length s-trimmed) 1))) + (cond + ((< i 0) + (if (os-windows?) (path "") (path ".")) + ) ; + ((char=? (string-ref s-trimmed i) sep) + (if (= i 0) + (path-root) + ;; Keep the trailing separator for the parent path + (path (substring s-trimmed 0 (+ i 1))) + ) ;if + ) ; + (else (loop (- i 1))) + ) ;cond + ) ;let + ) ;let + ) ;let + ) ;let ) ;define - (define (path-home) - (rich-path :home) + ;;; Path predicates and operations (work with strings or paths) + (define (path-dir? p) + (g_isdir (path->string p)) ) ;define - (define (path-temp-dir) - (rich-path :temp-dir) + (define (path-file? p) + (g_isfile (path->string p)) ) ;define - (define (path-parts value) - ((path->object value "path-parts") :get-parts) + (define (path-exists? p) + (file-exists? (path->string p)) ) ;define - (define (path-type value) - ((path->object value "path-type") :get-type) + (define (path-getsize p) + (let ((s (path->string p))) + (if (not (file-exists? s)) + (file-not-found-error + (string-append "No such file or directory: '" s "'") + ) ;file-not-found-error + (g_path-getsize s) + ) ;if + ) ;let ) ;define - (define (path-drive value) - ((path->object value "path-drive") :get-drive) + (define (path-read-text p) + (let ((s (path->string p))) + (if (not (file-exists? s)) + (file-not-found-error + (string-append "No such file or directory: '" s "'") + ) ;file-not-found-error + (g_path-read-text s) + ) ;if + ) ;let ) ;define - (define (path-copy value) - ((path->object value "path-copy") :copy) + (define (path-read-bytes p) + (let ((s (path->string p))) + (if (not (file-exists? s)) + (file-not-found-error + (string-append "No such file or directory: '" s "'") + ) ;file-not-found-error + (g_path-read-bytes s) + ) ;if + ) ;let ) ;define - (define (path->string value) - (path->input-string value "path->string") + (define (path-write-text p content) + (if (not (string? content)) + (type-error "path-write-text: content must be string") + (g_path-write-text (path->string p) content) + ) ;if ) ;define - (define path-to-string path->string) - - (define (path-name value) - ((path->object value "path-name") :name) + (define (path-append-text p content) + (g_path-append-text (path->string p) content) ) ;define - (define (path-stem value) - ((path->object value "path-stem") :stem) + (define (path-touch p) + (g_path-touch (path->string p)) ) ;define - (define (path-suffix value) - ((path->object value "path-suffix") :suffix) + ;;; Static path constructors + (define (path-root) + (make-path-record #("/") 'posix "") ) ;define - (define (path-equals? left right) - ((path->object left "path-equals?") :equals (path->object right "path-equals?")) + (define (path-of-drive ch) + (if (char? ch) + (make-path-record #() 'windows (string (char-upcase ch))) + (type-error "path-of-drive: argument must be char") + ) ;if ) ;define - (define path=? path-equals?) - - (define (path-absolute? value) - ((path->object value "path-absolute?") :absolute?) + (define (path-from-parts parts) + (if (vector? parts) + (if (and (> (vector-length parts) 0) + (string? (vector-ref parts 0)) + (windows-path-with-drive? (vector-ref parts 0))) + ;; Windows path with drive letter like "C:" + (let* ((drive-str (vector-ref parts 0)) + (drive (extract-drive drive-str)) + ;; Build result parts without drive part + (clean-parts (let loop ((i 1) + (result '())) + (if (>= i (vector-length parts)) + (list->vector (reverse result)) + (let ((part (vector-ref parts i))) + ;; Skip empty parts and separator parts + (if (or (string-null? part) + (string=? part "/") + (string=? part "\\")) + (loop (+ i 1) result) + (loop (+ i 1) (cons part result)))) + ) ;if + ) ;let + ) ;if + ) ;clean-parts + (make-path-record clean-parts 'windows drive) + ) ;let* + ;; Regular POSIX-style path + (make-path-record (vector-copy parts) 'posix "") + ) ;if + (type-error "path-from-parts: argument must be vector") + ) ;if ) ;define - (define (path-relative? value) - ((path->object value "path-relative?") :relative) + (define (path-from-env name) + (path (getenv name)) ) ;define - (define (path-join base . segments) - (let loop ((acc (path->object base "path-join")) - (rest segments)) - (if (null? rest) - acc - (loop (acc :/ (car rest)) (cdr rest)) - ) ;if - ) ;let + (define (path-cwd) + (path (getcwd)) ) ;define - (define (path-parent value) - (let* ((path-value (path->object value "path-parent")) - (parent (path-value :parent))) - (if (and (os-windows?) - (string=? (parent :to-string) "") - (path-relative? path-value) - ) ;and - (path ".") - parent - ) ;if - ) ;let* + (define (path-home) + (cond + ((or (os-linux?) (os-macos?)) + (path (getenv "HOME")) + ) ; + ((os-windows?) + (path (string-append (getenv "HOMEDRIVE") (getenv "HOMEPATH"))) + ) ; + (else + (value-error "path-home: unknown platform") + ) ;else + ) ;cond ) ;define - (define (path-list value) - (listdir (path->string value)) + (define (path-temp-dir) + (path (os-temp-dir)) ) ;define - (define (path-list-path value) - (vector-map - (lambda (entry) (path-join (path->object value "path-list-path") entry)) - (path-list value) - ) ;vector-map + ;;; List directory contents + (define (path-list p) + (listdir (path->string p)) ) ;define - (define (path-rmdir value) - ((path->object value "path-rmdir") :rmdir) + ;;; List directory contents as path objects + (define (path-list-path p) + (let ((base (path->string p))) + (let ((entries (listdir base))) + (vector-map + (lambda (entry) (path-join base entry)) + entries + ) ;vector-map + ) ;let + ) ;let ) ;define - (define* (path-unlink value (missing-ok #f)) - ((path->object value "path-unlink") :unlink missing-ok) + ;;; Remove directory + (define (path-rmdir p) + (rmdir (path->string p)) + ) ;define + + ;;; Remove file + (define* (path-unlink p (missing-ok #f)) + (let ((s (path->string p))) + (cond + ((file-exists? s) + (remove s) + ) ; + (missing-ok + #t + ) ;missing-ok + (else + (error 'file-not-found-error + (string-append "File not found: " s) + ) ;error + ) ;else + ) ;cond + ) ;let ) ;define* ) ;begin diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/range.scm b/TeXmacs/plugins/goldfish/goldfish/liii/range.scm index d9501ae08a..f3db660391 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/range.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/range.scm @@ -24,8 +24,5 @@ range-any range-every range-filter->list range-remove->list range-reverse range-map->vector range-filter->vector range-remove->vector vector->range range->list range->vector - range->string range->generator)) - (begin - ; (liii range) 重新导出 (srfi srfi-196) 的所有函数 - ) -) + range->string range->generator) +) ;define-library diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/rich-char.scm b/TeXmacs/plugins/goldfish/goldfish/liii/rich-char.scm deleted file mode 100644 index c450aad980..0000000000 --- a/TeXmacs/plugins/goldfish/goldfish/liii/rich-char.scm +++ /dev/null @@ -1,158 +0,0 @@ -; -; Copyright (C) 2025 The Goldfish Scheme Authors -; -; 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. -; - -(define-library (liii rich-char) - (import (liii oop) (liii bitwise) (liii base) (liii string) (liii unicode)) - (export rich-char) - (begin - - (define-case-class rich-char ((data any?)) - - (define code-point - (cond ((char? data) - (char->integer data)) - ((integer? data) - (if (and (>= data 0) (<= data #x10FFFF)) - data - (value-error "rich-char: code point out of range" data) - ) ;if - ) ; - (else - (type-error "rich-char: only accept char and integer") - ) ;else - ) ;cond - ) ;define - - (define (%equals that) - (cond ((char? that) - (= code-point (char->integer that))) - ((rich-char :is-type-of that) - (= code-point (that :to-integer)) - ) ; - (else #f) - ) ;cond - ) ;define - - (define (%ascii?) - (and (>= code-point 0) (<= code-point 127)) - ) ;define - - - (define (%numeric?) - (if (and (>= code-point 0) (<= code-point 255)) - (let ((ch (integer->char code-point))) - (char-numeric? ch) - ) ;let - #f - ) ;if - ) ;define - - (define (%upper?) - (and (>= code-point #x41) (<= code-point #x5A)) - ) ;define - - (define (%lower?) - (and (>= code-point #x61) (<= code-point #x7A)) - ) ;define - - (define (%digit?) - (or - (and (>= code-point 48) (<= code-point 57)) - (and (>= code-point #xFF10) (<= code-point #xFF19)) - (and (>= code-point #x0660) (<= code-point #x0669)) - (and (>= code-point #x06F0) (<= code-point #x06F9)) - (and (>= code-point #x0966) (<= code-point #x096F)) - (and (>= code-point #x09E6) (<= code-point #x09EF)) - (and (>= code-point #x0A66) (<= code-point #x0A6F)) - (and (>= code-point #x0AE6) (<= code-point #x0AEF)) - (and (>= code-point #x0B66) (<= code-point #x0B6F)) - (and (>= code-point #x0BE6) (<= code-point #x0BEF)) - (and (>= code-point #x0C66) (<= code-point #x0C6F)) - (and (>= code-point #x0CE6) (<= code-point #x0CEF)) - (and (>= code-point #x0D66) (<= code-point #x0D6F)) - (and (>= code-point #x0E50) (<= code-point #x0E59)) - (and (>= code-point #x0ED0) (<= code-point #x0ED9)) - (and (>= code-point #x0F20) (<= code-point #x0F29)) - (and (>= code-point #x1040) (<= code-point #x1049)) - (and (>= code-point #x17E0) (<= code-point #x17E9)) - (and (>= code-point #x1810) (<= code-point #x1819)) - ) ;or - ) ;define - - (define (%to-upper . args) - (chain-apply args - (rich-char - (if (and (>= code-point #x61) (<= code-point #x7A)) - (bitwise-and code-point #b11011111) - code-point - ) ;if - ) ;rich-char - ) ;chain-apply - ) ;define - - (define (%to-lower . args) - (chain-apply args - (rich-char - (if (and (>= code-point #x41) (<= code-point #x5A)) - (bitwise-ior code-point #b00100000) - code-point - ) ;if - ) ;rich-char - ) ;chain-apply - ) ;define - - (define (%to-bytevector) - (codepoint->utf8 code-point) - ) ;define - - (define (@from-bytevector x) - (rich-char (utf8->codepoint x)) - ) ;define - - (define (%to-string) - (if (%ascii?) - (object->string (integer->char code-point)) - (string-append "#\\" (utf8->string (%to-bytevector))) - ) ;if - ) ;define - - (define (@from-string x) - (when (not (string-starts? x "#\\")) - (value-error "char@from-string: the input must start with #\\") - ) ;when - (if (= 1 ($ x :drop 2 :length)) - (rich-char :from-bytevector (string->utf8 ($ x :drop 2 :get))) - (value-error "rich-char: must be u8 string which length equals 1") - ) ;if - ) ;define - - (define (%make-string) - (utf8->string (%to-bytevector)) - ) ;define - - (define (@from-integer x . args) - (chain-apply args - (rich-char x) - ) ;chain-apply - ) ;define - - (define (%to-integer) - code-point) - - ) ;define - - ) ;define-case-class - ) ;begin \ No newline at end of file diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/rich-either.scm b/TeXmacs/plugins/goldfish/goldfish/liii/rich-either.scm deleted file mode 100644 index 2166045cbf..0000000000 --- a/TeXmacs/plugins/goldfish/goldfish/liii/rich-either.scm +++ /dev/null @@ -1,161 +0,0 @@ -; -; Copyright (C) 2025 The Goldfish Scheme Authors -; -; 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. -; - -(define-library (liii rich-either) - (import (rename (liii rich-option) (rich-option option) (rich-none none)) - (liii oop) (liii base)) - (export rich-either left right) - (begin - - (define-case-class rich-either - ((type symbol?) - (value any?) - ) ; - - (define (%left?) - (eq? type 'left) - ) ;define - - (define (%right?) - (eq? type 'right) - ) ;define - - (define (%get) - value - ) ;define - - (define (%or-else default) - (when (not (rich-either :is-type-of default)) - (type-error "The first parameter of either%or-else must be a either case class") - ) ;when - - (if (%right?) - (%this) - default - ) ;if - ) ;define - - (define (%get-or-else default) - (cond ((%right?) value) - ((and (procedure? default) (not (case-class? default))) - (default) - ) ; - (else default) - ) ;cond - ) ;define - - (define (%filter-or-else pred zero) - (unless (procedure? pred) - (type-error - (format #f "In funtion #<~a ~a>: argument *~a* must be *~a*! **Got ~a**" - %filter-or-else '(pred zero) 'pred "procedure" (object->string pred) - ) ;format - ) ;type-error - ) ;unless - - (unless (any? zero) - (type-error - (format #f "In funtion #<~a ~a>: argument *~a* must be *~a*! **Got ~a**" - %filter-or-else '(pred zero) 'zero "any" (object->string zero) - ) ;format - ) ;type-error - ) ;unless - (if (%right?) - (if (pred value) - (%this) - (left zero) - ) ;if - (%this) - ) ;if - ) ;define - - (define (%contains x) - (and (%right?) - (class=? x value) - ) ;and - ) ;define - - (define (%for-each f) - (when (%right?) - (f value) - ) ;when - ) ;define - - (define (%to-option) - (if (%right?) - (option value) - (none) - ) ;if - ) ;define - - (define (%map f . args) - (chain-apply args - (if (%right?) - (right (f value)) - (%this) - ) ;if - ) ;chain-apply - ) ;define - - (define (%flat-map f . args) - (chain-apply args - (if (%right?) - (f value) - (%this) - ) ;if - ) ;chain-apply - ) ;define - - (define (%forall pred) - (unless (procedure? pred) - (type-error - (format #f "In funtion #<~a ~a>: argument *~a* must be *~a*! **Got ~a**" - %forall '(pred) 'pred "procedure" (object->string pred) - ) ;format - ) ;type-error - ) ;unless - (if (%right?) - (pred value) - #t - ) ;if - ) ;define - - (define (%exists pred) - (unless (procedure? pred) - (type-error - (format #f "In funtion #<~a ~a>: argument *~a* must be *~a*! **Got ~a**" - %exists '(pred) 'pred "procedure" (object->string pred) - ) ;format - ) ;type-error - ) ;unless - (if (%right?) - (pred value) - #f) - ) ;if - - ) ;define - - (define (left v) - (rich-either 'left v) - ) ;define - - (define (right v) - (rich-either 'right v) - ) ;define - - - ) ;define-case-class - ) ;begin diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/rich-hash-table.scm b/TeXmacs/plugins/goldfish/goldfish/liii/rich-hash-table.scm deleted file mode 100644 index 6348217365..0000000000 --- a/TeXmacs/plugins/goldfish/goldfish/liii/rich-hash-table.scm +++ /dev/null @@ -1,141 +0,0 @@ -; -; Copyright (C) 2025 The Goldfish Scheme Authors -; -; 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. -; - -(define-library (liii rich-hash-table) - (import (liii hash-table) (liii oop) (rename (liii rich-option) (rich-option option) (rich-none none)) (srfi srfi-8)) - (export rich-hash-table) - (begin - - (define-case-class rich-hash-table ((data hash-table?)) - (define (%collect) data) - - (chained-define (@empty) - (rich-hash-table (make-hash-table)) - ) ;chained-define - - (define (%find pred?) - (define iter (make-iterator data)) - (let loop ((kv (iter))) - (cond - ((eof-object? kv) (none)) - ((and (pair? kv) (pred? (car kv) (cdr kv))) (option kv)) - (else (loop (iter))) - ) ;cond - ) ;let - ) ;define - - (define (%get k) - (option (hash-table-ref/default data k '())) - ) ;define - - (define (%remove k) - (rich-hash-table - (let ((new (make-hash-table))) - (hash-table-for-each - (lambda (key val) - (unless (equal? key k) - (hash-table-set! new key val) - ) ;unless - ) ;lambda - data - ) ;hash-table-for-each - new - ) ;let - ) ;rich-hash-table - ) ;define - - (chained-define (%remove! k) - (hash-table-delete! data k) - %this - ) ;chained-define - - (define (%contains k) - (hash-table-contains? data k) - ) ;define - - (define (%forall pred?) - (let ((all-kv (map identity data))) - (let loop ((kvs all-kv)) - (if (null? kvs) - #t - (let ((kv (car kvs))) - (if (pred? (car kv) (cdr kv)) - (loop (cdr kvs)) - #f - ) ;if - ) ;let - ) ;if - ) ;let - ) ;let - ) ;define - - (define (%exists pred?) - (define iter (make-iterator data)) - (let loop ((kv (iter))) - (cond - ((eof-object? kv) #f) - ((and (pair? kv) (pred? (car kv) (cdr kv))) #t) - (else (loop (iter))) - ) ;cond - ) ;let - ) ;define - - (define (%map f . args) - (chain-apply args - (let ((r (make-hash-table))) - (hash-table-for-each - (lambda (k v) - (receive (k1 v1) (f k v) - (hash-table-set! r k1 v1) - ) ;receive - ) ;lambda - data - ) ;hash-table-for-each - (rich-hash-table r) - ) ;let - ) ;chain-apply - ) ;define - - (define (%count pred) - (hash-table-count pred data) - ) ;define - - (define (%for-each proc) - (hash-table-for-each proc data) - ) ;define - - (define (%filter f . args) - (chain-apply args - (let ((r (make-hash-table))) - (hash-table-for-each - (lambda (k v) - (when (f k v) (hash-table-set! r k v)) - ) ;lambda - data - ) ;hash-table-for-each - (rich-hash-table r) - ) ;let - ) ;chain-apply - ) ;define - - (define (%size) - (hash-table-size data) - ) ;define - - ) ;define-case-class - - ) ;begin -) ;define-library diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/rich-json.scm b/TeXmacs/plugins/goldfish/goldfish/liii/rich-json.scm deleted file mode 100644 index 698133660f..0000000000 --- a/TeXmacs/plugins/goldfish/goldfish/liii/rich-json.scm +++ /dev/null @@ -1,200 +0,0 @@ -; -; Copyright (C) 2026 The Goldfish Scheme Authors -; -; 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. -; - -(define-library (liii rich-json) -(import (liii base) (liii lang) (guenchi json)) -(export - rich-json - json-string-escape json-string-unescape string->json json->string - json-ref json-ref* - json-set json-set* json-push json-push* json-drop json-drop* json-reduce json-reduce* -) ;export -(begin - -(define-class rich-json - ((data any? #f)) - - (define (%get) - data - ) ;define - - (define (%get-or-else default) - (if (%null?) - default - data - ) ;if - ) ;define - - (typed-define (%get-string (key any?) (default string?)) - (let ((r (json-ref data key))) - (if (string? r) r default) - ) ;let - ) ;typed-define - - (typed-define (%get-number (key any?) (default number?)) - (let ((r (json-ref data key))) - (if (number? r) r default) - ) ;let - ) ;typed-define - - (typed-define (%get-boolean (key any?) (default boolean?)) - (let ((r (json-ref data key))) - (if (boolean? r) r default) - ) ;let - ) ;typed-define - - (define (%keys) - (if (not (%object?)) - '() - ((box data) :map car :collect) - ) ;if - ) ;define - - (define (%apply x . xs) - (@make (apply json-ref* (cons data (cons x xs)))) - ) ;define - - (define (%set x . xs) - (let ((processed-xs (map (lambda (arg) - (if (case-class? arg) - (arg :get) - arg) - ) ;if - xs))) - (rich-json (apply json-set* (cons data (cons x processed-xs)))) - ) ;let - ) ;define - - (define (%transform key . args) - (if (null? args) - (%this) - (let ((more-keys ($ args :drop-right 1 :collect)) - (all-args (append (list data key) args))) - (if (null? more-keys) - (rich-json (apply json-reduce all-args)) - (rich-json (apply json-reduce* all-args)) - ) ;if - ) ;let - ) ;if - ) ;define - - (define (%drop key . args) - (if (null? args) - (rich-json (json-drop data key)) - (rich-json (apply json-drop* (append (list data key) args))) - ) ;if - ) ;define - - (define (%push x . xs) - (let ((processed-xs (map (lambda (arg) - (if (case-class? arg) - (arg :get) - arg) - ) ;if - xs))) - (@make (apply json-push* (cons data (cons x processed-xs)))) - ) ;let - ) ;define - - (define (%null?) - (eq? data 'null) - ) ;define - - (define (%object?) - (and (list? data) (not (null? data))) - ) ;define - - (define (%contains-key? key) - (if (not (%object?)) - #f - ((box data) - :exists (lambda (x) (equal? (car x) key)) - ) ; - ) ;if - ) ;define - - (define (%array?) - (vector? data) - ) ;define - - (define (%string?) - (string? data) - ) ;define - - (define (%number?) - (number? data) - ) ;define - - (define (%integer?) - (integer? data) - ) ;define - - (define (%float?) - (float? data) - ) ;define - - (define (%boolean?) - (boolean? data) - ) ;define - - - (define (%to-string) - (cond ((integer? data) (number->string data)) - ((symbol? data) (symbol->string data)) - ((string? data) data) - (else (json->string data)) - ) ;cond - ) ;define - - (chained-define (@null) - (rich-json 'null) - ) ;chained-define - - (chained-define (@true) - (rich-json 'true) - ) ;chained-define - - (chained-define (@false) - (rich-json 'false) - ) ;chained-define - - (chained-define (@parse s) - (@apply (string->json s)) - ) ;chained-define - - (chained-define (@apply x) - (let ((j (rich-json))) - (cond - ((string? x) (j :set-data! x)) - ((null? x) (j :set-data! 'null)) - ((boolean? x) (if x (j :set-data! 'true) (j :set-data! 'false))) - ((number? x) (j :set-data! x)) - ((procedure? x) - (type-error "rich-json: a procedure could not be converted to rich-json case class") - ) ; - (else (j :set-data! x)) - ) ;cond - j - ) ;let - ) ;chained-define - - (chained-define (@make x) - (@apply x) - ) ;chained-define -) ;define-class - -) ;begin -) ;define-library \ No newline at end of file diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/rich-list.scm b/TeXmacs/plugins/goldfish/goldfish/liii/rich-list.scm deleted file mode 100644 index 7fb46ca9fe..0000000000 --- a/TeXmacs/plugins/goldfish/goldfish/liii/rich-list.scm +++ /dev/null @@ -1,586 +0,0 @@ -; -; Copyright (C) 2025 The Goldfish Scheme Authors -; -; 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. -; - -(define-library (liii rich-list) - (import (liii list) - (liii oop) - (liii sort) - (liii hash-table) - (liii string) - (rename (liii rich-option) (rich-option option) (rich-none none)) - (srfi srfi-8) - (liii error) - ) ;import - (export rich-list) - (begin - - - (define-final-class rich-list ((data list?)) - - (define (@range start end . step-and-args) - (chain-apply (if (null? step-and-args) - step-and-args - (if (number? (car step-and-args)) - (cdr step-and-args) - step-and-args) - ) ;if - (let ((step-size - (if (null? step-and-args) - 1 - (if (number? (car step-and-args)) - (car step-and-args) - 1)) - ) ;if - ) ;if - (cond - ((and (positive? step-size) (>= start end)) - (rich-list '()) - ) ; - ((and (negative? step-size) (<= start end)) - (rich-list '()) - ) ; - ((zero? step-size) - (value-error "Step size cannot be zero") - ) ; - (else - (let ((cnt (ceiling (/ (- end start) step-size)))) - (rich-list (iota cnt start step-size)) - ) ;let - ) ;else - ) ;cond - ) ;let - ) ;chain-apply - ) ;define - - (define (@empty . args) - (chain-apply args - (rich-list (list )) - ) ;chain-apply - ) ;define - - (define (@concat lst1 lst2 . args) - (chain-apply args - (rich-list (append (lst1 :collect) (lst2 :collect))) - ) ;chain-apply - ) ;define - - (define (@fill n elem) - (cond - ((< n 0) - (value-error "n cannot be negative") - ) ; - ((= n 0) - (rich-list '()) - ) ; - (else - (rich-list (make-list n elem)) - ) ;else - ) ;cond - ) ;define - - (define (%collect) data) - - (define (%apply n) - (list-ref data n) - ) ;define - - (define (%find pred) - (let loop ((lst data)) - (cond - ((null? lst) (none)) - ((pred (car lst)) (option (car lst))) - (else (loop (cdr lst))) - ) ;cond - ) ;let - ) ;define - - (define (%find-last pred) - (let ((reversed-list (reverse data))) ; 先反转列表 - (let loop ((lst reversed-list)) - (cond - ((null? lst) (none)) ; 遍历完未找到 - ((pred (car lst)) (option (car lst))) ; 找到第一个匹配项（即原列表最后一个） - (else (loop (cdr lst))) ; 继续查找 - ) ;cond - ) ;let - ) ;let - ) ;define - - (define (%head) - (if (null? data) - (error 'out-of-range "rich-list%head: list is empty") - (car data) - ) ;if - ) ;define - - (define (%head-option) - (if (null? data) - (none) - (option (car data)) - ) ;if - ) ;define - - - (define (%last) - (if (null? data) - (index-error "rich-list%last: empty list") - (car (reverse data)) - ) ;if - ) ;define - - (define (%last-option) - (if (null? data) - (none) - (option (car (reverse data))) - ) ;if - ) ;define - - (define (%slice from until . args) - (chain-apply args - (let* ((len (length data)) - (start (max 0 (min from len))) - (end (max 0 (min until len)))) - (if (< start end) - (rich-list (take (drop data start) (- end start))) - (rich-list '()) - ) ;if - ) ;let* - ) ;chain-apply - ) ;define - - (define (%empty?) - (null? data) - ) ;define - - (define (%equals that) - (let* ((l1 data) - (l2 (that 'data)) - (len1 (length l1)) - (len2 (length l2))) - (if (not (eq? len1 len2)) - #f - (let loop ((left l1) (right l2)) - (cond ((null? left) #t) - ((not (class=? (car left) (car right))) #f) - (else (loop (cdr left) (cdr right))) - ) ;cond - ) ;let - ) ;if - ) ;let* - ) ;define - - (define (%forall pred) - (every pred data) - ) ;define - - (define (%exists pred) - (any pred data) - ) ;define - - (define (%contains elem) - (%exists (lambda (x) (equal? x elem))) - ) ;define - - (define (%map x . args) - (chain-apply args - (rich-list (map x data)) - ) ;chain-apply - ) ;define - - (define (%flat-map x . args) - (chain-apply args - (rich-list (flat-map x data)) - ) ;chain-apply - ) ;define - - (define (%filter x . args) - (chain-apply args - (rich-list (filter x data)) - ) ;chain-apply - ) ;define - - (define (%for-each x) - (for-each x data) - ) ;define - - (define (%reverse . args) - (chain-apply args - (rich-list (reverse data)) - ) ;chain-apply - ) ;define - - (define (%take x . args) - (chain-apply args - (rich-list (list-take data x)) - ) ;chain-apply - ) ;define - - (define (%drop x . args) - (chain-apply args - (rich-list (list-drop data x)) - ) ;chain-apply - ) ;define - - (define (%take-right x . args) - (chain-apply args - (rich-list (list-take-right data x)) - ) ;chain-apply - ) ;define - - (define (%drop-right x . args) - (chain-apply args - (rich-list (list-drop-right data x)) - ) ;chain-apply - ) ;define - - (define (%count . xs) - (cond ((null? xs) (length data)) - ((length=? 1 xs) (count (car xs) data)) - (else (error 'wrong-number-of-args "rich-list%count" xs)) - ) ;cond - ) ;define - - (define (%length) - (length data) - ) ;define - - (define (%fold initial f) - (fold f initial data) - ) ;define - - (define (%fold-right initial f) - (fold-right f initial data) - ) ;define - - (define (%sort-with less-p . args) - (chain-apply args - (let ((sorted-data (list-stable-sort less-p data))) - (rich-list sorted-data) - ) ;let - ) ;chain-apply - ) ;define - - (define (%sort-by f . args) - (chain-apply args - (let ((sorted-data (list-stable-sort (lambda (x y) (< (f x) (f y))) data))) - (rich-list sorted-data) - ) ;let - ) ;chain-apply - ) ;define - - (define (%group-by func) - (let ((group (make-hash-table))) - (for-each - (lambda (elem) - (let ((key (func elem))) - (hash-table-update!/default - group - key - (lambda (current-list) (cons elem current-list)) - '() - ) ;hash-table-update!/default - ) ;let - ) ;lambda - data - ) ;for-each - (hash-table-for-each - (lambda (k v) (hash-table-set! group k (reverse v))) - group - ) ;hash-table-for-each - (rich-hash-table group) - ) ;let - ) ;define - - (define (%sliding size . step-arg) - (unless (integer? size) (type-error "rich-list%sliding: size must be an integer " size)) - (unless (> size 0) (value-error "rich-list%sliding: size must be a positive integer " size)) - - (let ((N (length data))) - (if (null? data) - #() - (let* ((is-single-arg-case (null? step-arg)) - (step (if is-single-arg-case 1 (car step-arg)))) - - (when (and (not is-single-arg-case) - (or (not (integer? step)) (<= step 0))) - (if (not (integer? step)) - (type-error "rich-list%sliding: step must be an integer " step) - (value-error "rich-list%sliding: step must be a positive integer " step) - ) ;if - ) ;when - - (if (and is-single-arg-case (< N size)) - (vector data) - (let collect-windows ((current-list-segment data) (result-windows '())) - (cond - ((null? current-list-segment) (list->vector (reverse result-windows))) - ((and is-single-arg-case (< (length current-list-segment) size)) - (list->vector (reverse result-windows)) - ) ; - (else - (let* ((elements-to-take (if is-single-arg-case - size - (min size (length current-list-segment)))) - (current-window (take current-list-segment elements-to-take)) - (next-list-segment (if (>= step (length current-list-segment)) - '() - (drop current-list-segment step))) - ) ;next-list-segment - (collect-windows next-list-segment - (cons current-window result-windows) - ) ;collect-windows - ) ;let* - ) ;else - ) ;cond - ) ;let - ) ;if - ) ;let* - ) ;if - ) ;let - ) ;define - - (define (%zip l . args) - (chain-apply args - (rich-list (apply map cons (list data l))) - ) ;chain-apply - ) ;define - - (define (%zip-with-index . args) - (chain-apply args - (let loop ((lst data) (idx 0) (result '())) - (if (null? lst) - (rich-list (reverse result)) - (loop (cdr lst) - (+ idx 1) - (cons (cons idx (car lst)) result) - ) ;loop - ) ;if - ) ;let - ) ;chain-apply - ) ;define - - (define (%distinct . args) - (chain-apply args - (let loop - ((result '()) - (data data) - (ht (make-hash-table)) - ) ; - (cond - ((null? data) (rich-list (reverse result))) - (else - (let ((elem (car data))) - (if (eq? (hash-table-ref ht elem) #f) - (begin - (hash-table-set! ht elem #t) - (loop (cons elem result) (cdr data) ht) - ) ;begin - (loop result (cdr data) ht) - ) ;if - ) ;let - ) ;else - ) ;cond - ) ;let - ) ;chain-apply - ) ;define - - (define (%reduce f) - (if (null? data) - (value-error "rich-list%reduce: empty list is not allowed to reduce") - (reduce f '() data) - ) ;if - ) ;define - - (define (%reduce-option f) - (if (null? data) - (none) - (option (reduce f '() data)) - ) ;if - ) ;define - - (define (%take-while pred . args) - (chain-apply args - (let ((result (take-while pred data))) - (rich-list result) - ) ;let - ) ;chain-apply - ) ;define - - (define (%drop-while pred . args) - (chain-apply args - (let ((result (drop-while pred data))) - (rich-list result) - ) ;let - ) ;chain-apply - ) ;define - - (define (%index-where pred) - (list-index pred data) - ) ;define - - (define (%max-by f) - (unless (procedure? f) - (type-error - (format #f "In funtion #<~a ~a>: argument *~a* must be *~a*! **Got ~a**" - %max-by '(f) 'f "procedure" (object->string f) - ) ;format - ) ;type-error - ) ;unless - (if (null? data) - (value-error "rich-list%max-by: empty list is not allowed") - (let loop ((rest (cdr data)) - (max-elem (car data)) - (max-val (let ((val (f (car data)))) - (unless (real? val) - (type-error "rich-list%max-by: procedure must return real number but got" - (object->string val) - ) ;type-error - ) ;unless - val)) - ) ;max-val - (if (null? rest) - max-elem - (let* ((current (car rest)) - (current-val (let ((val (f current))) - (unless (real? val) - (type-error "rich-list%max-by: procedure must return real number but got" - (object->string val) - ) ;type-error - ) ;unless - val)) - ) ;current-val - (if (> current-val max-val) - (loop (cdr rest) current current-val) - (loop (cdr rest) max-elem max-val) - ) ;if - ) ;let* - ) ;if - ) ;let - ) ;if - ) ;define - - (define (%min-by f) - (unless (procedure? f) - (type-error - (format #f "In funtion #<~a ~a>: argument *~a* must be *~a*! **Got ~a**" - %min-by '(f) 'f "procedure" (object->string f) - ) ;format - ) ;type-error - ) ;unless - (if (null? data) - (value-error "rich-list%min-by: empty list is not allowed") - (let loop ((rest (cdr data)) - (min-elem (car data)) - (min-val (let ((val (f (car data)))) - (unless (real? val) - (type-error "rich-list%min-by: procedure must return real number but got" - (object->string val) - ) ;type-error - ) ;unless - val)) - ) ;min-val - (if (null? rest) - min-elem - (let* ((current (car rest)) - (current-val (let ((val (f current))) - (unless (real? val) - (type-error "rich-list%min-by: procedure must return real number but got" - (object->string val) - ) ;type-error - ) ;unless - val)) - ) ;current-val - (if (< current-val min-val) - (loop (cdr rest) current current-val) - (loop (cdr rest) min-elem min-val) - ) ;if - ) ;let* - ) ;if - ) ;let - ) ;if - ) ;define - - (define (%append l) - (rich-list (append data l)) - ) ;define - - (define (%max-by-option f) - (if (null? data) - (none) - (option (%max-by f)) - ) ;if - ) ;define - - (define (%min-by-option f) - (if (null? data) - (none) - (option (%min-by f)) - ) ;if - ) ;define - - (define (%to-string) - (object->string data) - ) ;define - - (define (%make-string . xs) - (define (parse-args xs) - (cond - ((null? xs) (values "" "" "")) - ((length=? 1 xs) - (let ((sep (car xs))) - (if (string? sep) - (values "" sep "") - (type-error "rich-list%make-string: separator must be a string" sep) - ) ;if - ) ;let - ) ; - ((length=? 2 xs) - (error 'wrong-number-of-args "rich-list%make-string: expected 0, 1, or 3 arguments, but got 2" xs) - ) ; - ((length=? 3 xs) - (let ((start (car xs)) - (sep (cadr xs)) - (end (caddr xs))) - (if (and (string? start) (string? sep) (string? end)) - (values start sep end) - (error 'type-error "rich-list%make-string: prefix, separator, and suffix must be strings" xs) - ) ;if - ) ;let - ) ; - (else (error 'wrong-number-of-args "rich-list%make-string: expected 0, 1, or 3 arguments" xs)) - ) ;cond - ) ;define - - (receive (start sep end) (parse-args xs) - (let ((as-string (lambda (x) (if (string? x) x (object->string x))))) - (string-append start (string-join (map as-string data) sep) end) - ) ;let - ) ;receive - ) ;define - - (define (%to-vector) - (list->vector data) - ) ;define - - (define (%to-rich-vector) - (rich-vector (list->vector data)) - ) ;define - - ) ;define-final-class - - - ) ;begin -) ;define-library diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/rich-option.scm b/TeXmacs/plugins/goldfish/goldfish/liii/rich-option.scm deleted file mode 100644 index 17656d80be..0000000000 --- a/TeXmacs/plugins/goldfish/goldfish/liii/rich-option.scm +++ /dev/null @@ -1,123 +0,0 @@ -; -; Copyright (C) 2025 The Goldfish Scheme Authors -; -; 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. -; - -(define-library (liii rich-option) - (import (liii oop) (liii base)) - (export rich-option rich-none) - (begin - - (define-final-class rich-option ((value any?)) - - (define (%get) - (if (null? value) - (value-error "option is empty, cannot get value") - value - ) ;if - ) ;define - - (define (%get-or-else default) - (cond ((not (null? value)) value) - ((and (procedure? default) (not (case-class? default))) - (default) - ) ; - (else default) - ) ;cond - ) ;define - - (define (%or-else default . args) - (when (not (rich-option :is-type-of default)) - (type-error "The first parameter of rich-option%or-else must be a rich-option case class") - ) ;when - - (chain-apply args - (if (null? value) - default - (rich-option value) - ) ;if - ) ;chain-apply - ) ;define - - (define (%equals that) - (and (rich-option :is-type-of that) - (class=? value (that 'value)) - ) ;and - ) ;define - - (define (%defined?) (not (null? value))) - - (define (%empty?) - (null? value) - ) ;define - - (define (%forall f) - (if (null? value) - #f - (f value) - ) ;if - ) ;define - - (define (%exists f) - (if (null? value) - #f - (f value) - ) ;if - ) ;define - - (define (%contains elem) - (if (null? value) - #f - (equal? value elem) - ) ;if - ) ;define - - (define (%for-each f) - (when (not (null? value)) - (f value) - ) ;when - ) ;define - - (define (%map f . args) - (chain-apply args - (if (null? value) - (rich-option '()) - (rich-option (f value)) - ) ;if - ) ;chain-apply - ) ;define - - (define (%flat-map f . args) - (chain-apply args - (if (null? value) - (rich-option '()) - (f value) - ) ;if - ) ;chain-apply - ) ;define - - (define (%filter pred . args) - (chain-apply args - (if (or (null? value) (not (pred value))) - (rich-option '()) - (rich-option value)) - ) ;if - ) ;chain-apply - - ) ;define - - (define (rich-none) (rich-option '())) - - ) ;define-final-class - ) ;begin diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/rich-path.scm b/TeXmacs/plugins/goldfish/goldfish/liii/rich-path.scm deleted file mode 100644 index f3595e098a..0000000000 --- a/TeXmacs/plugins/goldfish/goldfish/liii/rich-path.scm +++ /dev/null @@ -1,468 +0,0 @@ -; -; Copyright (C) 2024 The Goldfish Scheme Authors -; -; 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. -; - -(define-library (liii rich-path) - (export - path-dir? path-file? path-exists? - path-getsize path-read-text path-read-bytes path-write-text path-append-text path-touch - path - ) ;export - (import (liii base) (liii lang) (liii error) (liii vector) (liii string) (liii list) - (liii os) - ) ;import - (begin - - (define (path-dir? path) - (g_isdir path) - ) ;define - - (define (path-file? path) - (g_isfile path) - ) ;define - - (define (path-exists? path) - (file-exists? path) - ) ;define - - (define path-getsize - (typed-lambda ((path string?)) - (if (not (file-exists? path)) - (file-not-found-error - (string-append "No such file or directory: '" path "'") - ) ;file-not-found-error - (g_path-getsize path) - ) ;if - ) ;typed-lambda - ) ;define - - (define path-read-text - (typed-lambda ((path string?)) - (if (not (file-exists? path)) - (file-not-found-error - (string-append "No such file or directory: '" path "'") - ) ;file-not-found-error - (g_path-read-text path) - ) ;if - ) ;typed-lambda - ) ;define - - (define path-read-bytes - (typed-lambda ((path string?)) - (if (not (file-exists? path)) - (file-not-found-error - (string-append "No such file or directory: '" path "'") - ) ;file-not-found-error - (g_path-read-bytes path) - ) ;if - ) ;typed-lambda - ) ;define - - (define path-write-text - (typed-lambda ((path string?) (content string?)) - (g_path-write-text path content) - ) ;typed-lambda - ) ;define - - (define path-append-text - (typed-lambda ((path string?) (content string?)) - (g_path-append-text path content) - ) ;typed-lambda - ) ;define - - (define (path-touch path) - (g_path-touch path) - ) ;define - - (define-case-class path () - (define parts #(".")) - (define type 'posix) - (define drive "") - - (define (%set-parts! v) - (if (rich-vector :is-type-of v) - (set! parts (v :collect)) - (set! parts v) - ) ;if - ) ;define - - (define (%set-type! s) - (set! type s) - ) ;define - - (define (%set-drive! s) - (set! drive s) - ) ;define - - (define (%get-parts) parts) - (define (%get-type) type) - (define (%get-drive) drive) - - (define (%copy) - (let ((p (path))) - (p :set-parts! parts) - (p :set-type! type) - (p :set-drive! drive) - p - ) ;let - ) ;define - - - (chained-define (@of-drive ch) - (when (not (char? ch)) - (type-error "path@of-drive must take char? as input") - ) ;when - (let ((r (path))) - (r :set-type! 'windows) - (r :set-drive! ($ ch :to-upper :make-string)) - (r :set-parts! #()) - r - ) ;let - ) ;chained-define - - (chained-define (@root) - (let ((r (path))) - (r :set-parts! #("/")) - r - ) ;let - ) ;chained-define - - (chained-define (@from-parts x) - (let ((r (path))) - (r :set-parts! x) - r - ) ;let - ) ;chained-define - - (chained-define (@/ x) - (if (path :is-type-of x) - (path :root :/ x) - (cond ((and (string-ends? x ":") (= (string-length x) 2)) - (path :of-drive (x 0))) - - ((string=? x "/") (path :root)) - - (else - (path :from-parts (vector-append (vector (string (os-sep))) (vector x))) - ) ;else - ) ;cond - ) ;if - ) ;chained-define - - (chained-define (@apply s) - (cond ((and (or (os-linux?) (os-macos?)) - (string-starts? s "/")) - (path :/ (@apply ($ s :drop 1 :get)))) - ((and (os-windows?) - (= (string-length s) 2) - (char=? (s 1) #\:)) - (path :of-drive (s 0)) - ) ; - ((and (os-windows?) (>= (string-length s) 3) - (char=? (s 1) #\:) - (char=? (s 2) #\\)) - (path :of-drive (s 0) - :/ (@apply ($ s :drop 3 :get)) - ) ;path - ) ; - (else - (let loop ((iter s)) - (cond ((or (string-null? iter) (string=? iter ".")) - (path)) - - ((not (char=? (iter 0) (os-sep))) - (path :from-parts ($ iter :split (string (os-sep)))) - ) ; - - (else - (loop ($ iter :drop 1 :get)) - ) ;else - ) ;cond - ) ;let - ) ;else - ) ;cond - ) ;chained-define - - (chained-define (@from-env name) - (path (getenv name)) - ) ;chained-define - - (define (%name) - (if (string=? "." ($ parts :last)) - "" - ($ parts :last) - ) ;if - ) ;define - - (define (%stem) - (define last-part-str - (if (> (vector-length parts) 0) - (vector-ref parts (- (vector-length parts) 1)) - "" - ) ;if - ) ;define - - (define (drop-suffix str) - (let* ((rich-str ($ str)) - (rich-splits (rich-str :split ".")) ; 按点分割 - (count (rich-splits :count))) ; 获取分割数量 - (cond ((<= count 1) str) ; 无后缀或单一部分 - ((string=? str ".") "") ; 当前目录特殊处理 - ((string=? str "..") "..") ; 上级目录特殊处理 - ((and (string=? (rich-splits 0) "") ; 以点开头 - (= count 2)) ; 且只有一个点（纯隐藏文件） - str ; 保留完整文件名 - ) ; - (else ; 正常多后缀情况 - (rich-splits :take (- count 1) :make-string ".") - ) ;else - ) ;cond - ) ;let* - ) ;define - - (drop-suffix (%name)) - ) ;define - - (define (%suffix) - (let* ((name (%name)) - (rich-str ($ name)) - (rich-splits (rich-str :split ".")) - (count (rich-splits :count))) - (cond ((<= count 1) "") ; 无后缀 - ((string=? name ".") "") ; 当前目录 - ((string=? name "..") "") ; 上级目录 - ((and (string=? (rich-splits 0) "") ; 以点开头 - (= count 2)) ; 且只有一个点（纯隐藏文件） - "" - ) ; - (else - (string-append "." (rich-splits :last)) ; 返回最后一部分 - ) ;else - ) ;cond - ) ;let* - ) ;define - - (define (%equals that) - (if (path :is-type-of that) - (string=? (%to-string) (that :to-string)) - #f - ) ;if - ) ;define - - (define (%file?) - (path-file? (%to-string)) - ) ;define - - (define (%dir?) - (path-dir? (%to-string)) - ) ;define - - (define (%absolute?) - (case type - ((posix) (string-starts? (parts 0) "/")) - - ((windows) (not ($ drive :empty?))) - - (else - (value-error - (string-append "path%absolute?: unknown type" (symbol->string type)) - ) ;value-error - ) ;else - ) ;case - ) ;define - - (define (%relative) - (not (%absolute?)) - ) ;define - - (define (%exists?) - (path-exists? (%to-string)) - ) ;define - - (define (%to-string) - (case type - ((posix) - (let ((s ($ parts :make-string (string (os-sep))))) - (if (and (> ($ s :length) 1) (string-starts? s (string (os-sep)))) - (string-drop s 1) - s - ) ;if - ) ;let - ) ; - ((windows) - (let ((s ($ parts :make-string "\\"))) - (if (string-null? drive) - s - (string-append drive ":\\" s) - ) ;if - ) ;let - ) ; - (else (value-error "path%to-string: unknown type" type)) - ) ;case - ) ;define - - (define (%read-text) - (path-read-text (%to-string)) - ) ;define - - (typed-define (%write-text (content string?)) - (path-write-text (%to-string) content) - ) ;typed-define - - (typed-define (%append-text (content string?)) - (path-append-text (%to-string) content) - ) ;typed-define - - (define (%list) - (box (listdir (%to-string))) - ) ;define - - (define (%list-path) - ((box (listdir (%to-string))) - :map (lambda (x) ((%this) :/ x)) - ) ; - ) ;define - - (define (%touch) - (path-touch (%to-string)) - ) ;define - - (chained-define (%/ x) - (cond ((string? x) - (let ((new-path (%copy))) - (new-path :set-parts! (vector-append parts (vector x))) - new-path) - ) ;let - - ((path :is-type-of x) - (cond ((x :absolute?) - (value-error "path to append must not be absolute path: " (x :to-string))) - ((string=? (x :to-string) ".") - (%this) - ) ; - (else (let ((new-path (%copy)) - (x-parts (x :get-parts))) - (if (os-windows?) - (new-path :set-parts! x-parts) - (new-path :set-parts! (vector-append (vector (string (os-sep))) x-parts)) - ) ;if - new-path) - ) ;else - ) ;cond - ) ; - - (else (type-error "only string?, path is allowed")) - ) ;cond - ) ;chained-define - - (chained-define (%parent) - (define (parts-drop-right parts x) - (let ((path-vec ($ parts :drop-right x))) - (let ((new-path (%copy))) - (if (path-vec :empty?) - (if (os-windows?) - (new-path :set-parts! #("")) - (new-path :set-parts! #(".")) - ) ;if - (new-path :set-parts! (path-vec :append #(""))) - ) ;if - new-path - ) ;let - ) ;let - ) ;define - - (cond - ((or (equal? #("/") parts) (equal? #(".") parts)) - (%this) - ) ; - ((or (os-macos?) (os-linux?)) - (let ((last-part (($ parts) :take-right 1 :collect))) - (if (equal? last-part #("")) - (parts-drop-right parts 2) - (parts-drop-right parts 1) - ) ;if - ) ;let - ) ; - ((os-windows?) - (if ($ parts :empty?) - (%this) - (let ((last-part (($ parts) :take-right 1 :collect))) - (if (equal? last-part #("")) - (parts-drop-right parts 2) - (parts-drop-right parts 1) - ) ;if - ) ;let - ) ;if - ) ; - - (else (??? "Unsupported platform")) - ) ;cond - ) ;chained-define - - (define (%rmdir) - (rmdir (%to-string)) - ) ;define - - (define* (%unlink (missing-ok #f)) ; 使用define*定义可选参数 - (let ((path-str (%to-string))) - (cond - ((file-exists? path-str) ; 文件存在时总是删除 - (remove path-str) - ) ; - (missing-ok ; 文件不存在时根据missing-ok决定 - #t ; missing-ok为#t时静默返回#t - ) ;missing-ok - (else ; missing-ok为#f时抛出错误 - (error 'file-not-found-error - (string-append "File not found: " path-str) - ) ;error - ) ;else - ) ;cond - ) ;let - ) ;define* - - - (chained-define (@./ x) - (let ((p (path x))) - (if (p :absolute?) - (value-error "path@./: only accecpt relative path") - (path x) - ) ;if - ) ;let - ) ;chained-define - - (chained-define (@cwd) - (path (getcwd)) - ) ;chained-define - - (chained-define (@home) - (cond ((or (os-linux?) (os-macos?)) - (path (getenv "HOME"))) - ((os-windows?) - (path :of-drive ((getenv "HOMEDRIVE") 0) - :/ (path (getenv "HOMEPATH")) - ) ;path - ) ; - (else (value-error "path@home: unknown type")) - ) ;cond - ) ;chained-define - - (chained-define (@temp-dir) - (path (os-temp-dir))) - - ) ;chained-define - - ) ;define-case-class - ) ;begin diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/rich-range.scm b/TeXmacs/plugins/goldfish/goldfish/liii/rich-range.scm deleted file mode 100644 index 3db0fc1f74..0000000000 --- a/TeXmacs/plugins/goldfish/goldfish/liii/rich-range.scm +++ /dev/null @@ -1,118 +0,0 @@ -; -; Copyright (C) 2024 The Goldfish Scheme Authors -; -; 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. -; - -(define-library (liii rich-range) - (import (liii oop) - (liii rich-list) - (liii error) - ) ;import - (export rich-range) - (begin - - (define-case-class rich-range - ((start integer?) (end integer?) (step integer? 1) (inclusive? boolean? #f)) - - (define* (@inclusive start end (step 1)) - (rich-range start end step #t) - ) ;define* - - (define (check-step) - (when (zero? step) - (value-error "step can't be zero") - ) ;when - ) ;define - - (define (in-range? x) - (or (and (> step 0) (if inclusive? (and (<= x end) (>= x start)) (and (< x end) (>= x start)))) - (and (< step 0) (if inclusive? (and (>= x end) (<= x start)) (and (> x end) (<= x start)))) - ) ;or - ) ;define - - (define (not-in-range? x) - (or (and (> step 0) (or (> x end) (< x start))) - (and (< step 0) (or (< x end) (> x start))) - (and (= x end) (not inclusive?)) - ) ;or - ) ;define - - (define (%empty?) - (check-step) - (or (and (> start end) (> step 0)) - (and (< start end) (< step 0)) - (and (= start end) (not inclusive?)) - ) ;or - ) ;define - - (define (%map map-func) - (if (%empty?) - (rich-list :empty) - (let loop ((current start) (result '())) - (if (not-in-range? current) - (rich-list (reverse result)) - (loop (+ current step) - (cons (map-func current) result) - ) ;loop - ) ;if - ) ;let - ) ;if - ) ;define - - (define (%for-each proc) - (when (not (%empty?)) - (let loop ((current start)) - (when (in-range? current) - (proc current) - (loop (+ current step)) - ) ;when - ) ;let - ) ;when - ) ;define - - (define (%filter f) - (if (%empty?) - (rich-list :empty) - (let loop ((i start) (return '())) - (if (not-in-range? i) - (rich-list (reverse return)) - (loop (+ i step) - (if (f i) - (cons i return) - return - ) ;if - ) ;loop - ) ;if - ) ;let - ) ;if - ) ;define - - (define (%contains elem) - (check-step) - (if (%empty?) - #f - (if (in-range? elem) ;判断是否在范围内 - (zero? (modulo (- elem start) (abs step))) - #f - ) ;if - ) ;if - ) ;define - - - - - ) ;define-case-class - ) ;begin -) ;define-library - diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/rich-set.scm b/TeXmacs/plugins/goldfish/goldfish/liii/rich-set.scm deleted file mode 100644 index aaceaf9a27..0000000000 --- a/TeXmacs/plugins/goldfish/goldfish/liii/rich-set.scm +++ /dev/null @@ -1,80 +0,0 @@ -; -; Copyright (C) 2024 The Goldfish Scheme Authors -; -; 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. -; - -(define-library (liii rich-set) - (import (liii lang)(liii hash-table)(srfi srfi-128)) - (export rich-hash-set) - (begin - - - (define-case-class rich-hash-set ((data hash-table?)) - - ;; Factory methods - (chained-define (@empty) - (rich-hash-set (make-hash-table)) - ) ;chained-define - - ;; Basic operations - (define (%size) (hash-table-size data)) - - (define (%empty?) (hash-table-empty? data)) - - (define (%contains element) - (hash-table-contains? data element) - ) ;define - - ;; Modification operations - (chained-define (%add-one! element) - (hash-table-set! data element #t) - (%this) - ) ;chained-define - - (chained-define (%remove! element) - (hash-table-delete! data element) - (%this) - ) ;chained-define - - (chained-define (%add-one element) - (let ((ht (make-hash-table))) - (hash-table-for-each - (lambda (k v) (hash-table-set! ht k v)) - data - ) ;hash-table-for-each - (hash-table-set! ht element #t) - (rich-hash-set ht) - ) ;let - ) ;chained-define - - (chained-define (%remove element) - (let ((ht (make-hash-table))) - (hash-table-for-each - (lambda (k v) (hash-table-set! ht k v)) - data - ) ;hash-table-for-each - (hash-table-delete! ht element) - (rich-hash-set ht) - ) ;let - ) ;chained-define - - (chained-define (%clear!) - (hash-table-clear! data) - (%this) - ) ;chained-define - - ) ;define-case-class - ) ;begin -) ;define-library - diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/rich-string.scm b/TeXmacs/plugins/goldfish/goldfish/liii/rich-string.scm deleted file mode 100644 index c7f6a01a1e..0000000000 --- a/TeXmacs/plugins/goldfish/goldfish/liii/rich-string.scm +++ /dev/null @@ -1,498 +0,0 @@ -; -; Copyright (C) 2025 The Goldfish Scheme Authors -; -; 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. -; - -(define-library (liii rich-string) - (import (liii string) - (liii oop) - (liii base) - (liii rich-char) - (liii rich-vector) - (liii vector) - (rename (liii rich-option) (rich-option option)) - ) ;import - (export rich-string) - (begin - - (define-case-class rich-string - ((data string?)) - - (define N (utf8-string-length data)) - - (define (@empty . args) - (chain-apply args (rich-string "")) - ) ;define - - (define (@value-of v . args) - (chain-apply args - (cond ((char? v) (rich-string (string v))) - ((number? v) (rich-string (number->string v))) - ((symbol? v) (rich-string (symbol->string v))) - ((string? v) (rich-string v)) - ((rich-char :is-type-of v) - (rich-string (v :make-string)) - ) ; - (else (type-error "Expected types are char, rich-char, number, symbol or string")) - ) ;cond - ) ;chain-apply - ) ;define - - (define (%get) data) - - (define (%length) - N - ) ;define - - (define (%char-at index) - (when (not (integer? index)) - (type-error "rich-string%char-at: index must be integer" index) - ) ;when - - (let* ((start index) - (end (+ index 1)) - (byte-seq (string->utf8 data start end))) - (rich-char :from-bytevector byte-seq) - ) ;let* - ) ;define - - (define (%apply i) - (%char-at i) - ) ;define - - (define (%find pred) ((%to-rich-vector) :find pred)) - - (define (%find-last pred) ((%to-rich-vector) :find-last pred)) - - (define (%head) - (if (string-null? data) - (index-error "rich-string%head: string is empty") - (%char-at 0) - ) ;if - ) ;define - - (define (%head-option) - (if (string-null? data) - (none) - (option (%char-at 0)) - ) ;if - ) ;define - - (define (%last) - (if (string-null? data) - (index-error "rich-string%last: string is empty") - (%char-at (- N 1)) - ) ;if - ) ;define - - (define (%last-option) - (if (string-null? data) - (none) - (option (%char-at (- N 1))) - ) ;if - ) ;define - - (define (%slice from until . args) - (chain-apply args - (let* ((start (max 0 from)) - (end (min N until))) - (cond ((and (zero? start) (= end N)) - (%this)) - ((>= start end) - (rich-string :empty) - ) ; - (else - (rich-string (u8-substring data start end)) - ) ;else - ) ;cond - ) ;let* - ) ;chain-apply - ) ;define - - (define (%take n . args) - (chain-apply args - (%slice 0 n) - ) ;chain-apply - ) ;define - - (define (%take-right n . args) - (chain-apply args - (%slice (- N n) N) - ) ;chain-apply - ) ;define - - (define (%drop n . args) - (chain-apply args - (%slice n N) - ) ;chain-apply - ) ;define - - (define (%drop-right n . args) - (chain-apply args - (%slice 0 (- N n)) - ) ;chain-apply - ) ;define - - (define (%empty?) - (string-null? data) - ) ;define - - (define (%starts-with prefix) - (string-starts? data prefix) - ) ;define - - (define (%ends-with suffix) - (string-ends? data suffix) - ) ;define - - (define (%forall pred) - ((%to-rich-vector) :forall pred) - ) ;define - - (define (%exists pred) - ((%to-rich-vector) :exists pred) - ) ;define - - (define (%contains elem) - (cond ((rich-string :is-type-of elem) - (string-contains data (elem :get))) - - ((string? elem) - (string-contains data elem) - ) ; - - ((rich-char :is-type-of elem) - (string-contains data (elem :make-string)) - ) ; - - ((char? elem) - (string-contains data (string elem)) - ) ; - - (else (type-error "elem must be char or string")) - ) ;cond - ) ;define - - (define* (%index-of str/char (start-index 0)) - (define (bytes-match? data-bv data-pos str-bv str-size data-size) - (let loop ((i 0)) - (if (>= i str-size) - #t - (and (< (+ data-pos i) data-size) - (= (bytevector-u8-ref data-bv (+ data-pos i)) - (bytevector-u8-ref str-bv i) - ) ;= - (loop (+ i 1)) - ) ;and - ) ;if - ) ;let - ) ;define - - (define (char-index->byte-pos bv size char-index) - (let loop ((i 0) (pos 0)) - (if (>= i char-index) - pos - (loop (+ i 1) (bytevector-advance-utf8 bv pos size)) - ) ;if - ) ;let - ) ;define - - (define* (inner-index-of str start-index) - (if (or (string-null? data) (string-null? str)) - -1 - (let* ((data-bv (string->utf8 data)) - (str-bv (string->utf8 str)) - (data-size (bytevector-length data-bv)) - (str-size (bytevector-length str-bv))) - (if (or (negative? start-index) - (>= start-index N)) - -1 - (let ((start-byte-pos (char-index->byte-pos data-bv data-size start-index))) - (let search ((byte-pos start-byte-pos) (current-char-index start-index)) - (cond - ((> (+ byte-pos str-size) data-size) -1) - ((bytes-match? data-bv byte-pos str-bv str-size data-size) - current-char-index - ) ; - (else - (search (bytevector-advance-utf8 data-bv byte-pos data-size) - (+ current-char-index 1) - ) ;search - ) ;else - ) ;cond - ) ;let - ) ;let - ) ;if - ) ;let* - ) ;if - ) ;define* - - (unless (integer? start-index) - (type-error "rich-string%index-of: the second parameter must be integer") - ) ;unless - - (let ((positive-start-index (max 0 start-index))) - (cond ((string? str/char) - (inner-index-of str/char positive-start-index)) - ((rich-string :is-type-of str/char) - (inner-index-of (str/char :get) positive-start-index) - ) ; - ((char? str/char) - (inner-index-of (string str/char) positive-start-index) - ) ; - ((rich-char :is-type-of str/char) - (inner-index-of (str/char :make-string) positive-start-index) - ) ; - (else (type-error "rich-string%index-of: first parameter must be string/rich-string/char/rich-char")) - ) ;cond - ) ;let - ) ;define* - - (define (%map f . args) - (chain-apply args - (rich-string ((%to-rich-vector) - :map f - :map (lambda (x) (x :make-string)) - :make-string) - ) ;rich-string - ) ;chain-apply - ) ;define - - (define (%filter pred . args) - (chain-apply args - (rich-string ((%to-rich-vector) - :filter pred - :map (lambda (x) (x :make-string)) - :make-string) - ) ;rich-string - ) ;chain-apply - ) ;define - - (define (%reverse . args) - (chain-apply args - (rich-string ((%to-rich-vector) - :reverse - :map (lambda (x) (x :make-string)) - :make-string) - ) ;rich-string - ) ;chain-apply - ) ;define - - (define (%for-each f) - ((%to-rich-vector) :for-each f) - ) ;define - - (define (%count pred?) - ((%to-rich-vector) :count pred?) - ) ;define - - (define (%index-where pred) - (let ((bytes (string->utf8 data)) - (len (bytevector-length (string->utf8 data)))) - (let loop ((byte-pos 0) (char-index 0)) - (cond - ((>= byte-pos len) -1) - (else - (let* ((next-pos (bytevector-advance-utf8 bytes byte-pos len)) - (char-bytes (bytevector-copy bytes byte-pos next-pos)) - (char (rich-char :from-bytevector char-bytes))) - (if (pred char) - char-index - (loop next-pos (+ char-index 1)) - ) ;if - ) ;let* - ) ;else - ) ;cond - ) ;let - ) ;let - ) ;define - - (define (%take-while pred . args) - (chain-apply args - (let ((stop-index (%index-where (lambda (c) (not (pred c)))))) - (if (= stop-index -1) - (%this) - (%slice 0 stop-index) - ) ;if - ) ;let - ) ;chain-apply - ) ;define - - (define (%drop-while pred . args) - (chain-apply args - (let ((index (%index-where (lambda (c) (not (pred c)))))) - (if (= index -1) - (rich-string "") - (%slice index N) - ) ;if - ) ;let - ) ;chain-apply - ) ;define - - (define (%to-string) - data - ) ;define - - (define (%to-vector) - (if (string-null? data) - (vector) - (let* ((bv (string->utf8 data)) - (bv-size (length bv)) - (result (make-vector N))) - (let loop ((i 0) (j 0)) - (if (>= i N) - result - (let* ((next-j (bytevector-advance-utf8 bv j bv-size)) - (ch (rich-char :from-bytevector (bytevector-copy bv j next-j)))) - (vector-set! result i ch) - (loop (+ i 1) next-j) - ) ;let* - ) ;if - ) ;let - ) ;let* - ) ;if - ) ;define - - (define (%to-rich-vector) - (rich-vector (%to-vector)) - ) ;define - - (define (%+ s . args) - (chain-apply args - (cond - ((string? s) - (rich-string (string-append data s)) - ) ; - ((rich-string :is-type-of s) - (rich-string (string-append data (s :get))) - ) ; - ((number? s) - (rich-string (string-append data (number->string s))) - ) ; - (else - (type-error (string-append (object->string s) "is not string or rich-string or number")) - ) ;else - ) ;cond - ) ;chain-apply - ) ;define - - (define (%strip-left . args) - (chain-apply args - (rich-string (string-trim data)) - ) ;chain-apply - ) ;define - - (define (%strip-right . args) - (chain-apply args - (rich-string (string-trim-right data)) - ) ;chain-apply - ) ;define - - (define (%strip-both . args) - (chain-apply args - (rich-string (string-trim-both data)) - ) ;chain-apply - ) ;define - - (define (%strip-prefix prefix . args) - (chain-apply args - (rich-string (string-remove-prefix data prefix)) - ) ;chain-apply - ) ;define - - (define (%strip-suffix suffix . args) - (chain-apply args - (rich-string (string-remove-suffix data suffix)) - ) ;chain-apply - ) ;define - - (define (%replace-first old new . args) - (chain-apply args - (let ((next-pos (%index-of old))) - (if (= next-pos -1) - (%this) - ((%slice 0 next-pos) - :+ new - :+ (%drop (+ next-pos ($ old :length))) - ) ; - ) ;if - ) ;let - ) ;chain-apply - ) ;define - - (define (%replace old new . args) - (define (replace-helper str old new start) - (let ((next-pos ((rich-string str) :index-of old start))) - (if (= next-pos -1) - str - (replace-helper ((rich-string str) :replace-first old new :get) - old new next-pos - ) ;replace-helper - ) ;if - ) ;let - ) ;define - (chain-apply args - (rich-string (replace-helper data old new 0)) - ) ;chain-apply - ) ;define - - (define* (%pad-left len ch . args) - (let ((result (if (<= len N) - (%this) - (let ((padding (make-string (- len N) ch))) - (rich-string (string-append padding data))))) - ) ;let - (if (null? args) - result - (apply result args) - ) ;if - ) ;let - ) ;define* - - (define* (%pad-right len ch . args) - (let ((result (if (<= len N) - (%this) - (let ((padding (make-string (- len N) ch))) - (rich-string (string-append data padding))))) - ) ;let - (if (null? args) - result - (apply result args) - ) ;if - ) ;let - ) ;define* - - (define (%split sep) - (let ((str-len N) - (sep-len (utf8-string-length sep))) - - (define (split-helper start acc) - (let ((next-pos (%index-of sep start))) - (if (= next-pos -1) - (cons (%drop start :get) acc) - (split-helper (+ next-pos sep-len) (cons (%slice start next-pos :get) acc)) - ) ;if - ) ;let - ) ;define - - (if (zero? sep-len) - ((%to-rich-vector) :map (lambda (c) (c :make-string))) - (rich-vector (reverse-list->vector (split-helper 0 '())))) - ) ;if - ) ;let - - ) ;define - - ) ;define-case-class - ) ;begin diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/rich-vector.scm b/TeXmacs/plugins/goldfish/goldfish/liii/rich-vector.scm deleted file mode 100644 index efb5a16413..0000000000 --- a/TeXmacs/plugins/goldfish/goldfish/liii/rich-vector.scm +++ /dev/null @@ -1,593 +0,0 @@ -; -; Copyright (C) 2025 The Goldfish Scheme Authors -; -; 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. -; - -(define-library (liii rich-vector) - (import (liii string) (liii hash-table) (liii sort) (liii list) (liii vector) (liii oop) (srfi srfi-8) - (rename (liii rich-option) (rich-option option)) - ) ;import - (export rich-vector) - (begin - - (define-case-class rich-vector ((data vector?)) - - (define (@range start end . step) - (let ((step-size (if (null? step) 1 (car step)))) - (cond - ((and (positive? step-size) (>= start end)) - (rich-vector #()) - ) ; - ((and (negative? step-size) (<= start end)) - (rich-vector #()) - ) ; - ((zero? step-size) - (value-error "Step size cannot be zero") - ) ; - (else - (let ((cnt (ceiling (/ (- end start) step-size)))) - (rich-vector (list->vector (iota cnt start step-size))) - ) ;let - ) ;else - ) ;cond - ) ;let - ) ;define - - (define (@empty . args) - (chain-apply args - (rich-vector #()) - ) ;chain-apply - ) ;define - - (define (@fill n elem . args) - (unless (integer? n) - (type-error "n must be integer" n) - ) ;unless - (when (< n 0) - (value-error "n must be non-negative" n) - ) ;when - (chain-apply args - (rich-vector (make-vector n elem)) - ) ;chain-apply - ) ;define - - (define (@concat v1 v2 . args) - (chain-apply args - (rich-vector (vector-append (v1 :collect) (v2 :collect))) - ) ;chain-apply - ) ;define - - (define (%collect) data) - - (define (%length) - (vector-length data) - ) ;define - - (define (%size) - (vector-length data) - ) ;define - - (define (%apply i) - (when (or (< i 0) (>= i (vector-length data))) - (index-error "rich-vector%apply: out of range with index" i) - ) ;when - (vector-ref data i) - ) ;define - - (define (%index-of x) - (or (vector-index (lambda (y) (class=? x y)) data) - -1 - ) ;or - ) ;define - - (define (%last-index-of x) - (or (vector-index-right (lambda (y) (class=? x y)) data) - -1 - ) ;or - ) ;define - - (define (%find p) - (let loop ((i 0)) - (cond - ((>= i (vector-length data)) (none)) - ((p (vector-ref data i)) (option (vector-ref data i))) - (else (loop (+ i 1))) - ) ;cond - ) ;let - ) ;define - - (define (%find-last pred) - (let loop ((i (- (vector-length data) 1))) - (cond - ((< i 0) (none)) ; 遍历完所有元素未找到 - ((pred (vector-ref data i)) (option (vector-ref data i))) ; 找到符合条件的元素 - (else (loop (- i 1))) ; 继续向前查找 - ) ;cond - ) ;let - ) ;define - - (define (%head) - (if (> (vector-length data) 0) - (vector-ref data 0) - (error 'out-of-range "out-of-range") - ) ;if - ) ;define - - (define (%head-option) - (if (> (vector-length data) 0) - (option (vector-ref data 0)) - (none) - ) ;if - ) ;define - - (define (%last) - (let ((len (vector-length data))) - (if (> len 0) - (vector-ref data (- len 1)) - (index-error "rich-vector%last: empty vector") - ) ;if - ) ;let - ) ;define - - (define (%last-option) - (let ((len (vector-length data))) - (if (> len 0) - (option (vector-ref data (- len 1))) - (none) - ) ;if - ) ;let - ) ;define - - (define (%slice from until . args) - (chain-apply args - (let* ((len (vector-length data)) - (start (max 0 from)) - (end (min len until))) - (if (< start end) - (rich-vector (vector-copy data start end)) - (rich-vector :empty) - ) ;if - ) ;let* - ) ;chain-apply - ) ;define - - (define (%empty?) - (= (length data) 0) - ) ;define - - (define (%equals that) - (and (that :is-instance-of 'rich-vector) - (vector= class=? data (that 'data)) - ) ;and - ) ;define - - (define (%forall p) - (vector-every p data) - ) ;define - - (define (%exists p) - (vector-any p data) - ) ;define - - (define (%contains elem) - (%exists (lambda (x) (equal? x elem))) - ) ;define - - (define (%map x . args) - (chain-apply args - (rich-vector (vector-map x data)) - ) ;chain-apply - ) ;define - - (define (%flat-map f . args) - (chain-apply args - (rich-vector (%map f :reduce vector-append)) - ) ;chain-apply - ) ;define - - (define (%filter x . args) - (chain-apply args - (rich-vector (vector-filter x data)) - ) ;chain-apply - ) ;define - - (define (%for-each x) - (vector-for-each x data) - ) ;define - - (define (%reverse . args) - (chain-apply args - (rich-vector (reverse data)) - ) ;chain-apply - ) ;define - - (define (%count . xs) - (cond ((null? xs) (vector-length data)) - ((length=? 1 xs) (count (car xs) (vector->list data))) - (else (error 'wrong-number-of-args "rich-vector%count" xs)) - ) ;cond - ) ;define - - (define (%take n . args) - (chain-apply args - (rich-vector (vector-take data n)) - ) ;chain-apply - ) ;define - - (define (%take-right n . args) - (chain-apply args - (rich-vector (vector-take-right data n)) - ) ;chain-apply - ) ;define - - (define (%drop n . args) - (chain-apply args - (rich-vector (vector-drop data n)) - ) ;chain-apply - ) ;define - - (define (%drop-right n . args) - (chain-apply args - (rich-vector (vector-drop-right data n)) - ) ;chain-apply - ) ;define - - (define (%drop-while pred . args) - (chain-apply args - (let ((len (vector-length data))) - (let loop ((i 0)) - (cond - ((>= i len) (rich-vector :empty)) ; 所有元素都被丢弃 - ((pred (vector-ref data i)) (loop (+ i 1))) ; 继续丢弃 - (else (rich-vector (vector-copy data i))) ; 返回剩余部分 - ) ;cond - ) ;let - ) ;let - ) ;chain-apply - ) ;define - - (define (%fold initial f) - (vector-fold f initial data) - ) ;define - - (define (%fold-right initial f) - (vector-fold-right f initial data) - ) ;define - - (define (%count . xs) - (cond ((null? xs) (vector-length data)) - ((length=? 1 xs) (count (car xs) (vector->list data))) - (else (error 'wrong-number-of-args "rich-vector%count" xs)) - ) ;cond - ) ;define - - (define (%sort-with less-p . args) - (chain-apply args - (rich-vector (vector-stable-sort less-p data)) - ) ;chain-apply - ) ;define - - (define (%sort-by f . args) - (chain-apply args - (let ((sorted-data (vector-stable-sort (lambda (x y) (< (f x) (f y))) data))) - (rich-vector sorted-data) - ) ;let - ) ;chain-apply - ) ;define - - (define (%group-by func) - (let ((group (make-hash-table))) - (for-each - (lambda (elem) - (let ((key (func elem))) - (hash-table-update!/default - group - key - (lambda (current-list) (cons elem current-list)) - '() - ) ;hash-table-update!/default - ) ;let - ) ;lambda - (vector->list data) - ) ;for-each - (hash-table-for-each - (lambda (k v) (hash-table-set! group k (reverse-list->vector v))) - group - ) ;hash-table-for-each - (rich-hash-table group) - ) ;let - ) ;define - - (define (%sliding size . step-arg) - (unless (integer? size) (type-error "rich-vector%sliding: size must be an integer " size)) - (unless (> size 0) (value-error "rich-vector%sliding: size must be a positive integer " size)) - - (let ((N (vector-length data))) - (if (zero? N) - #() - (let* ((is-single-arg-case (null? step-arg)) - (step (if is-single-arg-case 1 (car step-arg)))) - - ;; Validate step if provided - (when (and (not is-single-arg-case) - (or (not (integer? step)) (<= step 0))) - (if (not (integer? step)) - (type-error "rich-vector%sliding: step must be an integer " step) - (value-error "rich-vector%sliding: step must be a positive integer " step) - ) ;if - ) ;when - - ;; single-argument version when N < size - (if (and is-single-arg-case (< N size)) - (vector data) - (let collect-windows ((current-idx 0) (result-windows '())) - (cond - ;; Stop if current_idx is out of bounds - ((>= current-idx N) (list->vector (reverse result-windows))) - ;; For single-arg case - ((and is-single-arg-case (> (+ current-idx size) N)) - (list->vector (reverse result-windows)) - ) ; - (else - (let* ((window-end (if is-single-arg-case - (+ current-idx size) ;; Single-arg: always takes full 'size' - (min (+ current-idx size) N))) ;; Two-arg: can be partial - (current-window (vector-copy data current-idx window-end))) - (collect-windows (+ current-idx step) (cons current-window result-windows)) - ) ;let* - ) ;else - ) ;cond - ) ;let - ) ;if - ) ;let* - ) ;if - ) ;let - ) ;define - - (define (%zip-with-index . args) - (chain-apply args - (let* ((n (vector-length data)) - (result (make-vector n))) - (let loop ((idx 0)) - (if (>= idx n) - (rich-vector result) - (begin - (vector-set! - result - idx - (cons idx (vector-ref data idx)) - ) ;vector-set! - (loop (+ idx 1)) - ) ;begin - ) ;if - ) ;let - ) ;let* - ) ;chain-apply - ) ;define - - (define (%distinct . args) - (chain-apply args - (let ((ht (make-hash-table)) - (length (vector-length data))) - (let loop ((result '()) - (index 0)) - (if (>= index length) - (rich-vector (list->vector (reverse result))) - (let ((elem (vector-ref data index))) - (if (eq? (hash-table-ref ht elem) #f) - (begin - (hash-table-set! ht elem #t) - (loop (cons elem result) (+ index 1)) - ) ;begin - (loop result (+ index 1)) - ) ;if - ) ;let - ) ;if - ) ;let - ) ;let - ) ;chain-apply - ) ;define - - (define (%reduce f) - (let ((len (vector-length data))) - (if (zero? len) - (value-error "rich-vector%reduce: empty vector is not allowed to reduce") - (let loop ((acc (vector-ref data 0)) - (i 1)) - (if (>= i len) - acc - (loop (f acc (vector-ref data i)) (+ i 1)) - ) ;if - ) ;let - ) ;if - ) ;let - ) ;define - - (define (%index-where pred) - (or (vector-index pred data) - -1 - ) ;or - ) ;define - - (define (%last-index-where pred) - (or (vector-index-right pred data) - -1 - ) ;or - ) ;define - - (define (%take-while pred . args) - (chain-apply args - (let* ((vec data) - (len (vector-length vec)) - (idx (vector-index (lambda (x) (not (pred x))) vec))) - (rich-vector (vector-copy vec 0 (or idx len))) - ) ;let* - ) ;chain-apply - ) ;define - - (define (%max-by f) - (when (not (procedure? f)) - (type-error "rich-vector%max-by: f must be a procedure") - ) ;when - - (let ((vec data) - (len (length data))) - (if (zero? len) - (value-error "rich-vector%max-by: empty list is not allowed") - (let loop ((i 1) - (max-elem (vector-ref vec 0)) - (max-val (f (vector-ref vec 0)))) - (if (>= i len) - max-elem - (let* ((current-elem (vector-ref vec i)) - (current-val (f current-elem))) - (unless (number? current-val) - (type-error "f must return a number") - ) ;unless - (if (< current-val max-val) - (loop (+ i 1) max-elem max-val) - (loop (+ i 1) current-elem current-val) - ) ;if - ) ;let* - ) ;if - ) ;let - ) ;if - ) ;let - ) ;define - - (define (%min-by f) - (when (not (procedure? f)) - (type-error "rich-vector%min-by: f must be a procedure") - ) ;when - - (let ((vec data) - (len (length data))) - (if (zero? len) - (value-error "rich-vector%min-by: empty list is not allowed") - (let loop ((i 1) - (min-elem (vector-ref vec 0)) - (min-val (f (vector-ref vec 0)))) - (if (>= i len) - min-elem - (let* ((current-elem (vector-ref vec i)) - (current-val (f current-elem))) - (unless (number? current-val) - (type-error "f must return a number") - ) ;unless - (if (> current-val min-val) - (loop (+ i 1) min-elem min-val) - (loop (+ i 1) current-elem current-val) - ) ;if - ) ;let* - ) ;if - ) ;let - ) ;if - ) ;let - ) ;define - - (define (%max-by-option f) - (when (not (procedure? f)) - (type-error "rich-vector%max-by-option: f must be a procedure") - ) ;when - - (if (zero? (vector-length data)) - (none) - (option (%max-by f)) - ) ;if - ) ;define - - (define (%min-by-option f) - (when (not (procedure? f)) - (type-error "rich-vector%min-by-option: f must be a procedure") - ) ;when - - (if (zero? (vector-length data)) - (none) - (option (%min-by f)) - ) ;if - ) ;define - - (define (%to-string) - ((%map object->string) - :make-string "#(" " " ")" - ) ; - ) ;define - - (define (%make-string . xs) - (define (parse-args xs) - (cond - ((null? xs) (values "" "" "")) - ((length=? 1 xs) - (let ((sep (car xs))) - (if (string? sep) - (values "" sep "") - (type-error "rich-vector%make-string: separator must be a string" sep) - ) ;if - ) ;let - ) ; - ((length=? 2 xs) - (error 'wrong-number-of-args "rich-vector%make-string: expected 0, 1, or 3 arguments, but got 2" xs) - ) ; - ((length=? 3 xs) - (let ((start (car xs)) - (sep (cadr xs)) - (end (caddr xs))) - (if (and (string? start) (string? sep) (string? end)) - (values start sep end) - (type-error "rich-vector%make-string: prefix, separator, and suffix must be strings" xs) - ) ;if - ) ;let - ) ; - (else (error 'wrong-number-of-args "rich-vector%make-string: expected 0, 1, or 3 arguments" xs)) - ) ;cond - ) ;define - - (receive (start sep end) (parse-args xs) - (let* ((as-string (lambda (x) (if (string? x) x (object->string x)))) - (middle (string-join (map as-string (vector->list data)) sep))) - (string-append start middle end) - ) ;let* - ) ;receive - ) ;define - - (define (%to-list) - (vector->list data) - ) ;define - - (define (%to-rich-list) - (rich-list (vector->list data)) - ) ;define - - (define (%set! i x) - (when (or (< i 0) (>= i (length data))) - (index-error "rich-vector%set! out of range at index" i) - ) ;when - (vector-set! data i x) - ) ;define - - (define (%append v) - (when (not (or (vector? v) (rich-vector :is-type-of v))) - (type-error "rich-vector%append: input is not vector or rich-vector") - ) ;when - - (if (vector? v) - (rich-vector (vector-append data v)) - (rich-vector (vector-append data (v :collect))) - ) ;if - ) ;define - - ) ;define-case-class - - ) ;begin -) ;define-library diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/stack.scm b/TeXmacs/plugins/goldfish/goldfish/liii/stack.scm deleted file mode 100644 index 8947869187..0000000000 --- a/TeXmacs/plugins/goldfish/goldfish/liii/stack.scm +++ /dev/null @@ -1,65 +0,0 @@ -; -; Copyright (C) 2024 The Goldfish Scheme Authors -; -; 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. -; - -(define-library (liii stack) - (import (liii rich-list) (liii oop)) - (export stack) - (begin - - (define-case-class stack ((data list?)) - (define (@empty) (stack (list ))) - - (define (%length) (length data)) - - (define (%size) (length data)) - - (define (%top) - (if (null? data) - (error 'out-of-range) - (car data) - ) ;if - ) ;define - - (chained-define (%pop) - (if (null? data) - (error 'out-of-range "Cannot pop from an empty stack") - (stack (cdr data)) - ) ;if - ) ;chained-define - - (chained-define (%pop!) - (if (null? data) - (error 'out-of-range) - (stack (set! data (cdr data))) - ) ;if - (%this) - ) ;chained-define - - (chained-define (%push element) - (stack (cons element data)) - ) ;chained-define - - (chained-define (%push! element) - (stack (set! data (cons element data))) - (%this) - ) ;chained-define - - (define (%to-list) data) - - (define (%to-rich-list) (rich-list data)) - ) ;define-case-class - ) ;begin -) ;define-library diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/string.scm b/TeXmacs/plugins/goldfish/goldfish/liii/string.scm index 4b06f6956a..3fc159dc15 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/string.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/string.scm @@ -33,10 +33,11 @@ string-reverse string-tokenize ; Liii extras - string-starts? string-ends? + string-starts? string-contains? string-ends? + string-split string-replace string-remove-prefix string-remove-suffix ) ;export - (import (srfi srfi-13) + (import (except (srfi srfi-13) string-replace) (liii base) (liii error) ) ;import @@ -49,6 +50,137 @@ ) ;if ) ;define + (define string-contains? + (typed-lambda ((str string?) (sub-str string?)) + (string-contains str sub-str) + ) ;typed-lambda + ) ;define + + (define (string-split str sep) + (define (split-characters input) + (let ((input-len (utf8-string-length input))) + (let loop ((i 0) + (parts '())) + (if (= i input-len) + (reverse parts) + (loop (+ i 1) + (cons (u8-substring input i (+ i 1)) + parts + ) ;cons + ) ;loop + ) ;if + ) ;let loop + ) ;let + ) ;define + + (when (not (string? str)) + (type-error "string-split: first parameter must be string") + ) ;when + + (let* ((sep-str (cond ((string? sep) sep) + ((char? sep) (string sep)) + (else (type-error "string-split: second parameter must be string or char")) + ) ;cond + ) + (str-len (string-length str)) + (sep-len (string-length sep-str))) + (if (zero? sep-len) + (split-characters str) + (let loop ((search-start 0) + (parts '())) + (let ((next-pos (string-position sep-str str search-start))) + (if next-pos + (loop (+ next-pos sep-len) + (cons (substring str search-start next-pos) + parts + ) ;cons + ) ;loop + (reverse + (cons (substring str search-start str-len) + parts + ) ;cons + ) ;reverse + ) ;if + ) ;let + ) ;let loop + ) ;if + ) ;let* + ) ;define + + (define (string-replace str old new . rest) + ; 参数数量检查 + (when (> (length rest) 1) + (error 'wrong-number-of-args "string-replace: too many arguments")) + ; 参数类型检查 + (unless (string? str) (type-error "string-replace: str must be a string")) + (unless (string? old) (type-error "string-replace: old must be a string")) + (unless (string? new) (type-error "string-replace: new must be a string")) + (let ((count (if (null? rest) -1 (car rest)))) + (unless (integer? count) (type-error "string-replace: count must be an integer")) + (let ((str-len (string-length str)) + (old-len (string-length old))) + (cond + ; count = 0 时不替换 + ((zero? count) (string-copy str)) + ; 空 pattern 时在每个字符之间插入 new + ((zero? old-len) + (if (zero? str-len) + new ; 空字符串 + 空 pattern = new + (let* ((max-inserts (+ str-len 1)) + (remaining (if (negative? count) max-inserts (min count max-inserts)))) + (let loop ((i 0) + (acc '()) + (r remaining)) + (cond + ((and (= i str-len) (> r 0)) + ; 字符已用完，但还有剩余的 count，添加末尾 new + (apply string-append (reverse (cons new acc)))) + ((= i str-len) + ; 字符已用完，没有剩余 count + (apply string-append (reverse acc))) + ((zero? r) + ; count 用完，添加剩余字符 + (apply string-append (reverse (cons (substring str i str-len) acc)))) + (else + (loop (+ i 1) + (cons (substring str i (+ i 1)) (cons new acc)) + (- r 1)))))))) + ; 正常替换逻辑 + (else + (let ((remaining (if (negative? count) -1 count))) + (let loop ((search-start 0) + (parts '()) + (r remaining)) + (let ((next-pos (string-position old str search-start))) + (if (and next-pos (not (zero? r))) + (loop (+ next-pos old-len) + (cons new + (cons (substring str search-start next-pos) + parts + ) ;cons + ) ;cons + (- r 1) + ) ;loop + (if (null? parts) + (string-copy str) + (apply string-append + (reverse + (cons (substring str search-start str-len) + parts + ) ;cons + ) ;reverse + ) ;apply + ) ;if + ) ;if + ) ;let + ) ;let loop + ) ;let remaining + ) ;else + ) ;cond + ) ;let + ) ;let + ) ;define + (define (string-ends? str suffix) (if (and (string? str) (string? suffix)) (string-suffix? suffix str) @@ -76,4 +208,3 @@ ) ;begin ) ;define-library - diff --git a/TeXmacs/plugins/goldfish/goldfish/scheme/cxr.scm b/TeXmacs/plugins/goldfish/goldfish/scheme/cxr.scm new file mode 100644 index 0000000000..18ede81fb9 --- /dev/null +++ b/TeXmacs/plugins/goldfish/goldfish/scheme/cxr.scm @@ -0,0 +1,25 @@ +; +; Copyright (C) 2026 The Goldfish Scheme Authors +; +; 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. +; + +(define-library (scheme cxr) + (export + caaar caadr cadar caddr cdaar cdadr cddar cdddr + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr + ) ;export + (begin + ) ;begin +) ;define-library diff --git a/TeXmacs/plugins/goldfish/goldfish/scheme/eval.scm b/TeXmacs/plugins/goldfish/goldfish/scheme/eval.scm new file mode 100644 index 0000000000..04a5524082 --- /dev/null +++ b/TeXmacs/plugins/goldfish/goldfish/scheme/eval.scm @@ -0,0 +1,32 @@ +; +; Copyright (C) 2026 The Goldfish Scheme Authors +; +; 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. +; + +(define-library (scheme eval) + (import (scheme base)) + (export environment eval) + (begin + + (define (environment . import-sets) + (let ((env (inlet))) + (when (not (null? import-sets)) + (eval (cons 'import import-sets) env) + ) ;when + env + ) ;let + ) ;define + + ) ;begin +) ;define-library diff --git a/TeXmacs/plugins/goldfish/goldfish/scheme/read.scm b/TeXmacs/plugins/goldfish/goldfish/scheme/read.scm new file mode 100644 index 0000000000..d4a06b0e54 --- /dev/null +++ b/TeXmacs/plugins/goldfish/goldfish/scheme/read.scm @@ -0,0 +1,21 @@ +; +; Copyright (C) 2026 The Goldfish Scheme Authors +; +; 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. +; + +(define-library (scheme read) + (export read) + (begin + ) ;begin +) ;define-library diff --git a/TeXmacs/plugins/goldfish/goldfish/scheme/write.scm b/TeXmacs/plugins/goldfish/goldfish/scheme/write.scm new file mode 100644 index 0000000000..bd47f6a867 --- /dev/null +++ b/TeXmacs/plugins/goldfish/goldfish/scheme/write.scm @@ -0,0 +1,27 @@ +; +; Copyright (C) 2026 The Goldfish Scheme Authors +; +; 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. +; + +(define-library (scheme write) + (export display write write-shared write-simple newline write-char) + (begin + + ; s7 does not currently expose separate built-ins for these two names. + (define write-simple write) + + (define write-shared write) + + ) ;begin +) ;define-library diff --git a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-214.scm b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-214.scm index de5529c1c2..eea327d695 100644 --- a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-214.scm +++ b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-214.scm @@ -184,7 +184,8 @@ (assume (integer? i)) (let* ((len (flexvector-length fv)) (v (if (< len (cap fv)) (vec fv) (grow! fv)))) - (assume (<= 0 i len)) + (when (or (< i 0) (> i len)) + (error 'value-error "flexvector-add!: index out of bounds")) (vector-copy! v (+ i 1) v i len) (vector-set! v i x) (set-flexvector-length! fv (+ len 1)) @@ -225,7 +226,8 @@ (v (let lp ((v (vec fv))) (if (< (+ len xvlen) (vector-length v)) v (lp (grow! fv))))) ) ;v - (assume (<= 0 i len)) + (when (or (< i 0) (> i len)) + (error 'value-error "flexvector-add!: index out of bounds")) (vector-copy! v (+ i xvlen) v i len) (vector-copy! v i xv 0 xvlen) (set-flexvector-length! fv (+ len xvlen)) diff --git a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-78.scm b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-78.scm index 6163e4fc77..fd3ed69728 100644 --- a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-78.scm +++ b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-78.scm @@ -38,14 +38,14 @@ ; Follow the same License as the original one (define-library (srfi srfi-78) - (import (liii lang)) + (import (scheme base)) (export check check-set-mode! check-report check-reset! check-passed? check-failed? check:proc ) ;export (begin - (define check:write display*) + (define check:write display) (define check:mode #f) @@ -157,7 +157,7 @@ (>= (length check:failed) 1) ) ;define - (define* (check:proc expression thunk expected-result (equal class=?)) + (define* (check:proc expression thunk expected-result (equal equal?)) (let ((location-info (check:get-source-location expression))) (case check:mode ((0) #f) diff --git a/TeXmacs/plugins/goldfish/src/goldfish.hpp b/TeXmacs/plugins/goldfish/src/goldfish.hpp index 68843bc8c8..6af3d12106 100644 --- a/TeXmacs/plugins/goldfish/src/goldfish.hpp +++ b/TeXmacs/plugins/goldfish/src/goldfish.hpp @@ -69,7 +69,7 @@ #include #endif -#define GOLDFISH_VERSION "17.11.32" +#define GOLDFISH_VERSION "17.11.35" #define GOLDFISH_PATH_MAXN TB_PATH_MAXN @@ -3365,10 +3365,16 @@ display_help () { cout << " fix [options] PATH Format PATH (PATH can be a .scm file or directory)" << endl; cout << " Options:" << endl; cout << " --dry-run Print formatted result to stdout" << endl; - cout << " test [options] Run tests (all *-test.scm files under tests/)" << endl; - cout << " Options:" << endl; - cout << " --only PATTERN Run tests matching PATTERN" << endl; - cout << " (e.g. json, sicp, list-test.scm)" << endl; + cout << " doc ORG/LIB Display exact library documentation from tests/" << endl; + cout << " doc FUNC Display exact function documentation from tests/" << endl; + cout << " doc --build-json Rebuild function-library-index.json under tests/" << endl; + cout << " test [PATTERN] Run tests (all *-test.scm files under tests/)" << endl; + cout << " PATTERN can be:" << endl; + cout << " (none) Run all tests" << endl; + cout << " FILE.scm Run specific test file" << endl; + cout << " DIR/ Run tests in directory" << endl; + cout << " name-test.scm Match by file name" << endl; + cout << " substring Match by path substring" << endl; cout << " run TARGET Run main function from TARGET" << endl; cout << " TARGET can be:" << endl; cout << " FILE.scm Load file and run main" << endl; @@ -3381,6 +3387,8 @@ display_help () { cout << endl; cout << "Options:" << endl; cout << " --mode, -m MODE Set mode: default, liii, sicp, r7rs, s7" << endl; + cout << " -I DIR Prepend DIR to library search path" << endl; + cout << " -A DIR Append DIR to library search path" << endl; cout << endl; cout << "If no command is specified, help is displayed by default." << endl; } @@ -3531,6 +3539,21 @@ find_goldtest_tool_root (const char* gf_lib) { return ""; } +static string +find_golddoc_tool_root (const char* gf_lib) { + std::error_code ec; + vector candidates= {fs::path (gf_lib) / "tools" / "golddoc", fs::path (gf_lib).parent_path () / "tools" / "golddoc"}; + + for (const auto& candidate : candidates) { + if (fs::is_directory (candidate, ec)) { + return candidate.string (); + } + ec.clear (); + } + + return ""; +} + static void add_goldfix_load_path_if_present (s7_scheme* sc, const char* gf_lib) { string tool_root= find_goldfix_tool_root (gf_lib); @@ -3732,7 +3755,7 @@ customize_goldfish_by_mode (s7_scheme* sc, string mode, const char* boot_file_pa } if (mode == "default" || mode == "liii") { - s7_eval_c_string (sc, "(import (liii base) (liii error) (liii oop))"); + s7_eval_c_string (sc, "(import (liii base) (liii error) (liii string))"); } else if (mode == "scheme") { s7_eval_c_string (sc, "(import (liii base) (liii error))"); @@ -4217,7 +4240,15 @@ goldfish_repl (s7_scheme* sc, const string& mode) { } #endif -// Parse command line options including --mode +struct StartupCliOptions { + string mode= "default"; + vector prepend_dirs; + vector append_dirs; + string command; + int command_index= -1; + string error; +}; + static std::string parse_mode_option (int argc, char** argv) { std::string mode= "default"; @@ -4236,63 +4267,246 @@ parse_mode_option (int argc, char** argv) { return mode; } -// Check if an option is valid (for --mode only) static bool -is_valid_global_option (const string& flag) { - return flag == "--mode" || flag == "-m" || flag.rfind ("--mode=", 0) == 0 || flag.rfind ("-m=", 0) == 0; +is_legacy_cli_command (const string& arg) { + return arg == "--help" || arg == "-h" || arg == "--version" || arg == "-v"; } -int -repl_for_community_edition (s7_scheme* sc, int argc, char** argv) { - string gf_lib_dir = find_goldfish_library (); - const char* gf_lib = gf_lib_dir.c_str (); - string gf_boot_path= find_goldfish_boot (gf_lib); - const char* gf_boot = gf_boot_path.c_str (); +static string +normalize_load_path_dir (const string& raw_dir) { + fs::path path (raw_dir); + string normalized= path.lexically_normal ().string (); + return normalized.empty () ? raw_dir : normalized; +} - // 供 goldfish `g_command-line` procedure 查询 - command_args.assign (argv, argv + argc); +static bool +load_path_directory_exists (const string& raw_dir) { + std::error_code ec; + fs::path path (normalize_load_path_dir (raw_dir)); + return fs::exists (path, ec) && fs::is_directory (path, ec); +} + +static bool +append_unique_string (vector& items, const string& raw_item) { + string item= normalize_load_path_dir (raw_item); + if (item.empty ()) return false; + if (std::find (items.begin (), items.end (), item) != items.end ()) return false; + items.push_back (item); + return true; +} + +static bool +is_plugin_name_part (const string& value) { + if (value.empty ()) return false; + return std::all_of (value.begin (), value.end (), [] (unsigned char ch) { return (ch >= 'a' && ch <= 'z') || (ch >= '0' && ch <= '9'); }); +} + +static bool +is_auto_goldfish_plugin_dir_name (const string& name) { + size_t dash_pos= name.find ('-'); + if (dash_pos == string::npos || dash_pos == 0 || dash_pos == name.length () - 1) { + return false; + } + if (name.find ('-', dash_pos + 1) != string::npos) { + return false; + } + return is_plugin_name_part (name.substr (0, dash_pos)) && is_plugin_name_part (name.substr (dash_pos + 1)); +} + +static bool +directory_contains_scheme_sources (const fs::path& dir) { + std::error_code ec; + for (fs::recursive_directory_iterator it (dir, fs::directory_options::skip_permission_denied, ec), end; it != end; + it.increment (ec)) { + if (ec) { + ec.clear (); + continue; + } + if (it->is_regular_file (ec) && it->path ().extension () == ".scm") { + return true; + } + ec.clear (); + } + return false; +} + +static vector +discover_auto_goldfish_library_dirs () { + vector dirs; + const char* home= getenv ("HOME"); + if ((!home) || (!*home)) { + return dirs; + } + + std::error_code ec; + fs::path root= fs::path (home) / ".local" / "goldfish"; + if (!fs::exists (root, ec) || !fs::is_directory (root, ec)) { + return dirs; + } + + for (fs::directory_iterator it (root, fs::directory_options::skip_permission_denied, ec), end; it != end; it.increment (ec)) { + if (ec) { + ec.clear (); + continue; + } + if (!it->is_directory (ec)) { + ec.clear (); + continue; + } + + string name= it->path ().filename ().string (); + if (!is_auto_goldfish_plugin_dir_name (name)) { + ec.clear (); + continue; + } + if (!directory_contains_scheme_sources (it->path ())) { + ec.clear (); + continue; + } + + append_unique_string (dirs, it->path ().string ()); + ec.clear (); + } + + std::sort (dirs.begin (), dirs.end ()); + return dirs; +} - // 解析 mode 选项 - std::string mode= parse_mode_option (argc, argv); +static vector +current_load_path_entries (s7_scheme* sc) { + vector entries; + for (s7_pointer rest= s7_load_path (sc); s7_is_pair (rest); rest= s7_cdr (rest)) { + s7_pointer entry= s7_car (rest); + if (s7_is_string (entry)) { + append_unique_string (entries, string (s7_string (entry))); + } + } + return entries; +} + +static void +set_load_path_entries (s7_scheme* sc, const vector& entries) { + s7_pointer list= s7_nil (sc); + for (auto it= entries.rbegin (); it != entries.rend (); ++it) { + list= s7_cons (sc, s7_make_string (sc, it->c_str ()), list); + } + s7_symbol_set_value (sc, s7_make_symbol (sc, "*load-path*"), list); +} + +static void +prepend_load_path_entries (s7_scheme* sc, const vector& prepend_dirs) { + vector seen= current_load_path_entries (sc); + for (auto it= prepend_dirs.rbegin (); it != prepend_dirs.rend (); ++it) { + string dir= normalize_load_path_dir (*it); + if (dir.empty ()) continue; + if (std::find (seen.begin (), seen.end (), dir) != seen.end ()) continue; + s7_add_to_load_path (sc, dir.c_str ()); + seen.insert (seen.begin (), dir); + } +} + +static void +append_load_path_entries (s7_scheme* sc, const vector& append_dirs) { + vector entries= current_load_path_entries (sc); + bool changed= false; + for (const auto& raw_dir : append_dirs) { + string dir= normalize_load_path_dir (raw_dir); + if (dir.empty ()) continue; + if (std::find (entries.begin (), entries.end (), dir) != entries.end ()) continue; + entries.push_back (dir); + changed= true; + } + if (changed) { + set_load_path_entries (sc, entries); + } +} + +static StartupCliOptions +parse_startup_cli_options (int argc, char** argv) { + StartupCliOptions opts; - // 查找第一个非选项参数作为命令（跳过 mode 选项） - string command; - int command_index= -1; for (int i= 1; i < argc; ++i) { string arg= argv[i]; + if (arg == "--mode" || arg == "-m") { - i++; // 跳过 mode 的值 + if ((i + 1) >= argc) { + opts.error= "Error: '--mode' requires a MODE argument."; + return opts; + } + opts.mode= argv[++i]; continue; } - if (arg.rfind ("--mode=", 0) == 0 || arg.rfind ("-m=", 0) == 0) { + if (arg.rfind ("--mode=", 0) == 0) { + opts.mode= arg.substr (7); continue; } - // 这不是 mode 选项，那就是命令 - command = arg; - command_index= i; - break; - } - - // 检查是否是 fix/test 子命令（它们有自己特殊的选项处理） - bool is_fix_command= (command == "fix"); - bool is_test_command= (command == "test"); - - // 检查无效的全局选项（除了 --mode 之外的其他选项都不再支持） - // 只检查命令之前的选项，命令之后的参数属于脚本 - // fix/test 子命令有自己的选项解析逻辑，这里跳过对它们的选项检查 - if (!is_fix_command && !is_test_command) { - int limit= (command_index > 0) ? command_index : argc; - for (int i= 1; i < limit; ++i) { - string arg= argv[i]; - if (arg.length () > 0 && arg[0] == '-') { - if (!is_valid_global_option (arg)) { - std::cerr << "Invalid option: " << arg << "\n\n"; - display_help (); - exit (1); - } + if (arg.rfind ("-m=", 0) == 0) { + opts.mode= arg.substr (3); + continue; + } + + if (arg == "-I" || arg == "-A") { + if ((i + 1) >= argc) { + opts.error= "Error: '" + arg + "' requires a DIRECTORY argument."; + return opts; + } + string dir= argv[++i]; + if (!load_path_directory_exists (dir)) { + opts.error= "Error: directory does not exist: " + dir; + return opts; + } + if (arg == "-I") { + append_unique_string (opts.prepend_dirs, dir); + } + else { + append_unique_string (opts.append_dirs, dir); } + continue; + } + + if (is_legacy_cli_command (arg) || arg.empty () || arg[0] != '-') { + opts.command = arg; + opts.command_index= i; + break; } + + opts.error= "Invalid option: " + arg; + return opts; + } + + return opts; +} + +static void +apply_startup_load_path_options (s7_scheme* sc, const StartupCliOptions& opts) { + vector prepend_dirs= opts.prepend_dirs; + for (const auto& dir : discover_auto_goldfish_library_dirs ()) { + append_unique_string (prepend_dirs, dir); } + prepend_load_path_entries (sc, prepend_dirs); + append_load_path_entries (sc, opts.append_dirs); +} + +int +repl_for_community_edition (s7_scheme* sc, int argc, char** argv) { + string gf_lib_dir = find_goldfish_library (); + const char* gf_lib = gf_lib_dir.c_str (); + string gf_boot_path= find_goldfish_boot (gf_lib); + const char* gf_boot = gf_boot_path.c_str (); + + // 供 goldfish `g_command-line` procedure 查询 + command_args.assign (argv, argv + argc); + + StartupCliOptions startup_opts= parse_startup_cli_options (argc, argv); + if (!startup_opts.error.empty ()) { + std::cerr << startup_opts.error << "\n\n"; + display_help (); + exit (1); + } + + string command = startup_opts.command; + int command_index= startup_opts.command_index; + string mode = parse_mode_option (argc, argv); // 如果没有找到命令或没有参数，显示帮助 if (argc <= 1 || command.empty ()) { @@ -4317,6 +4531,7 @@ repl_for_community_edition (s7_scheme* sc, int argc, char** argv) { exit (1); } + apply_startup_load_path_options (sc, startup_opts); customize_goldfish_by_mode (sc, mode, gf_boot); // start capture error output @@ -4488,11 +4703,10 @@ repl_for_community_edition (s7_scheme* sc, int argc, char** argv) { } s7_add_to_load_path (sc, goldtest_root.c_str ()); - // Load the goldtest.scm file - string goldtest_scm = goldtest_root + "/liii/goldtest.scm"; - s7_pointer load_result = s7_load (sc, goldtest_scm.c_str ()); - if (!load_result) { - cerr << "Error: Failed to load " << goldtest_scm << endl; + // Import (liii goldtest) module + s7_pointer import_result = s7_eval_c_string (sc, "(import (liii goldtest))"); + if (!import_result) { + cerr << "Error: Failed to import (liii goldtest) module." << endl; s7_close_output_port (sc, s7_current_error_port (sc)); s7_set_current_error_port (sc, old_port); if (gc_loc != -1) s7_gc_unprotect_at (sc, gc_loc); @@ -4500,28 +4714,80 @@ repl_for_community_edition (s7_scheme* sc, int argc, char** argv) { } errmsg = s7_get_output_string (sc, s7_current_error_port (sc)); if ((errmsg) && (*errmsg)) { - cerr << "Error loading goldtest.scm: " << errmsg << endl; + cerr << "Error importing (liii goldtest): " << errmsg << endl; s7_close_output_port (sc, s7_current_error_port (sc)); s7_set_current_error_port (sc, old_port); if (gc_loc != -1) s7_gc_unprotect_at (sc, gc_loc); exit (1); } - // Get the run-goldtest function - s7_pointer run_goldtest = s7_name_to_value (sc, "run-goldtest"); - if ((!run_goldtest) || (!s7_is_procedure (run_goldtest))) { - cerr << "Error: Failed to find run-goldtest function." << endl; + // Get and call the main function from (liii goldtest) + s7_pointer main_func = s7_name_to_value (sc, "main"); + if ((!main_func) || (!s7_is_procedure (main_func))) { + cerr << "Error: Failed to find main function in (liii goldtest)." << endl; s7_close_output_port (sc, s7_current_error_port (sc)); s7_set_current_error_port (sc, old_port); if (gc_loc != -1) s7_gc_unprotect_at (sc, gc_loc); exit (1); } - s7_call (sc, run_goldtest, s7_nil (sc)); + s7_pointer result = s7_call (sc, main_func, s7_nil (sc)); errmsg = s7_get_output_string (sc, s7_current_error_port (sc)); if ((errmsg) && (*errmsg)) cout << errmsg; s7_close_output_port (sc, s7_current_error_port (sc)); s7_set_current_error_port (sc, old_port); if (gc_loc != -1) s7_gc_unprotect_at (sc, gc_loc); + if (s7_is_integer (result)) { + return static_cast (s7_integer (result)); + } + return 0; + } + + // 处理 doc 子命令 + if (command == "doc") { + string golddoc_root = find_golddoc_tool_root (gf_lib); + if (golddoc_root.empty ()) { + cerr << "Error: tools/golddoc directory not found." << endl; + s7_close_output_port (sc, s7_current_error_port (sc)); + s7_set_current_error_port (sc, old_port); + if (gc_loc != -1) s7_gc_unprotect_at (sc, gc_loc); + exit (1); + } + s7_add_to_load_path (sc, golddoc_root.c_str ()); + + s7_pointer import_result = s7_eval_c_string (sc, "(import (liii golddoc))"); + if (!import_result) { + cerr << "Error: Failed to import (liii golddoc) module." << endl; + s7_close_output_port (sc, s7_current_error_port (sc)); + s7_set_current_error_port (sc, old_port); + if (gc_loc != -1) s7_gc_unprotect_at (sc, gc_loc); + exit (1); + } + errmsg = s7_get_output_string (sc, s7_current_error_port (sc)); + if ((errmsg) && (*errmsg)) { + cerr << "Error importing (liii golddoc): " << errmsg << endl; + s7_close_output_port (sc, s7_current_error_port (sc)); + s7_set_current_error_port (sc, old_port); + if (gc_loc != -1) s7_gc_unprotect_at (sc, gc_loc); + exit (1); + } + + s7_pointer main_func = s7_name_to_value (sc, "main"); + if ((!main_func) || (!s7_is_procedure (main_func))) { + cerr << "Error: Failed to find main function in (liii golddoc)." << endl; + s7_close_output_port (sc, s7_current_error_port (sc)); + s7_set_current_error_port (sc, old_port); + if (gc_loc != -1) s7_gc_unprotect_at (sc, gc_loc); + exit (1); + } + s7_pointer result = s7_call (sc, main_func, s7_nil (sc)); + errmsg = s7_get_output_string (sc, s7_current_error_port (sc)); + if ((errmsg) && (*errmsg)) cout << errmsg; + s7_close_output_port (sc, s7_current_error_port (sc)); + s7_set_current_error_port (sc, old_port); + if (gc_loc != -1) s7_gc_unprotect_at (sc, gc_loc); + if (s7_is_integer (result)) { + return static_cast (s7_integer (result)); + } return 0; } diff --git a/devel/200_21.md b/devel/200_21.md index ba43fe5d24..5f870806e1 100644 --- a/devel/200_21.md +++ b/devel/200_21.md @@ -9,6 +9,8 @@ xmake run stem ```sh ./bin/bump_goldfish v17.11.xx ``` +## 2026/02/27 升级到Goldfish Scheme v17.11.35 + ## 2026/02/27 升级到Goldfish Scheme v17.11.32