From 88487a69a9f8be1d5c8845ab594028402480893f Mon Sep 17 00:00:00 2001 From: Darcy Shen Date: Sun, 12 Jan 2025 22:11:16 +0800 Subject: [PATCH] [61_7] Upgrade to Goldfish Scheme 17.11.2 --- .../plugins/goldfish/goldfish/liii/alist.scm | 18 +- .../plugins/goldfish/goldfish/liii/base.scm | 158 ++++- .../plugins/goldfish/goldfish/liii/case.scm | 1 + .../plugins/goldfish/goldfish/liii/chez.scm | 26 + .../plugins/goldfish/goldfish/liii/cut.scm | 20 + .../plugins/goldfish/goldfish/liii/error.scm | 4 +- .../plugins/goldfish/goldfish/liii/lang.scm | 486 ++++++++++++++++ .../plugins/goldfish/goldfish/liii/list.scm | 35 +- TeXmacs/plugins/goldfish/goldfish/liii/os.scm | 59 +- .../plugins/goldfish/goldfish/liii/path.scm | 69 ++- .../plugins/goldfish/goldfish/liii/sort.scm | 22 + .../plugins/goldfish/goldfish/liii/string.scm | 1 + .../plugins/goldfish/goldfish/liii/sys.scm | 5 +- .../plugins/goldfish/goldfish/liii/uuid.scm | 1 + .../plugins/goldfish/goldfish/liii/vector.scm | 25 +- .../plugins/goldfish/goldfish/scheme/base.scm | 34 +- .../plugins/goldfish/goldfish/scheme/boot.scm | 2 +- .../goldfish/goldfish/scheme/inexact.scm | 25 + .../plugins/goldfish/goldfish/srfi/srfi-1.scm | 7 +- .../goldfish/goldfish/srfi/srfi-125.scm | 18 +- .../goldfish/goldfish/srfi/srfi-13.scm | 42 ++ .../goldfish/goldfish/srfi/srfi-132.scm | 111 ++++ .../goldfish/goldfish/srfi/srfi-133.scm | 41 +- .../goldfish/goldfish/srfi/srfi-151.scm | 1 + .../goldfish/goldfish/srfi/srfi-26.scm | 70 +++ .../goldfish/goldfish/srfi/srfi-78.scm | 4 +- TeXmacs/plugins/goldfish/src/goldfish.cpp | 9 +- TeXmacs/plugins/goldfish/src/goldfish.hpp | 539 ++++++++++++------ xmake/packages/s/s7/port/xmake.lua | 2 + xmake/packages/s/s7/xmake.lua | 2 +- xmake/vars.lua | 2 +- 31 files changed, 1577 insertions(+), 262 deletions(-) create mode 100644 TeXmacs/plugins/goldfish/goldfish/liii/chez.scm create mode 100644 TeXmacs/plugins/goldfish/goldfish/liii/cut.scm create mode 100644 TeXmacs/plugins/goldfish/goldfish/liii/lang.scm create mode 100644 TeXmacs/plugins/goldfish/goldfish/liii/sort.scm create mode 100644 TeXmacs/plugins/goldfish/goldfish/scheme/inexact.scm create mode 100644 TeXmacs/plugins/goldfish/goldfish/srfi/srfi-132.scm create mode 100644 TeXmacs/plugins/goldfish/goldfish/srfi/srfi-26.scm diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/alist.scm b/TeXmacs/plugins/goldfish/goldfish/liii/alist.scm index 42ae91de91..c6743a55b8 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/alist.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/alist.scm @@ -4,11 +4,16 @@ (define-library (liii alist) (import (liii base) + (liii list) (liii error) (scheme case-lambda)) -(export alist-ref alist-ref/default) +(export alist? alist-cons alist-ref alist-ref/default vector->alist) (begin +(define (alist? l) + (and (list? l) + (every pair? l))) + (define alist-ref (case-lambda ((alist key) @@ -31,6 +36,17 @@ ((alist key default =) (alist-ref alist key (lambda () default) =)))) +; MIT License +; Copyright guenchi (c) 2018 - 2019 +(define vector->alist + (typed-lambda ((x vector?)) + (if (zero? (length x)) '() + (let loop ((x (vector->list x)) (n 0)) + (cons (cons n (car x)) + (if (null? (cdr x)) + '() + (loop (cdr x) (+ n 1)))))))) + ) ; end of begin ) ; end of library diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/base.scm b/TeXmacs/plugins/goldfish/goldfish/liii/base.scm index aefb779f6c..8374ebe7cc 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/base.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/base.scm @@ -24,7 +24,7 @@ ; R7RS 5: Program Structure define-values define-record-type ; R7RS 6.2: Numbers - square exact inexact floor s7-floor ceiling s7-ceiling truncate s7-truncate + square exact inexact max min floor s7-floor ceiling s7-ceiling truncate s7-truncate round s7-round floor-quotient gcd lcm s7-lcm ; R7RS 6.3: Booleans boolean=? @@ -55,21 +55,26 @@ and-let* ; SRFI-8 receive - ; Extra routines for (liii base) - == != display* in? let1 compose identity typed-lambda + ; Extra routines + loose-car loose-cdr in? compose identity any? + ; Extra structure + let1 typed-lambda typed-define define-case-class case-class? + == != display* object->string ) (begin (define* (u8-substring str (start 0) (end #t)) (utf8->string (string->utf8 str start end))) -(define == equal?) +(define (loose-car pair-or-empty) + (if (eq? '() pair-or-empty) + '() + (car pair-or-empty))) -(define (!= left right) - (not (equal? left right))) - -(define (display* . params) - (for-each display params)) +(define (loose-cdr pair-or-empty) + (if (eq? '() pair-or-empty) + '() + (cdr pair-or-empty))) (define (in? elem l) (cond ((list? l) (not (not (member elem l)))) @@ -84,10 +89,6 @@ (in? elem (string->list l))) (else (error 'type-error "type mismatch")))) -(define-macro (let1 name1 value1 . body) - `(let ((,name1 ,value1)) - ,@body)) - (define identity (lambda (x) x)) (define (compose . fs) @@ -96,6 +97,12 @@ (lambda (x) ((car fs) ((apply compose (cdr fs)) x))))) +(define (any? x) #t) + +(define-macro (let1 name1 value1 . body) + `(let ((,name1 ,value1)) + ,@body)) + ; 0 clause BSD, from S7 repo stuff.scm (define-macro (typed-lambda args . body) ; (typed-lambda ((var [type])...) ...) @@ -116,6 +123,131 @@ args) ,@body)))) +(define-macro (typed-define name-and-params x . xs) + (let* ((name (car name-and-params)) + (params (cdr name-and-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)) + + ,@(map (lambda (param) + (let ((param-name (car param)) + (type-pred (cadr param))) + `(unless (,type-pred ,param-name) + (error 'type-error (string-append "Invalid type for " (symbol->string ',param-name)))))) + params) + ,x + ,@xs))) + +(define-macro (define-case-class class-name fields . extra-operations) + (let ((constructor (string->symbol (string-append (symbol->string class-name)))) + (key-fields (map (lambda (field) + (string->symbol (string-append ":" (symbol->string (car field))))) + fields))) + `(begin + (typed-define ,(cons class-name fields) + (define (%is-instance-of x) + (eq? x ',class-name)) + + (typed-define (%equals (that case-class?)) + (and (that :is-instance-of ',class-name) + ,@(map (lambda (field) + `(equal? ,(car field) (that ',(car field)))) + fields))) + + (define (%apply . args) + (when (null? args) + (??? ,class-name "apply on zero args is not implemented")) + (cond ((equal? ((symbol->string (car args)) 0) #\:) + (??? ,class-name + "No such method: " (car args) + "Please implement the method")) + (else + (??? ,class-name "No such field: " (car args) + "Please use the correct field name" + "Or you may implement %apply to process " 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)))))))) + + ,@extra-operations + + (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)) + + ,@(map (lambda (field) + `((eq? msg ',(car field)) ,(car field))) + fields) + ,@(map (lambda (field key-field) + `((eq? msg ,key-field) + (,constructor ,@(map (lambda (f) + (if (eq? (car f) (car field)) + '(car args) + (car f))) + fields)))) + fields key-fields) + + ,@(map (lambda (op) + `((eq? msg ,(string->symbol (string-append ":" (substring (symbol->string (caadr op)) 1)))) + (apply ,(caadr op) args))) + extra-operations) + + (else (apply %apply (cons msg args))))))))) + +(define (case-class? x) + (and-let* ((is-proc? (procedure? x)) + (source (procedure-source x)) + (body (source 2)) + (is-cond? (eq? (car body) 'cond)) + (at-least-2? (>= (length body) 3)) + (pred1 ((body 1) 0)) + (pred2 ((body 2) 0))) + (and (equal? pred1 '(eq? msg :is-instance-of)) + (equal? pred2 '(eq? msg :equals))))) + +(define (== left right) + (if (and (case-class? left) (case-class? right)) + (left :equals right) + (equal? left right))) + +(define (!= left right) + (not (== left right))) + +(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))) + ) ; end of begin ) ; end of define-library diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/case.scm b/TeXmacs/plugins/goldfish/goldfish/liii/case.scm index 7cde2e1551..68e575c57d 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/case.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/case.scm @@ -15,6 +15,7 @@ ; (define-library (liii case) +(import (liii base)) (export case*) (begin diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/chez.scm b/TeXmacs/plugins/goldfish/goldfish/liii/chez.scm new file mode 100644 index 0000000000..f58fe80c22 --- /dev/null +++ b/TeXmacs/plugins/goldfish/goldfish/liii/chez.scm @@ -0,0 +1,26 @@ +; +; 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 chez) +(export atom?) +(begin + +(define (atom? x) + (not (pair? x))) + +) ; end of begin +) ; end of define-library + diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/cut.scm b/TeXmacs/plugins/goldfish/goldfish/liii/cut.scm new file mode 100644 index 0000000000..f8b6e13938 --- /dev/null +++ b/TeXmacs/plugins/goldfish/goldfish/liii/cut.scm @@ -0,0 +1,20 @@ +; +; 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 cut) + (import (srfi srfi-26)) + (export cut cute)) + diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/error.scm b/TeXmacs/plugins/goldfish/goldfish/liii/error.scm index d087e3f08c..b8cf7b762d 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/error.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/error.scm @@ -48,8 +48,8 @@ (define (value-error . args) (apply error (cons 'value-error args))) -(define (???) - (error 'not-implemented-error "???")) +(define (??? . args) + (apply error (cons '??? args))) ) ; begin ) ; define-library diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/lang.scm b/TeXmacs/plugins/goldfish/goldfish/liii/lang.scm new file mode 100644 index 0000000000..a5545a67cf --- /dev/null +++ b/TeXmacs/plugins/goldfish/goldfish/liii/lang.scm @@ -0,0 +1,486 @@ +; +; 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 (liii base) (liii string) (liii vector) + (liii list) (liii hash-table) (liii bitwise)) +(export + option none + case-integer case-char case-string + case-list case-vector case-hash-table + box +) +(begin + +(define (%apply-one x xs r) + (let1 result r + (if (null? xs) r (apply r xs)))) + +(define-case-class option ((value any?)) + +(define (%get) + (if (null? value) + (value-error "option is empty, cannot get value") + value)) + +(define (%get-or-else default) + (if (null? value) + (if (procedure? default) (default) default) + value)) + +(define (%equals that) + (== value (that 'value))) + +(define (%defined?) (not (null? value))) + +(define (%empty?) (null? value)) + +(define (%map f . xs) + (%apply-one f xs + (if (null? value) + (option '()) + (option (f value))))) + +(define (%flat-map f . xs) + (let1 r (if (null? value) + (option '()) + (f value)) + (if (null? xs) r (apply r xs)))) + +(define (%filter pred . xs) + (let1 r (if (or (null? value) (not (pred value))) + (option '()) + (option value)) + (if (null? xs) r (apply r xs)))) + +) + +(define (none) (option '())) + +(define-case-class case-integer ((data integer?)) + +(define (%unbox) data) + +(typed-define (%to (n integer?)) + (if (< n data) + (case-list (list)) + (case-list (iota (+ (- n data) 1) data)))) + +(typed-define (%until (n integer?)) + (if (<= n data) + (case-list (list)) + (case-list (iota (+ (- n data)) data)))) + +(define (%to-char) + (case-char data)) + +(define (%to-string) + (number->string data)) + +) + +(define-case-class case-char ((code-point integer?)) + +(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)))) + +(define (%to-bytevector) + (cond + ((<= code-point #x7F) + (bytevector code-point)) + + ((<= code-point #x7FF) + (let ((byte1 (bitwise-ior #b11000000 (bitwise-and (arithmetic-shift code-point -6) #b00011111))) + (byte2 (bitwise-ior #b10000000 (bitwise-and code-point #b00111111)))) + (bytevector byte1 byte2))) + + ((<= code-point #xFFFF) + (let ((byte1 (bitwise-ior #b11100000 (bitwise-and (arithmetic-shift code-point -12) #b00001111))) + (byte2 (bitwise-ior #b10000000 (bitwise-and (arithmetic-shift code-point -6) #b00111111))) + (byte3 (bitwise-ior #b10000000 (bitwise-and code-point #b00111111)))) + (bytevector byte1 byte2 byte3))) + + ((<= code-point #x10FFFF) + (let ((byte1 (bitwise-ior #b11110000 (bitwise-and (arithmetic-shift code-point -18) #b00000111))) + (byte2 (bitwise-ior #b10000000 (bitwise-and (arithmetic-shift code-point -12) #b00111111))) + (byte3 (bitwise-ior #b10000000 (bitwise-and (arithmetic-shift code-point -6) #b00111111))) + (byte4 (bitwise-ior #b10000000 (bitwise-and code-point #b00111111)))) + (bytevector byte1 byte2 byte3 byte4))) + + (else + (value-error "Invalid code point")))) + +(define (%to-string) + (utf8->string (%to-bytevector))) + +) + +(define make-case-char case-char) + +(define (utf8-byte-sequence->code-point byte-seq) + (let ((len (bytevector-length byte-seq))) + (cond + ((= len 1) + (bytevector-u8-ref byte-seq 0)) + ((= len 2) + (let ((b1 (bytevector-u8-ref byte-seq 0)) + (b2 (bytevector-u8-ref byte-seq 1))) + (bitwise-ior + (arithmetic-shift (bitwise-and b1 #x1F) 6) + (bitwise-and b2 #x3F)))) + ((= len 3) + (let ((b1 (bytevector-u8-ref byte-seq 0)) + (b2 (bytevector-u8-ref byte-seq 1)) + (b3 (bytevector-u8-ref byte-seq 2))) + (bitwise-ior + (arithmetic-shift (bitwise-and b1 #x0F) 12) + (arithmetic-shift (bitwise-and b2 #x3F) 6) + (bitwise-and b3 #x3F)))) + ((= len 4) + (let ((b1 (bytevector-u8-ref byte-seq 0)) + (b2 (bytevector-u8-ref byte-seq 1)) + (b3 (bytevector-u8-ref byte-seq 2)) + (b4 (bytevector-u8-ref byte-seq 3))) + (bitwise-ior + (arithmetic-shift (bitwise-and b1 #x07) 18) + (arithmetic-shift (bitwise-and b2 #x3F) 12) + (arithmetic-shift (bitwise-and b3 #x3F) 6) + (bitwise-and b4 #x3F)))) + (else + (value-error "Invalid UTF-8 byte sequence length"))))) + +(define (case-char x) + (cond ((integer? x) + (if (and (>= x 0) (<= x #x10FFFF)) + (make-case-char x) + (value-error "case-char: code point out of range" x))) + ((string? x) + (if (= 1 (u8-string-length x)) + (case-char (string->utf8 x)) + (value-error "case-char: must be u8 string which length equals 1"))) + ((bytevector? x) + (make-case-char (utf8-byte-sequence->code-point x))) + (else (type-error "case-char: must be integer, string, bytevector")))) + +(define-case-class case-string ((data string?)) + +(define (%unbox) data) + +(define (%length) + (u8-string-length data)) + +(define (%char-at index) + (let* ((start index) + (end (+ index 1)) + (byte-seq (string->utf8 data start end)) + (code-point (utf8-byte-sequence->code-point byte-seq))) + (case-char byte-seq))) + +(typed-define (%apply (i integer?)) + (%char-at i)) + +(define (%empty?) + (string-null? data)) + +(define (%starts-with prefix) + (string-starts? data prefix)) + +(define (%ends-with suffix) + (string-ends? data suffix)) + +(define (%forall pred) + (string-every pred data)) + +(define (%exists pred) + (string-any pred data)) + +(define (%contains elem) + (cond ((string? elem) + (string-contains data elem)) + ((char? elem) + (string-contains data (string elem))) + (else (type-error "elem must be char or string")))) + +(define (%map x . xs) + (%apply-one x xs + (case-string (string-map x data)))) + +(define (%count pred?) + (string-count data pred?)) + +(define (%to-string) + data) + +) + +(define-case-class case-list ((data list?)) + +(define (%collect) data) + +(define (%apply n) + (list-ref data n)) + +(define (%find pred) + (let loop ((lst data)) + (cond + ((null? lst) (none)) + ((pred (car lst)) (option (car lst))) + (else (loop (cdr lst)))))) + +(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) + ((!= (car left) (car right)) #f) + (else (loop (cdr left) (cdr right)))))))) + +(define (%forall pred) + (every pred data)) + +(define (%exists pred) + (any pred data)) + +(define (%contains elem) + (%exists (lambda (x) (equal? x elem)))) + + (define (%map x . xs) + (let1 r (case-list (map x data)) + (if (null? xs) r (apply r xs)))) + + (define (%flat-map x . xs) + (let1 r (case-list (flat-map x data)) + (if (null? xs) r (apply r xs)))) + + (define (%filter x . xs) + (let1 r (case-list (filter x data)) + (if (null? xs) r (apply r xs)))) + + (define (%for-each x) + (for-each x data)) + + (define (%take x . xs) + (typed-define (scala-take (data list?) (n integer?)) + (cond ((< n 0) '()) + ((>= n (length data)) data) + (else (take data n)))) + + (let1 r (case-list (scala-take data x)) + (if (null? xs) r (apply r xs)))) + + (define (%take-right x . xs) + (typed-define (scala-take-right (data list?) (n integer?)) + (cond ((< n 0) '()) + ((>= n (length data)) data) + (else (take-right data n)))) + + (let1 r (case-list (scala-take-right data x)) + (if (null? xs) r (apply r xs)))) + + (define (%count . xs) + (cond ((null? xs) (length data)) + ((length=? 1 xs) (count (car xs) data)) + (else (error 'wrong-number-of-args "case-list%count" xs)))) + + (define (%fold initial f) + (fold f initial data)) + + (define (%fold-right initial f) + (fold-right f initial data)) + +(define (%to-string) + (object->string data)) + + (define (%make-string . xs) + (define (parse-args xs) + (cond + ((null? xs) (values "" "" "")) + ((length=? 1 xs) + (let1 sep (car xs) + (if (string? sep) + (values "" sep "") + (type-error "case-list%make-string: separator must be a string" sep)))) + ((length=? 2 xs) + (error 'wrong-number-of-args "case-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 "case-list%make-string: prefix, separator, and suffix must be strings" xs)))) + (else (error 'wrong-number-of-args "case-list%make-string: expected 0, 1, or 3 arguments" xs)))) + + (receive (start sep end) (parse-args xs) + (string-append start (string-join (map object->string data) sep) end))) + +) + +(define-case-class case-vector ((data vector?)) + +(define (%collect) data) + +(define (%apply n) + (vector-ref data n)) + + (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)))))) +(define (%equals that) + (vector= == data (that 'data))) + + (define (%forall p) + (vector-every p data)) + + (define (%map x . xs) + (let1 r (case-vector (vector-map x data)) + (if (null? xs) r (apply r xs)))) + + (define (%filter x . xs) + (let1 r (case-vector (vector-filter x data)) + (if (null? xs) r (apply r xs)))) + + (define (%for-each x) + (vector-for-each x data)) + + (define (%count . xs) + (cond ((null? xs) (vector-length data)) + ((length=? 1 xs) (vector-count (car xs) data)) + (else (error 'wrong-number-of-args "case-vector%count" xs)))) + + (define (%take x . xs) + (typed-define (scala-take (data vector?) (n integer?)) + (cond + ((< n 0) (vector)) + ((>= n (vector-length data)) data) + (else + (let ((new-vec (make-vector n))) + (do ((i 0 (+ i 1))) + ((>= i n) new-vec) + (vector-set! new-vec i (vector-ref data i))))))) + + (let1 r (case-vector (scala-take data x)) + (if (null? xs) r (apply r xs)))) + + (define (%take-right x . xs) + (typed-define (scala-take-right (data vector?) (n integer?)) + (let ((len (vector-length data))) + (cond + ((< n 0) (vector)) + ((>= n len) data) + (else + (let ((new-vec (make-vector n))) + (do ((i (- len n) (+ i 1)) + (j 0 (+ j 1))) + ((>= j n) new-vec) + (vector-set! new-vec j (vector-ref data i)))))))) + + (let1 r (case-vector (scala-take-right data x)) + (if (null? xs) r (apply r xs)))) + + (define (%fold initial f) + (vector-fold f initial data)) + + (define (%fold-right initial f) + (vector-fold-right f initial data)) + +(define (%to-string) + (object->string data)) + + (define (%make-string . xs) + (define (parse-args xs) + (cond + ((null? xs) (values "" "" "")) + ((length=? 1 xs) + (let1 sep (car xs) + (if (string? sep) + (values "" sep "") + (type-error "case-vector%make-string: separator must be a string" sep)))) + ((length=? 2 xs) + (error 'wrong-number-of-args "case-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 "case-vector%make-string: prefix, separator, and suffix must be strings" xs)))) + (else (error 'wrong-number-of-args "case-vector%make-string: expected 0, 1, or 3 arguments" xs)))) + + (receive (start sep end) (parse-args xs) + (string-append start (string-join (map object->string (vector->list data)) sep) end))) + +) + +(define-case-class case-hash-table ((data hash-table?)) + (define (%collect) data) + +(define (%map f . xs) + (%apply-one f xs + (let1 r (make-hash-table) + (hash-table-for-each + (lambda (k v) + (receive (k1 v1) (f k v) + (hash-table-set! r k1 v1))) + data) + (case-hash-table r)))) + +(define (%get k) + (option (hash-table-ref/default data k '()))) + +(define (%contains k) + (hash-table-contains? data k)) + +) + +(define (box x) + (cond ((integer? x) (case-integer x)) + ((char? x) (case-char (char->integer x))) + ((string? x) (case-string x)) + ((list? x) (case-list x)) + ((vector? x) (case-vector x)) + ((hash-table? x) (case-hash-table x)) + (else (type-error "box: x must be integer?, char?, string?, list?, vector?, hash-table?")))) + +) ; end of begin +) ; end of library + diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/list.scm b/TeXmacs/plugins/goldfish/goldfish/liii/list.scm index c4e056c729..3f60837d82 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/list.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/list.scm @@ -26,8 +26,10 @@ first second third fourth fifth sixth seventh eighth ninth tenth take drop take-right drop-right split-at last-pair last + ; SRFI 1: Miscellaneous: length, append, concatenate, reverse, zip & count + zip count ; SRFI 1: fold, unfold & map - count fold fold-right reduce reduce-right + fold fold-right reduce reduce-right filter partition remove append-map ; SRFI 1: Searching find any every list-index @@ -37,15 +39,19 @@ ; SRFI 1: Association List assoc assq assv alist-cons ; Liii List extensions - list-view flatmap + flat-map list-null? list-not-null? not-null-list? length=? length>? length>=? flatten ) (import (srfi srfi-1) - (liii error)) + (srfi srfi-13) + (liii error) + (liii case)) (begin (define (length=? x scheme-list) + (when (not (integer? x)) + (type-error "length=?: first parameter x must be an integer")) (when (< x 0) (value-error "length=?: expected non-negative integer x but received ~d" x)) (cond ((and (= x 0) (null? scheme-list)) #t) @@ -66,28 +72,7 @@ ((pair? lst) (loop (cdr lst) (+ cnt 1))) (else (<= len cnt))))) -(define (list-view scheme-list) - (define (f-inner-reducer scheme-list filter filter-func rest-funcs) - (cond ((null? rest-funcs) (list-view (filter filter-func scheme-list))) - (else - (f-inner-reducer (filter filter-func scheme-list) - (car rest-funcs) - (cadr rest-funcs) - (cddr rest-funcs))))) - (define (f-inner . funcs) - (cond ((null? funcs) scheme-list) - ((length=? 2 funcs) - (list-view ((car funcs) (cadr funcs) scheme-list))) - ((even? (length funcs)) - (f-inner-reducer scheme-list - (car funcs) - (cadr funcs) - (cddr funcs))) - (else (error 'wrong-number-of-args - "list-view only accepts even number of args")))) - f-inner) - -(define flatmap append-map) +(define flat-map append-map) (define (not-null-list? l) (cond ((pair? l) diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/os.scm b/TeXmacs/plugins/goldfish/goldfish/liii/os.scm index d60ee5b384..c7525d1274 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/os.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/os.scm @@ -26,22 +26,12 @@ (liii string)) (begin -(define (os-call command) - (g_os-call command)) - -(define (system command) - (g_system command)) - (define (os-arch) (g_os-arch)) (define (os-type) (g_os-type)) -(define (os-windows?) - (let ((name (os-type))) - (and name (string=? name "Windows")))) - (define (os-linux?) (let ((name (os-type))) (and name (string=? name "Linux")))) @@ -50,6 +40,10 @@ (let ((name (os-type))) (and name (string=? name "Darwin")))) +(define (os-windows?) + (let ((name (os-type))) + (and name (string=? name "Windows")))) + (define (os-sep) (if (os-windows?) #\\ @@ -60,17 +54,6 @@ #\; #\:)) -(define (os-temp-dir) - (let1 temp-dir (g_os-temp-dir) - (string-remove-suffix temp-dir (string (os-sep))))) - -(define (access path mode) - (cond ((eq? mode 'F_OK) (g_access path 0)) - ((eq? mode 'X_OK) (g_access path 1)) - ((eq? mode 'W_OK) (g_access path 2)) - ((eq? mode 'R_OK) (g_access path 4)) - (else (error 'value-error "Allowed mode 'F_OK, 'X_OK,'W_OK, 'R_OK")))) - (define (%check-dir-andthen path f) (cond ((not (file-exists? path)) (file-not-found-error @@ -80,29 +63,45 @@ (string-append "Not a directory: '" path "'"))) (else (f path)))) +(define (os-call command) + (g_os-call command)) + +(define (system command) + (g_system command)) + +(define (access path mode) + (cond ((eq? mode 'F_OK) (g_access path 0)) + ((eq? mode 'X_OK) (g_access path 128)) + ((eq? mode 'W_OK) (g_access path 2)) + ((eq? mode 'R_OK) (g_access path 1)) + (else (error 'value-error "Allowed mode 'F_OK, 'X_OK,'W_OK, 'R_OK")))) + +(define (getenv key) + (get-environment-variable key)) + +(define (unsetenv key) + (g_unsetenv key)) + +(define (os-temp-dir) + (let1 temp-dir (g_os-temp-dir) + (string-remove-suffix temp-dir (string (os-sep))))) + (define (mkdir path) (if (file-exists? path) (file-exists-error (string-append "File exists: '" path "'")) (g_mkdir path))) +(define (rmdir path) + (%check-dir-andthen path delete-file)) (define (chdir path) (if (file-exists? path) (g_chdir path) (file-not-found-error (string-append "No such file or directory: '" path "'")))) -(define (rmdir path) - (%check-dir-andthen path delete-file)) - (define (listdir path) (%check-dir-andthen path g_listdir)) -(define (getenv key) - (get-environment-variable key)) - -(define (unsetenv key) - (g_unsetenv key)) - (define (getcwd) (g_getcwd)) diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/path.scm b/TeXmacs/plugins/goldfish/goldfish/liii/path.scm index 81d978772c..8d28cccd2a 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/path.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/path.scm @@ -16,11 +16,65 @@ (define-library (liii path) (export - path-dir? path-file? path-exists? path-getsize + make-path path-parts path-absolute? + path->string + path-dir? path-file? path-exists? + path-getsize path-read-text path-write-text ) -(import (liii error)) +(import (liii error) (liii vector) (liii string) (liii list)) (begin +(define-record-type :path + (%make-path parts type drive) + path? + (parts path-parts) + (type path-type) + (drive path-drive)) + +(define (%check-posix-parts parts) + (when (vector-empty? parts) + (value-error "make-path: parts must not be emtpy for posix path")) + (let1 N (vector-length parts) + (let loop ((i 0)) + (when (< i (- N 1)) + (when (string-null? (parts i)) + (value-error "make-path: part of path must not be empty string, index" i)) + (loop (+ i 1)))) + (let loop ((i 1)) + (when (< i N) + (when (string-index (parts i) #\/) + (value-error "make-path: non-first part of path must not contains /")) + (loop (+ i 1)))))) + +(define* (make-path parts (type 'posix) (drive "")) + (when (not (vector? parts)) + (type-error "make-path: parts must be a vector")) + + (case type + ((posix) (%check-posix-parts parts))) + + (case type + ((posix) + (%make-path parts type drive)) + (else (value-error "make-path: invalid type" type)))) + +(define path-absolute? + (typed-lambda ((path path?)) + (case (path-type path) + ((posix) + (string-starts? ((path-parts path) 0) "/")) + (else (value-error "path-absolute?: invalid type of path" (path-type path)))))) + +(define path->string + (typed-lambda ((path path?)) + (case (path-type path) + ((posix) + (let1 s (string-join (vector->list (path-parts path)) (string #\/)) + (if (string-starts? s "//") + (string-drop s 1) + s))) + (else (value-error "path->string: invalid type of path" (path-type path)))))) + (define (path-dir? path) (g_isdir path)) @@ -37,6 +91,17 @@ (string-append "No such file or directory: '" path "'")) (g_path-getsize path)))) +(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 "'")) + (g_path-read-text path)))) + +(define path-write-text + (typed-lambda ((path string?) (content string?)) + (g_path-write-text path content))) + ) ; end of begin ) ; end of define-library diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/sort.scm b/TeXmacs/plugins/goldfish/goldfish/liii/sort.scm new file mode 100644 index 0000000000..50beef812d --- /dev/null +++ b/TeXmacs/plugins/goldfish/goldfish/liii/sort.scm @@ -0,0 +1,22 @@ +; +; 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 sort) +(export list-sorted? vector-sorted? + list-merge list-sort list-stable-sort vector-merge vector-sort vector-stable-sort + list-merge! list-sort! list-stable-sort! vector-merge! vector-sort! vector-stable-sort!) +(import (srfi srfi-132))) + diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/string.scm b/TeXmacs/plugins/goldfish/goldfish/liii/string.scm index 0d494b89bc..7cc37c9af5 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/string.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/string.scm @@ -29,6 +29,7 @@ string-index string-index-right string-contains string-count string-upcase string-downcase + string-fold string-fold-right string-for-each-index string-reverse string-tokenize ; Liii extras diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/sys.scm b/TeXmacs/plugins/goldfish/goldfish/liii/sys.scm index 24a70449b6..4f0efad157 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/sys.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/sys.scm @@ -15,11 +15,14 @@ ; (define-library (liii sys) -(export argv) +(export argv executable) (import (scheme process-context)) (begin (define (argv) (command-line)) +(define (executable) (g_executable)) + ) ; end of begin ) ; end of define-library + diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/uuid.scm b/TeXmacs/plugins/goldfish/goldfish/liii/uuid.scm index 72f029a33f..daff1986ab 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/uuid.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/uuid.scm @@ -22,3 +22,4 @@ ) ; end of begin ) ; end of define-library + diff --git a/TeXmacs/plugins/goldfish/goldfish/liii/vector.scm b/TeXmacs/plugins/goldfish/goldfish/liii/vector.scm index 66dcc497a7..f8f8d7f26a 100644 --- a/TeXmacs/plugins/goldfish/goldfish/liii/vector.scm +++ b/TeXmacs/plugins/goldfish/goldfish/liii/vector.scm @@ -16,6 +16,7 @@ (define-library (liii vector) (import (srfi srfi-133) + (srfi srfi-13) (liii base)) (export ; S7 Scheme built-in @@ -25,13 +26,33 @@ vector-map vector-for-each ; from (srfi srfi-133) vector-empty? + vector-fold vector-fold-right vector-count vector-any vector-every vector-copy vector-copy! - vector-index vector-index-right vector-partition + vector-index vector-index-right vector-skip vector-skip-right vector-partition vector-swap! vector-cumulate reverse-list->vector - vector=) + vector= + ; Liii Extras + vector-filter +) (begin +(define (vector-filter pred vec) + (let* ((result-list (vector-fold (lambda (elem acc) + (if (pred elem) + (cons elem acc) + acc)) + '() + vec)) + (result-length (length result-list)) + (result-vec (make-vector result-length))) + (let loop ((i (- result-length 1)) (lst result-list)) + (if (null? lst) + result-vec + (begin + (vector-set! result-vec i (car lst)) + (loop (- i 1) (cdr lst))))))) + ) ; end of begin ) ; end of define-library diff --git a/TeXmacs/plugins/goldfish/goldfish/scheme/base.scm b/TeXmacs/plugins/goldfish/goldfish/scheme/base.scm index edae90cc25..503664a399 100644 --- a/TeXmacs/plugins/goldfish/goldfish/scheme/base.scm +++ b/TeXmacs/plugins/goldfish/goldfish/scheme/base.scm @@ -20,7 +20,7 @@ ; R7RS 5: Program Structure define-values define-record-type ; R7RS 6.2: Numbers - square exact inexact floor s7-floor ceiling s7-ceiling truncate s7-truncate + square exact inexact max min floor s7-floor ceiling s7-ceiling truncate s7-truncate round s7-round floor-quotient gcd lcm s7-lcm boolean=? ; R7RS 6.4: list pair? cons car cdr set-car! set-cdr! caar cadr cdar cddr @@ -121,6 +121,38 @@ (define inexact exact->inexact) +(define s7-max max) + +(define (max2 x y) + (when (or (not (real? x)) (not (real? y))) + (error 'type-error "max: parameter must be real number")) + (if (or (inexact? x) (inexact? y)) + (inexact (s7-max x y)) + (s7-max x y))) + +(define (max x . xs) + (let loop ((current-max x) (remaining xs)) + (if (null? remaining) + current-max + (loop (max2 current-max (car remaining)) + (cdr remaining))))) + +(define s7-min min) + +(define (min2 x y) + (when (or (not (real? x)) (not (real? y))) + (error 'type-error "min: parameter must be real number")) + (if (or (inexact? x) (inexact? y)) + (inexact (s7-min x y)) + (s7-min x y))) + +(define (min x . xs) + (let loop ((current-min x) (remaining xs)) + (if (null? remaining) + current-min + (loop (min2 current-min (car remaining)) + (cdr remaining))))) + (define s7-floor floor) (define (floor x) diff --git a/TeXmacs/plugins/goldfish/goldfish/scheme/boot.scm b/TeXmacs/plugins/goldfish/goldfish/scheme/boot.scm index 887cbf5a86..0e2766ad17 100644 --- a/TeXmacs/plugins/goldfish/goldfish/scheme/boot.scm +++ b/TeXmacs/plugins/goldfish/goldfish/scheme/boot.scm @@ -2,7 +2,7 @@ (if (string? path) (if (not (g_access path 0)) ; F_OK #f - (if (g_access path 4) ; R_OK + (if (g_access path 1) ; R_OK #t (error 'permission-error (string-append "No permission: " path)))) (error 'type-error "(file-exists? path): path should be string"))) diff --git a/TeXmacs/plugins/goldfish/goldfish/scheme/inexact.scm b/TeXmacs/plugins/goldfish/goldfish/scheme/inexact.scm new file mode 100644 index 0000000000..f183fcf682 --- /dev/null +++ b/TeXmacs/plugins/goldfish/goldfish/scheme/inexact.scm @@ -0,0 +1,25 @@ +; +; 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. +; + +; The (scheme inexact) library exports procedures which are typically only +; useful with inexact values +(define-library (scheme inexact) +(export acos asin atan cos exp finite? infinite? log nan? sin sqrt tan) +(begin + +) ; end of begin +) ; end of define-library + diff --git a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-1.scm b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-1.scm index 05104690e6..609280798d 100644 --- a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-1.scm +++ b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-1.scm @@ -22,9 +22,11 @@ ; SRFI 1: Selectors first second third fourth fifth sixth seventh eighth ninth tenth - take drop take-right drop-right count fold fold-right split-at + take drop take-right drop-right fold fold-right split-at reduce reduce-right append-map filter partition remove find delete delete-duplicates + ; SRFI 1: Miscellaneous: length, append, concatenate, reverse, zip & count + zip count ; SRFI 1: Association List assoc assq assv alist-cons take-while drop-while list-index any every @@ -141,6 +143,9 @@ (if (null-list? lis) i (lp (cdr lis) (if (pred (car lis)) (+ i 1) i))))) +(define (zip . lists) + (apply map list lists)) + (define (fold f initial l) (when (not (procedure? f)) (error 'type-error "The first param must be a procedure")) diff --git a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-125.scm b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-125.scm index c059b53fc4..9a7f87fdd3 100644 --- a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-125.scm +++ b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-125.scm @@ -69,9 +69,9 @@ (define (hash-table=? ht1 ht2) (equal? ht1 ht2)) -(define-macro (hash-table-ref/default ht key default) - `(or (hash-table-ref ,ht ,key) - ,default)) +(define (hash-table-ref/default ht key default) + (or (hash-table-ref ht key) + (if (procedure? default) (default) default))) (define (hash-table-set! ht . rest) (assert-hash-table-type ht hash-table-set!) @@ -119,6 +119,18 @@ (vs (hash-table-values ht))) (values ks vs)))) +(define (hash-table-find proc ht failure) + (let ((keys (hash-table-keys ht))) + (let loop ((keys keys)) + (if (null? keys) + (if (procedure? failure) + (failure) + failure) + (let* ((key (car keys)) + (value (hash-table-ref ht key))) + (if (proc key value) + value + (loop (cdr keys)))))))) (define hash-table-count (typed-lambda ((pred? procedure?) (ht hash-table?)) diff --git a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-13.scm b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-13.scm index 44d5d5b445..d2136ce23d 100644 --- a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-13.scm +++ b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-13.scm @@ -28,6 +28,7 @@ string-index string-index-right string-contains string-count string-upcase string-downcase + string-fold string-fold-right string-for-each-index string-reverse string-tokenize) (begin @@ -277,6 +278,8 @@ (loop (+ i 1))))))) (define (string-count str char/pred? . start+end) + (when (not (string? str)) + (type-error "string-count: first parameter must be string")) (let ((str-sub (%string-from-range str start+end)) (criterion (%make-criterion char/pred?))) (count criterion (string->list str-sub)))) @@ -312,6 +315,45 @@ (substring str end)))) (else (error 'wrong-number-of-args "string-reverse")))) +(define (string-fold kons knil s . rest) + (when (not (procedure? kons)) + (type-error "string-fold: first argument must be a procedure")) + (when (not (string? s)) + (type-error "string-fold: second argument must be a string")) + + (let ((substr (%string-from-range s rest))) + (let loop ((i 0) + (result knil)) + (if (= i (string-length substr)) + result + (loop (+ i 1) + (kons (string-ref substr i) result)))))) + +(define (string-fold-right kons knil s . rest) + (when (not (procedure? kons)) + (type-error "string-fold-right: first argument must be a procedure")) + (when (not (string? s)) + (type-error "string-fold-right: second argument must be a string")) + + (let ((substr (%string-from-range s rest))) + (let loop ((i (- (string-length substr) 1)) + (result knil)) + (if (< i 0) + result + (loop (- i 1) + (kons (string-ref substr i) result)))))) + +(define (string-for-each-index proc str . start+end) + (when (not (procedure? proc)) + (error 'type-error "string-for-each-index: first argument must be a procedure")) + (when (not (string? str)) + (error 'type-error "string-for-each-index: expected a string")) + (let ((substr (%string-from-range str start+end))) + (let loop ((i 0) (len (string-length substr)) (acc '())) + (if (< i len) + (loop (+ i 1) len (proc i (string-ref substr i) acc)) + (reverse acc))))) + (define (string-tokenize str . char+start+end) (define (string-tokenize-sub str char) diff --git a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-132.scm b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-132.scm new file mode 100644 index 0000000000..3b7ece1f4c --- /dev/null +++ b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-132.scm @@ -0,0 +1,111 @@ +; +; 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 (srfi srfi-132) +(export list-sorted? vector-sorted? + list-merge list-sort list-stable-sort vector-merge vector-sort vector-stable-sort + list-merge! list-sort! list-stable-sort! vector-merge! vector-sort! vector-stable-sort!) +(import (liii list) + (liii error) + (scheme case-lambda)) +(begin + + (define (list-sorted? less-p lis) + (if (null? lis) + #t + (do ((first lis (cdr first)) + (second (cdr lis) (cdr second)) + (res #t (not (less-p (car second) (car first))))) + ((or (null? second) (not res)) res)))) + + ; TODO optional parameters + (define (vector-sorted? less-p v) + (let ((start 0) + (end (length v))) + (do ((first start (+ 1 first)) + (second (+ 1 start) (+ 1 second)) + (res #t (not (less-p (vector-ref v second) (vector-ref v first))))) + ((or (>= second end) (not res)) res)))) + + (define (list-merge less-p lis1 lis2) + (let loop + ((res '()) + (lis1 lis1) + (lis2 lis2)) + (cond + ((and (null? lis1) (null? lis2)) (reverse res)) + ((null? lis1) (loop (cons (car lis2) res) lis1 (cdr lis2))) + ((null? lis2) (loop (cons (car lis1) res) lis2 (cdr lis1))) + ((less-p (car lis2) (car lis1)) (loop (cons (car lis2) res) lis1 (cdr lis2))) + (else (loop (cons (car lis1) res) (cdr lis1) lis2))))) + + ; this list-merge! violates SRFI 132, since it does not satisfy the constant running space + ; constraint specified in SRFI 132, and does not work "in place" + (define list-merge! list-merge) + + (define (list-stable-sort less-p lis) + (define (sort l r) + (cond + ((= l r) '()) + ((= (+ l 1) r) (list (list-ref lis l))) + (else + (let* ((mid (quotient (+ l r) 2)) + (l-sorted (sort l mid)) + (r-sorted (sort mid r))) + (list-merge less-p l-sorted r-sorted))))) + (sort 0 (length lis))) + + (define list-sort list-stable-sort) + (define list-sort! list-stable-sort) + (define list-stable-sort! list-stable-sort) + + (define vector-stable-sort + (case-lambda + ((less-p v) + (list->vector (list-stable-sort less-p (vector->list v)))) + ((less-p v start) + (list->vector (list-stable-sort less-p (subvector->list v start (vector-length v))))) + ((less-p v start end) + (list->vector (list-stable-sort less-p (subvector->list v start end)))))) + + (define vector-sort vector-stable-sort) + + (define (vector-sort! . r) (???)) + (define (vector-stable-sort! . r) (???)) + + (define (subvector->list v start end) + (do ((r '() (cons (vector-ref v p) r)) + (p start (+ 1 p))) + ((>= p end) (reverse r)))) + + (define vector-merge + (case-lambda + ((less-p v1 v2) + (list->vector (list-merge less-p (vector->list v1) (vector->list v2)))) + ((less-p v1 v2 start1) + (list->vector (list-merge less-p (subvector->list v1 start1 (vector-length v1)) (vector->list v2)))) + ((less-p v1 v2 start1 end1) + (list->vector (list-merge less-p (subvector->list v1 start1 end1) (vector->list v2)))) + ((less-p v1 v2 start1 end1 start2) + (list->vector (list-merge less-p (subvector->list v1 start1 end1) (subvector->list v2 start2 (vector-length v2))))) + ((less-p v1 v2 start1 end1 start2 end2) + (list->vector (list-merge less-p (subvector->list v1 start1 end1) (subvector->list v2 start2 end2)))))) + + (define (vector-merge! . r) (???)) + +) ; end of begin +) ; end of library + diff --git a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-133.scm b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-133.scm index 79d5bd0110..8fcec8dc0d 100644 --- a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-133.scm +++ b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-133.scm @@ -18,9 +18,10 @@ (import (liii base)) (export vector-empty? + vector-fold vector-fold-right vector-count vector-any vector-every vector-copy vector-copy! - vector-index vector-index-right vector-partition + vector-index vector-index-right vector-skip vector-skip-right vector-partition vector-swap! vector-cumulate reverse-list->vector vector=) (begin @@ -49,6 +50,18 @@ (if (null? vrest) #t (loop vec2 (car vrest) (cdr vrest))) #f))))) +(define (vector-fold f initial vec) + (let loop ((i 0) (acc initial)) + (if (< i (vector-length vec)) + (loop (+ i 1) (f (vector-ref vec i) acc)) + acc))) + +(define (vector-fold-right f initial vec) + (let loop ((i (- (vector-length vec) 1)) (acc initial)) + (if (>= i 0) + (loop (- i 1) (f (vector-ref vec i) acc)) + acc))) + ; TODO optional parameters (define (vector-count pred v) (let loop ((i 0) (count 0)) @@ -88,20 +101,26 @@ ((not (pred (vector-ref v i))) #f) (else (loop (+ i 1)))))) -; TODO optional parameters -(define (vector-index pred v) - (let loop ((i 0)) +(define vector-index + (typed-lambda ((pred procedure?) (v vector?)) + (let loop ((i 0)) (cond ((= i (vector-length v)) #f) ((pred (vector-ref v i)) i) - (else (loop (+ i 1)))))) + (else (loop (+ i 1))))))) -; TODO optional parameters -(define (vector-index-right pred v) - (let ((len (vector-length v))) - (let loop ((i (- len 1))) - (cond ((< i 0) #f) +(define vector-index-right + (typed-lambda ((pred procedure?) (v vector?)) + (let ((len (vector-length v))) + (let loop ((i (- len 1))) + (cond ((< i 0) #f) ((pred (vector-ref v i)) i) - (else (loop (- i 1))))))) + (else (loop (- i 1)))))))) + +(define (vector-skip pred v) + (vector-index (lambda (x) (not (pred x))) v)) + +(define (vector-skip-right pred v) + (vector-index-right (lambda (x) (not (pred x))) v)) (define (vector-partition pred v) (let* ((len (vector-length v)) diff --git a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-151.scm b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-151.scm index c61ccad4f3..d38e0014aa 100644 --- a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-151.scm +++ b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-151.scm @@ -15,6 +15,7 @@ ; (define-library (srfi srfi-151) +(import (liii base)) (export bitwise-not bitwise-and bitwise-ior bitwise-xor bitwise-nor bitwise-nand bit-count bitwise-orc1 bitwise-orc2 bitwise-andc1 bitwise-andc2 diff --git a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-26.scm b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-26.scm new file mode 100644 index 0000000000..e59988c0c8 --- /dev/null +++ b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-26.scm @@ -0,0 +1,70 @@ +; +; 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 (srfi srfi-26) +(export cut cute) +(import (liii list) + (liii error)) +(begin + +(define-macro (cut . paras) + (letrec* + ((slot? (lambda (x) (equal? '<> x))) + (more-slot? (lambda (x) (equal? '<...> x))) + (slots (filter slot? paras)) + (more-slots (filter more-slot? paras)) + (xs (map (lambda (x) (gensym)) slots)) + (rest (gensym)) + (parse + (lambda (xs paras) + (cond + ((null? paras) paras) + ((not (list? paras)) paras) + ((more-slot? (car paras)) `(,rest ,@(parse xs (cdr paras)))) + ((slot? (car paras)) `(,(car xs) ,@(parse (cdr xs) (cdr paras)))) + (else `(,(car paras) ,@(parse xs (cdr paras)))))))) + (cond + ((null? more-slots) + `(lambda ,xs ,(parse xs paras))) + (else + (when + (or (> (length more-slots) 1) + (not (more-slot? (last paras)))) + (error 'syntax-error "<...> must be the last parameter of cut")) + (let ((parsed (parse xs paras))) + `(lambda (,@xs . ,rest) (apply ,@parsed))))))) + +(define-macro (cute . paras) + (letrec* + ((slot? (lambda (x) (equal? '<> x))) + (more-slot? (lambda (x) (equal? '<...> x))) + (exprs (filter (lambda (x) (not (or (slot? x) (more-slot? x)))) + paras)) + (xs (map (lambda (x) (gensym)) exprs)) + (lets (map list xs exprs)) + (parse + (lambda (xs paras) + (cond + ((null? paras) paras) + ((not (list? paras)) paras) + ((not (or (slot? (car paras)) (more-slot? (car paras)))) + `(,(car xs) ,@(parse (cdr xs) (cdr paras)))) + (else `(,(car paras) ,@(parse xs (cdr paras)))))))) + `(let ,lets (cut ,@(parse xs paras))))) + +) ; end of begin +) ; end of library + diff --git a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-78.scm b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-78.scm index 2228c32375..7f468ad8a3 100644 --- a/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-78.scm +++ b/TeXmacs/plugins/goldfish/goldfish/srfi/srfi-78.scm @@ -43,7 +43,7 @@ check:proc) (begin -(define check:write display) +(define check:write display*) (define check:mode #f) @@ -136,7 +136,7 @@ (else (error "unrecognized check:mode" check:mode)))) (define-macro (check expr => expected) - `(check:proc ',expr (lambda () ,expr) equal? ,expected)) + `(check:proc ',expr (lambda () ,expr) == ,expected)) (define (check-report) (if (>= check:mode 1) diff --git a/TeXmacs/plugins/goldfish/src/goldfish.cpp b/TeXmacs/plugins/goldfish/src/goldfish.cpp index 8772cb1f02..48412d4c0b 100644 --- a/TeXmacs/plugins/goldfish/src/goldfish.cpp +++ b/TeXmacs/plugins/goldfish/src/goldfish.cpp @@ -15,8 +15,15 @@ // #include "goldfish.hpp" +#include int main (int argc, char** argv) { - return goldfish::repl_for_community_edition (argc, argv); +#ifdef TB_CONFIG_OS_WINDOWS + SetConsoleOutputCP (65001); +#endif + std::string gf_lib_dir = goldfish::find_goldfish_library (); + const char* gf_lib = gf_lib_dir.c_str (); + s7_scheme* sc= goldfish::init_goldfish_scheme (gf_lib); + return goldfish::repl_for_community_edition (sc, argc, argv); } diff --git a/TeXmacs/plugins/goldfish/src/goldfish.hpp b/TeXmacs/plugins/goldfish/src/goldfish.hpp index 081b831156..4c3aecea45 100644 --- a/TeXmacs/plugins/goldfish/src/goldfish.hpp +++ b/TeXmacs/plugins/goldfish/src/goldfish.hpp @@ -16,6 +16,7 @@ #include #include +#include #include #include #include @@ -28,17 +29,21 @@ #ifdef TB_CONFIG_OS_WINDOWS #include #include +#elif TB_CONFIG_OS_MACOSX +#include +#include #else -#include -#include +#include #endif #if !defined(TB_CONFIG_OS_WINDOWS) #include +#include +#include #include #endif -#define GOLDFISH_VERSION "17.11.0" +#define GOLDFISH_VERSION "17.11.2" #define GOLDFISH_PATH_MAXN TB_PATH_MAXN @@ -61,6 +66,13 @@ string_vector_to_s7_vector (s7_scheme* sc, vector v) { return ret; } +inline void +glue_define (s7_scheme *sc, const char* name, const char* desc, s7_function f, s7_int required, s7_int optional) { + s7_pointer cur_env= s7_curlet (sc); + s7_pointer func= s7_make_typed_function (sc, name, f, required, optional, false, desc, NULL); + s7_define (sc, cur_env, s7_make_symbol (sc, name), func); +} + static s7_pointer f_version (s7_scheme* sc, s7_pointer args) { return s7_make_string (sc, GOLDFISH_VERSION); @@ -174,6 +186,63 @@ glue_scheme_process_context (s7_scheme* sc) { false, d_command_line, NULL)); } +string +goldfish_exe () { +#ifdef TB_CONFIG_OS_WINDOWS + char buffer[GOLDFISH_PATH_MAXN]; + GetModuleFileName (NULL, buffer, GOLDFISH_PATH_MAXN); + return string (buffer); +#elif TB_CONFIG_OS_MACOSX + char buffer[PATH_MAX]; + uint32_t size= sizeof (buffer); + if (_NSGetExecutablePath (buffer, &size) == 0) { + char real_path[GOLDFISH_PATH_MAXN]; + if (realpath (buffer, real_path) != NULL) { + return string (real_path); + } + } + return ""; +#elif TB_CONFIG_OS_LINUX + char buffer[GOLDFISH_PATH_MAXN]; + ssize_t len= readlink ("/proc/self/exe", buffer, sizeof (buffer) - 1); + if (len != -1) { + buffer[len]= '\0'; + return std::string (buffer); + } + return ""; +#endif +} + +static s7_pointer +f_executable (s7_scheme* sc, s7_pointer args) { + string exe_path= goldfish_exe (); + return s7_make_string (sc, exe_path.c_str ()); +} + +inline void +glue_executable (s7_scheme* sc) { + const char* name= "g_executable"; + const char* desc= "(g_executable) => string"; + glue_define (sc, name, desc, f_executable, 0, 0); +} + +inline void +glue_liii_sys (s7_scheme* sc) { + glue_executable (sc); +} + +static s7_pointer +f_os_arch (s7_scheme* sc, s7_pointer args) { + return s7_make_string (sc, TB_ARCH_STRING); +} + +inline void +glue_os_arch (s7_scheme* sc) { + const char* name= "g_os-arch"; + const char* desc= "(g_os-arch) => string"; + glue_define (sc, name, desc, f_os_arch, 0, 0); +} + static s7_pointer f_os_type (s7_scheme* sc, s7_pointer args) { #ifdef TB_CONFIG_OS_LINUX @@ -188,9 +257,11 @@ f_os_type (s7_scheme* sc, s7_pointer args) { return s7_make_boolean (sc, false); } -static s7_pointer -f_os_arch (s7_scheme* sc, s7_pointer args) { - return s7_make_string (sc, TB_ARCH_STRING); +inline void +glue_os_type (s7_scheme* sc) { + const char* name= "g_os-type"; + const char* desc= "(g_os-type) => string"; + glue_define (sc, name, desc, f_os_type, 0, 0); } static s7_pointer @@ -203,7 +274,7 @@ f_os_call (s7_scheme* sc, s7_pointer args) { #if _MSC_VER ret= (int) std::system (cmd_c); #else - wordexp_t p; + wordexp_t p; ret= wordexp (cmd_c, &p, 0); if (ret != 0) { // failed after calling wordexp @@ -221,6 +292,12 @@ f_os_call (s7_scheme* sc, s7_pointer args) { return s7_make_integer (sc, ret); } +inline void glue_os_call(s7_scheme* sc) { + const char* name = "g_os-call"; + const char* desc = "(g_os-call string) => int, execute a shell command and return the exit code"; + glue_define(sc, name, desc, f_os_call, 1, 0); +} + static s7_pointer f_system (s7_scheme* sc, s7_pointer args) { const char* cmd_c= s7_string (s7_car (args)); @@ -228,41 +305,52 @@ f_system (s7_scheme* sc, s7_pointer args) { return s7_make_integer (sc, ret); } -static s7_pointer -f_os_temp_dir (s7_scheme* sc, s7_pointer args) { - tb_char_t path[GOLDFISH_PATH_MAXN]; - tb_directory_temporary (path, GOLDFISH_PATH_MAXN); - return s7_make_string (sc, path); +inline void glue_system(s7_scheme* sc) { + const char* name = "g_system"; + const char* desc = "(g_system string) => int, execute a shell command and return the exit code"; + glue_define(sc, name, desc, f_system, 1, 0); } static s7_pointer -f_isdir (s7_scheme* sc, s7_pointer args) { - const char* dir_c= s7_string (s7_car (args)); - tb_file_info_t info; - bool ret= false; - if (tb_file_info (dir_c, &info)) { - switch (info.type) { - case TB_FILE_TYPE_DIRECTORY: - case TB_FILE_TYPE_DOT: - case TB_FILE_TYPE_DOT2: - ret= true; - } - } +f_access (s7_scheme* sc, s7_pointer args) { + const char* path_c= s7_string (s7_car (args)); + int mode = s7_integer ((s7_cadr (args))); + bool ret= false; + if (mode == 0) { + tb_file_info_t info; + ret= tb_file_info (path_c, &info); + } else { + ret= tb_file_access (path_c, mode); + } + return s7_make_boolean (sc, ret); } +inline void glue_access(s7_scheme* sc) { + const char* name = "g_access"; + const char* desc = "(g_access string integer) => boolean, check file access permissions"; + glue_define(sc, name, desc, f_access, 2, 0); +} + +inline void +glue_unsetenv (s7_scheme* sc) { + const char* name= "g_unsetenv"; + const char* desc= "(g_unsetenv string): string => boolean"; + glue_define (sc, name, desc, f_unset_environment_variable, 1, 0); +} + static s7_pointer -f_isfile (s7_scheme* sc, s7_pointer args) { - const char* dir_c= s7_string (s7_car (args)); - tb_file_info_t info; - bool ret= false; - if (tb_file_info (dir_c, &info)) { - switch (info.type) { - case TB_FILE_TYPE_FILE: - ret= true; - } - } - return s7_make_boolean (sc, ret); +f_os_temp_dir (s7_scheme* sc, s7_pointer args) { + tb_char_t path[GOLDFISH_PATH_MAXN]; + tb_directory_temporary (path, GOLDFISH_PATH_MAXN); + return s7_make_string (sc, path); +} + +inline void +glue_os_temp_dir (s7_scheme* sc) { + const char* name= "g_os-temp-dir"; + const char* desc= "(g_os-temp-dir) => string, get the temporary directory path"; + glue_define (sc, name, desc, f_os_temp_dir, 0, 0); } static s7_pointer @@ -271,17 +359,22 @@ f_mkdir (s7_scheme* sc, s7_pointer args) { return s7_make_boolean (sc, tb_directory_create (dir_c)); } +inline void glue_mkdir(s7_scheme* sc) { + const char* name = "g_mkdir"; + const char* desc = "(g_mkdir string) => boolean, create a directory"; + glue_define(sc, name, desc, f_mkdir, 1, 0); +} + static s7_pointer f_chdir (s7_scheme* sc, s7_pointer args) { const char* dir_c= s7_string (s7_car (args)); return s7_make_boolean (sc, tb_directory_current_set (dir_c)); } -static s7_pointer -f_getcwd (s7_scheme* sc, s7_pointer args) { - tb_char_t path[GOLDFISH_PATH_MAXN]; - tb_directory_current (path, GOLDFISH_PATH_MAXN); - return s7_make_string (sc, path); +inline void glue_chdir(s7_scheme* sc) { + const char* name = "g_chdir"; + const char* desc = "(g_chdir string) => boolean, change the current working directory"; + glue_define(sc, name, desc, f_chdir, 1, 0); } static tb_long_t @@ -322,16 +415,25 @@ f_listdir (s7_scheme* sc, s7_pointer args) { return string_vector_to_s7_vector (sc, entries); } +inline void +glue_listdir (s7_scheme* sc) { + const char* name= "g_listdir"; + const char* desc= "(g_listdir string) => vector, list the contents of a directory"; + glue_define (sc, name, desc, f_listdir, 1, 0); +} + static s7_pointer -f_access (s7_scheme* sc, s7_pointer args) { - const char* path_c= s7_string (s7_car (args)); - int mode = s7_integer ((s7_cadr (args))); -#ifdef TB_CONFIG_OS_WINDOWS - bool ret= (_access (path_c, mode) == 0); -#else - bool ret= (access (path_c, mode) == 0); -#endif - return s7_make_boolean (sc, ret); +f_getcwd (s7_scheme* sc, s7_pointer args) { + tb_char_t path[GOLDFISH_PATH_MAXN]; + tb_directory_current (path, GOLDFISH_PATH_MAXN); + return s7_make_string (sc, path); +} + +inline void +glue_getcwd (s7_scheme* sc) { + const char* name= "g_getcwd"; + const char* desc= "(g_getcwd) => string, get the current working directory"; + glue_define (sc, name, desc, f_getcwd, 0, 0); } static s7_pointer @@ -345,6 +447,13 @@ f_getlogin (s7_scheme* sc, s7_pointer args) { #endif } +inline void +glue_getlogin (s7_scheme* sc) { + const char* name= "g_getlogin"; + const char* desc= "(g_getlogin) => string, get the current user's login name"; + glue_define (sc, name, desc, f_getlogin, 0, 0); +} + static s7_pointer f_getpid (s7_scheme* sc, s7_pointer args) { #ifdef TB_CONFIG_OS_WINDOWS @@ -354,6 +463,93 @@ f_getpid (s7_scheme* sc, s7_pointer args) { #endif } +inline void +glue_getpid (s7_scheme* sc) { + const char* name= "g_getpid"; + const char* desc= "(g_getpid) => integer"; + glue_define (sc, name, desc, f_getpid, 0, 0); +} + +inline void +glue_liii_os (s7_scheme* sc) { + glue_os_arch (sc); + glue_os_type (sc); + glue_os_call (sc); + glue_system (sc); + glue_access (sc); + glue_unsetenv (sc); + glue_getcwd (sc); + glue_os_temp_dir (sc); + glue_mkdir (sc); + glue_chdir (sc); + glue_listdir (sc); + glue_getlogin (sc); + glue_getpid (sc); +} + +static s7_pointer +f_uuid4 (s7_scheme* sc, s7_pointer args) { + tb_char_t uuid[37]; + const tb_char_t* ret= tb_uuid4_make_cstr (uuid, tb_null); + return s7_make_string (sc, ret); +} + +inline void +glue_uuid4 (s7_scheme* sc) { + const char* name= "g_uuid4"; + const char* desc= "(g_uuid4) => string"; + glue_define (sc, name, desc, f_uuid4, 0, 0); +} + +inline void +glue_liii_uuid (s7_scheme* sc) { + glue_uuid4 (sc); +} + +static s7_pointer +f_isdir (s7_scheme* sc, s7_pointer args) { + const char* dir_c= s7_string (s7_car (args)); + tb_file_info_t info; + bool ret= false; + if (tb_file_info (dir_c, &info)) { + switch (info.type) { + case TB_FILE_TYPE_DIRECTORY: + case TB_FILE_TYPE_DOT: + case TB_FILE_TYPE_DOT2: + ret= true; + } + } + return s7_make_boolean (sc, ret); +} + +inline void +glue_isdir (s7_scheme* sc) { + const char* name= "g_isdir"; + const char* desc= "(g_isdir string) => boolean"; + glue_define (sc, name, desc, f_isdir, 1, 0); +} + +static s7_pointer +f_isfile (s7_scheme* sc, s7_pointer args) { + const char* dir_c= s7_string (s7_car (args)); + tb_file_info_t info; + bool ret= false; + if (tb_file_info (dir_c, &info)) { + switch (info.type) { + case TB_FILE_TYPE_FILE: + ret= true; + } + } + return s7_make_boolean (sc, ret); +} + +inline void +glue_isfile (s7_scheme* sc) { + const char* name= "g_isfile"; + const char* desc= "(g_isfile string) => boolean"; + glue_define (sc, name, desc, f_isfile, 1, 0); +} + static s7_pointer f_path_getsize (s7_scheme* sc, s7_pointer args) { const char* path_c= s7_string (s7_car (args)); @@ -367,111 +563,102 @@ f_path_getsize (s7_scheme* sc, s7_pointer args) { } inline void -glue_liii_os (s7_scheme* sc) { - s7_pointer cur_env= s7_curlet (sc); +glue_path_getsize (s7_scheme* sc) { + const char* name= "g_path-getsize"; + const char* desc= "(g_path_getsize string): string => integer"; + glue_define (sc, name, desc, f_path_getsize, 1, 0); +} + +static s7_pointer f_path_read_text(s7_scheme* sc, s7_pointer args) { + const char* path = s7_string (s7_car (args)); + if (!path) { + return s7_make_boolean(sc, false); + } + + tb_file_ref_t file = tb_file_init(path, TB_FILE_MODE_RO); + if (file == tb_null) { + // TODO: warning on the tb_file_init failure + return s7_make_boolean(sc, false); + } + + tb_file_sync (file); + + tb_size_t size = tb_file_size(file); + if (size == 0) { + tb_file_exit (file); + return s7_make_string (sc, ""); + } + + tb_byte_t* buffer = new tb_byte_t[size + 1]; + tb_size_t real_size = tb_file_read (file, buffer, size); + buffer[real_size] = '\0'; + + tb_file_exit(file); + std::string content (reinterpret_cast(buffer), real_size); + delete[] buffer; - const char* s_os_type= "g_os-type"; - const char* d_os_type= "(g_os-type) => string"; - s7_define (sc, cur_env, s7_make_symbol (sc, s_os_type), - s7_make_typed_function (sc, s_os_type, f_os_type, 0, 0, false, - d_os_type, NULL)); - - const char* s_os_arch = "g_os-arch"; - const char* d_os_arch = "(g_os-arch) => string"; - const char* s_os_call = "g_os-call"; - const char* d_os_call = "(string) => int"; - const char* s_system = "g_system"; - const char* d_system = "(string) => int"; - const char* s_os_temp_dir= "g_os-temp-dir"; - const char* d_os_temp_dir= "(g_os-temp-dir) => string"; - const char* s_isdir = "g_isdir"; - const char* d_isdir = "(g_isdir string) => boolean"; - const char* s_isfile = "g_isfile"; - const char* d_isfile = "(g_isfile string) => boolean"; - const char* s_mkdir = "g_mkdir"; - const char* d_mkdir = "(g_mkdir string) => boolean"; - const char* s_chdir = "g_chdir"; - const char* d_chdir = "(g_chdir string) => boolean"; - const char* s_listdir = "g_listdir"; - const char* d_listdir = "(g_listdir) => vector"; - const char* s_getcwd = "g_getcwd"; - const char* d_getcwd = "(g_getcwd) => string"; - const char* s_access = "g_access"; - const char* d_access = "(g_access string integer) => boolean"; - const char* s_getlogin = "g_getlogin"; - const char* d_getlogin = "(g_getlogin) => string"; - const char* s_getpid = "g_getpid"; - const char* d_getpid = "(g_getpid) => integer"; - - s7_define (sc, cur_env, s7_make_symbol (sc, s_os_arch), - s7_make_typed_function (sc, s_os_arch, f_os_arch, 0, 0, false, - d_os_arch, NULL)); - s7_define (sc, cur_env, s7_make_symbol (sc, s_os_call), - s7_make_typed_function (sc, s_os_call, f_os_call, 1, 0, false, - d_os_call, NULL)); - s7_define (sc, cur_env, s7_make_symbol (sc, s_system), - s7_make_typed_function (sc, s_system, f_system, 1, 0, false, - d_system, NULL)); - s7_define (sc, cur_env, s7_make_symbol (sc, s_os_temp_dir), - s7_make_typed_function (sc, s_os_temp_dir, f_os_temp_dir, 0, 0, - false, d_os_call, NULL)); - s7_define (sc, cur_env, s7_make_symbol (sc, s_isdir), - s7_make_typed_function (sc, s_isdir, f_isdir, 1, 0, false, d_isdir, - NULL)); - s7_define (sc, cur_env, s7_make_symbol (sc, s_isfile), - s7_make_typed_function (sc, s_isfile, f_isfile, 1, 0, false, - d_isfile, NULL)); - s7_define (sc, cur_env, s7_make_symbol (sc, s_mkdir), - s7_make_typed_function (sc, s_mkdir, f_mkdir, 1, 0, false, d_mkdir, - NULL)); - s7_define (sc, cur_env, s7_make_symbol (sc, s_chdir), - s7_make_typed_function (sc, s_chdir, f_chdir, 1, 0, false, d_chdir, - NULL)); - s7_define (sc, cur_env, s7_make_symbol (sc, s_listdir), - s7_make_typed_function (sc, s_listdir, f_listdir, 1, 0, false, - d_listdir, NULL)); - s7_define (sc, cur_env, s7_make_symbol (sc, s_getcwd), - s7_make_typed_function (sc, s_getcwd, f_getcwd, 0, 0, false, - d_getcwd, NULL)); - s7_define (sc, cur_env, s7_make_symbol (sc, s_access), - s7_make_typed_function (sc, s_access, f_access, 2, 0, false, - d_access, NULL)); - s7_define (sc, cur_env, s7_make_symbol (sc, s_getlogin), - s7_make_typed_function (sc, s_getlogin, f_getlogin, 0, 0, false, - d_access, NULL)); - s7_define (sc, cur_env, s7_make_symbol (sc, s_getpid), - s7_make_typed_function (sc, s_getpid, f_getpid, 0, 0, false, - d_getpid, NULL)); - - const char* s_unsetenv= "g_unsetenv"; - const char* d_unsetenv= "(g_unsetenv string): string => boolean"; - s7_define (sc, cur_env, s7_make_symbol (sc, s_unsetenv), - s7_make_typed_function (sc, s_unsetenv, - f_unset_environment_variable, 1, 0, false, - d_unsetenv, NULL)); - - const char* s_path_getsize= "g_path-getsize"; - const char* d_path_getsize= "(g_path_getsize string): string => integer"; - s7_define (sc, cur_env, s7_make_symbol (sc, s_path_getsize), - s7_make_typed_function (sc, s_unsetenv, f_path_getsize, 1, 0, - false, d_path_getsize, NULL)); + return s7_make_string(sc, content.c_str()); +} + +inline void +glue_path_read_text(s7_scheme* sc) { + const char* name = "g_path-read-text"; + const char* desc = "(g_path-read-text path) => string, read the content of the file at the given path"; + s7_define_function(sc, name, f_path_read_text, 1, 0, false, desc); } static s7_pointer -f_uuid4 (s7_scheme* sc, s7_pointer args) { - tb_char_t uuid[37]; - const tb_char_t* ret= tb_uuid4_make_cstr (uuid, tb_null); - return s7_make_string (sc, ret); +f_path_write_text (s7_scheme* sc, s7_pointer args) { + const char* path = s7_string (s7_car (args)); + if (!path) { + return s7_make_integer(sc, -1); + } + + const char* content= s7_string (s7_cadr (args)); + if (!content) { + return s7_make_integer(sc, -1); + } + + tb_file_ref_t file = tb_file_init(path, TB_FILE_MODE_WO | TB_FILE_MODE_CREAT | TB_FILE_MODE_TRUNC); + if (file == tb_null) { + return s7_make_integer(sc, -1); + } + + tb_filelock_ref_t lock = tb_filelock_init(file); + if (tb_filelock_enter(lock, TB_FILELOCK_MODE_EX) == tb_false) { + tb_filelock_exit(lock); + tb_file_exit(file); + return s7_make_integer(sc, -1); + } + + tb_size_t content_size= strlen(content); + tb_size_t written_size= tb_file_writ(file, reinterpret_cast(content), content_size); + + bool release_success= tb_filelock_leave (lock); + tb_filelock_exit (lock); + bool exit_success= tb_file_exit(file); + + if (written_size == content_size && release_success && exit_success) { + return s7_make_integer(sc, written_size); + } else { + return s7_make_integer(sc, -1); + } +} + +inline void glue_path_write_text(s7_scheme* sc) { + const char* name = "g_path-write-text"; + const char* desc = "(g_path-write-text path content) => integer,\ +write content to the file at the given path and return the number of bytes written, or -1 on failure"; + s7_define_function(sc, name, f_path_write_text, 2, 0, false, desc); } inline void -glue_liii_uuid (s7_scheme* sc) { - s7_pointer cur_env= s7_curlet (sc); - const char* s_uuid4= "g_uuid4"; - const char* d_uuid4= "(g_uuid4) => string"; - s7_define (sc, cur_env, s7_make_symbol (sc, s_uuid4), - s7_make_typed_function (sc, s_uuid4, f_uuid4, 0, 0, false, d_uuid4, - NULL)); +glue_liii_path (s7_scheme* sc) { + glue_isfile (sc); + glue_isdir (sc); + glue_path_getsize (sc); + glue_path_read_text (sc); + glue_path_write_text (sc); } void @@ -479,7 +666,9 @@ glue_for_community_edition (s7_scheme* sc) { glue_goldfish (sc); glue_scheme_time (sc); glue_scheme_process_context (sc); + glue_liii_sys (sc); glue_liii_os (sc); + glue_liii_path (sc); glue_liii_uuid (sc); } @@ -548,6 +737,9 @@ customize_goldfish_by_mode (s7_scheme* sc, string mode, } if (mode == "default" || mode == "liii") { + s7_eval_c_string (sc, "(import (liii base) (liii error) (liii lang))"); + } + else if (mode == "scheme") { s7_eval_c_string (sc, "(import (liii base) (liii error))"); } else if (mode == "sicp") { @@ -564,38 +756,60 @@ customize_goldfish_by_mode (s7_scheme* sc, string mode, } } -int -repl_for_community_edition (int argc, char** argv) { - // Check if the standard library and boot.scm exists - tb_char_t data_goldfish[TB_PATH_MAXN]= {0}; - tb_char_t const* goldfish= - tb_path_absolute (argv[0], data_goldfish, sizeof (data_goldfish)); +string +find_goldfish_library () { + string exe_path= goldfish_exe (); tb_char_t data_bin[TB_PATH_MAXN]= {0}; tb_char_t const* ret_bin= - tb_path_directory (goldfish, data_bin, sizeof (data_bin)); + tb_path_directory (exe_path.c_str (), data_bin, sizeof (data_bin)); tb_char_t data_root[TB_PATH_MAXN]= {0}; tb_char_t const* gf_root= tb_path_directory (ret_bin, data_root, sizeof (data_root)); tb_char_t data_lib[TB_PATH_MAXN]= {0}; - tb_char_t const* gf_lib= - tb_path_absolute_to (gf_root, "goldfish", data_lib, sizeof (data_lib)); + tb_char_t const* gf_lib= tb_path_absolute_to (gf_root, "share/goldfish", + data_lib, sizeof (data_lib)); +#ifdef TB_CONFIG_OS_LINUX + if (strcmp (gf_root, "/") == 0) { + gf_lib= "/usr/share/goldfish"; + } +#endif + if (!tb_file_access (gf_lib, TB_FILE_MODE_RO)) { + gf_lib= + tb_path_absolute_to (gf_root, "goldfish", data_lib, sizeof (data_lib)); + if (!tb_file_access (gf_lib, TB_FILE_MODE_RO)) { + cerr << "The load path for Goldfish standard library does not exist" + << endl; + exit (-1); + } + } + + return string (gf_lib); +} + +string +find_goldfish_boot (const char* gf_lib) { tb_char_t data_boot[TB_PATH_MAXN]= {0}; tb_char_t const* gf_boot= tb_path_absolute_to (gf_lib, "scheme/boot.scm", data_boot, sizeof (data_boot)); - if (!tb_file_access (gf_lib, TB_FILE_MODE_RO)) { - cerr << "The load path for Goldfish Scheme Standard Library does not exist" - << endl; - exit (-1); - } if (!tb_file_access (gf_boot, TB_FILE_MODE_RO)) { cerr << "The boot.scm for Goldfish Scheme does not exist" << endl; exit (-1); } + return string (gf_boot); +} + +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 (); + vector all_args (argv, argv + argc); int all_args_N= all_args.size (); for (int i= 0; i < all_args_N; i++) { @@ -609,9 +823,6 @@ repl_for_community_edition (int argc, char** argv) { exit (0); } - // Init the underlying S7 Scheme and add the load_path - s7_scheme* sc= init_goldfish_scheme (gf_lib); - const char* errmsg= NULL; s7_pointer old_port= s7_set_current_error_port (sc, s7_open_output_string (sc)); diff --git a/xmake/packages/s/s7/port/xmake.lua b/xmake/packages/s/s7/port/xmake.lua index ebc85db4c0..3bc88dd02b 100644 --- a/xmake/packages/s/s7/port/xmake.lua +++ b/xmake/packages/s/s7/port/xmake.lua @@ -29,6 +29,8 @@ end target("libs7") do set_kind("$(kind)") add_defines("WITH_SYSTEM_EXTRAS=0") + add_defines("HAVE_OVERFLOW_CHECKS=0") + add_defines("WITH_WARNINGS") set_basename("s7") add_files("s7.c") add_headerfiles("s7.h") diff --git a/xmake/packages/s/s7/xmake.lua b/xmake/packages/s/s7/xmake.lua index 41e40746ab..3dd3bdc0a2 100644 --- a/xmake/packages/s/s7/xmake.lua +++ b/xmake/packages/s/s7/xmake.lua @@ -26,7 +26,7 @@ package("s7") add_urls("https://gitee.com/XmacsLabs/s7.git") add_urls("https://github.com/XmacsLabs/s7.git") - add_versions("20241122", "20241122") + add_versions("20241230", "20241230") add_configs("gmp", {description = "enable gmp support", default = false, type = "boolean"}) diff --git a/xmake/vars.lua b/xmake/vars.lua index 9f02736643..3d92a53064 100644 --- a/xmake/vars.lua +++ b/xmake/vars.lua @@ -24,7 +24,7 @@ LOLLY_VERSION = "1.4.28" -- Third-party dependencies CPPTRACE_VERSION = "v0.7.1" -S7_VERSION = "20241122" +S7_VERSION = "20241230" TREESITTER_VERSION = "0.22.6" TREESITTER_CPP_VERSION = "0.22.2" TREESITTER_SCHEME_VERSION = "0.6.2"