[61_7] Goldfish: upgrade to 17.10.6 rc2

TeXmacs/plugins/goldfish/goldfish/liii/base.scm

@@ -21,6 +21,10 @@
   let-values
   define-record-type
   square
+  exact inexact
+  floor s7-floor ceiling s7-ceiling truncate s7-truncate round s7-round
+  floor-quotient
+  gcd lcm s7-lcm
   boolean=?
   ; String
   string-copy

TeXmacs/plugins/goldfish/goldfish/liii/error.scm

@@ -19,7 +19,7 @@
 (export ???
   os-error file-not-found-error not-a-directory-error file-exists-error
   timeout-error
-  type-error value-error)
+  type-error type-error? value-error)
 (begin
 
 (define (os-error . args)
@@ -40,6 +40,9 @@
 (define (type-error . args)
   (apply error (cons 'type-error args)))
 
+(define (type-error? err)
+  (in? err `(type-error wrong-type-arg)))
+
 (define (value-error . args)
   (apply error (cons 'value-error args)))
 

TeXmacs/plugins/goldfish/goldfish/liii/hash-table.scm

@@ -25,7 +25,9 @@
   hash-table-set! hash-table-delete! hash-table-intern! hash-table-update!
   hash-table-update!/default hash-table-pop! hash-table-clear!
   hash-table-size hash-table-keys hash-table-values hash-table-entries
-  hash-table-find hash-table-count hash-table->alist
+  hash-table-find hash-table-count
+  hash-table-for-each
+  hash-table->alist
 )
 (begin
 ) ; end of begin

TeXmacs/plugins/goldfish/goldfish/liii/list.scm

@@ -28,7 +28,7 @@
   last-pair last
   ; SRFI 1: fold, unfold & map
   count fold fold-right reduce reduce-right
-  filter partition remove
+  filter partition remove append-map
   ; SRFI 1: Searching
   find any every list-index
   take-while drop-while
@@ -71,8 +71,7 @@
                        "list-view only accepts even number of args"))))
   f-inner)
 
-(define (flatmap f seq)
-  (fold-right append () (map f seq)))
+(define flatmap append-map)
 
 (define (not-null-list? l)
   (cond ((pair? l)

TeXmacs/plugins/goldfish/goldfish/scheme/base.scm

@@ -19,6 +19,10 @@
   let-values
   define-record-type
   square
+  exact inexact
+  floor s7-floor ceiling s7-ceiling truncate s7-truncate round s7-round
+  floor-quotient
+  gcd lcm s7-lcm
   boolean=?
   ; String
   string-copy
@@ -103,6 +107,60 @@
           fields)
        ',type)))
 
+(define exact inexact->exact)
+
+(define inexact exact->inexact)
+
+(define s7-floor floor)
+
+(define (floor x)
+  (if (inexact? x)
+      (inexact (s7-floor x))
+      (s7-floor x)))
+
+(define s7-ceiling ceiling)
+
+(define (ceiling x)
+  (if (inexact? x)
+      (inexact (s7-ceiling x))
+      (s7-ceiling x)))
+
+(define s7-truncate truncate)
+
+(define (truncate x)
+  (if (inexact? x)
+      (inexact (s7-truncate x))
+      (s7-truncate x)))
+
+(define s7-round round)
+
+(define (round x)
+  (if (inexact? x)
+      (inexact (s7-round x))
+      (s7-round x)))
+
+(define (floor-quotient x y) (floor (/ x y)))
+
+(define s7-lcm lcm)
+
+(define (lcm2 x y)
+  (cond ((and (inexact? x) (exact? y))
+         (inexact (s7-lcm (exact x) y)))
+        ((and (exact? x) (inexact? y))
+         (inexact (s7-lcm x (exact y))))
+        ((and (inexact? x) (inexact? y))
+         (inexact (s7-lcm (exact x) (exact y))))
+        (else (s7-lcm x y))))
+
+(define (lcm . args)
+  (cond ((null? args) 1)
+        ((null? (cdr args))
+         (car args))
+        ((null? (cddr args))
+         (lcm2 (car args) (cadr args)))
+        (else (apply lcm (cons (lcm (car args) (cadr args))
+                               (cddr args))))))
+
 (define (square x) (* x x))
 
 (define (boolean=? obj1 obj2 . rest)

TeXmacs/plugins/goldfish/goldfish/scheme/boot.scm

@@ -102,3 +102,4 @@
                           (format () "~A not loaded~%" sym)
                           (symbol->value sym))))))
               libs))))
+

TeXmacs/plugins/goldfish/goldfish/srfi/srfi-1.scm

@@ -12,13 +12,14 @@
 ;;; Follow the same License as the original one
 
 (define-library (srfi srfi-1)
-(import (liii error))
+(import (liii error)
+        (liii base))
 (export
   circular-list iota circular-list? null-list?
   first second third fourth fifth
   sixth seventh eighth ninth tenth
   take drop take-right drop-right count fold fold-right
-  reduce reduce-right filter partition remove find
+  reduce reduce-right append-map filter partition remove find
   delete delete-duplicates
   take-while drop-while list-index any every
   last-pair last)
@@ -138,6 +139,15 @@
             (f head (recur (car l) (cdr l)))
             head))))
 
+(define append-map
+  (typed-lambda ((proc procedure?) (lst list?))
+    (let loop ((rest lst)
+               (result '()))
+      (if (null? rest)
+          result
+          (loop (cdr rest)
+                (append result (proc (car rest))))))))
+
 (define (filter pred l)
   (let recur ((l l))
     (if (null-list? l) l

TeXmacs/plugins/goldfish/goldfish/srfi/srfi-125.scm

@@ -15,7 +15,9 @@
 ;
 
 (define-library (srfi srfi-125)
-(import (srfi srfi-1))
+(import (srfi srfi-1)
+        (liii base)
+        (liii error))
 (export
   make-hash-table hash-table hash-table-unfold alist->hash-table
   hash-table? hash-table-contains? hash-table-empty? hash-table=?
@@ -24,7 +26,9 @@
   hash-table-set! hash-table-delete! hash-table-intern! hash-table-update!
   hash-table-update!/default hash-table-pop! hash-table-clear!
   hash-table-size hash-table-keys hash-table-values hash-table-entries
-  hash-table-find hash-table-count hash-table->alist
+  hash-table-find hash-table-count
+  hash-table-for-each
+  hash-table->alist
 )
 (begin
 
@@ -34,6 +38,7 @@
 
 (define s7-hash-table-set! hash-table-set!)
 (define s7-make-hash-table make-hash-table)
+(define s7-hash-table-entries hash-table-entries)
 
 (define (make-hash-table . args)
   (cond ((null? args) (s7-make-hash-table))
@@ -43,6 +48,18 @@
            (s7-make-hash-table 8 (cons equiv hash-func) (cons #t #t))))
         (else (type-error "make-hash-table"))))
 
+(define alist->hash-table
+  (typed-lambda ((lst list?))
+    (when (odd? (length lst))
+      (value-error "The length of lst must be even!"))
+    (let1 ht (make-hash-table)
+      (let loop ((rest lst))
+        (if (null? rest)
+            ht
+            (begin
+              (hash-table-set! ht (car rest) (cadr rest))
+              (loop (cddr rest))))))))
+
 (define (hash-table-contains? ht key)
   (not (not (hash-table-ref ht key))))
 
@@ -88,16 +105,36 @@
       (hash-table-set! ht key #f))
     (hash-table-keys ht)))
 
-(define hash-table-size hash-table-entries)
+(define hash-table-size s7-hash-table-entries)
 
 (define (hash-table-keys ht)
-  (map car (map values ht)))
+  (map car ht))
 
 (define (hash-table-values ht)
-  (map cdr (map values ht)))
-
-(define (hash-table->alist table)
-  (map values table))
+  (map cdr ht))
+
+(define hash-table-entries
+  (typed-lambda ((ht hash-table?))
+    (let ((ks (hash-table-keys ht))
+          (vs (hash-table-values ht)))
+      (values ks vs))))
+
+
+(define hash-table-count
+  (typed-lambda ((pred? procedure?) (ht hash-table?))
+    (count (lambda (x) (pred? (car x) (cdr x)))
+           (map values ht))))
+
+(define hash-table-for-each
+  (typed-lambda ((proc procedure?) (ht hash-table?))
+    (for-each (lambda (x) (proc (car x) (cdr x)))
+              ht)))
+
+(define hash-table->alist
+  (typed-lambda ((ht hash-table?))
+    (append-map
+      (lambda (x) (list (car x) (cdr x)))
+      (map values ht))))
 
 ) ; end of begin
 ) ; end of define-library

TeXmacs/plugins/goldfish/src/goldfish.hpp

@@ -14,6 +14,7 @@
 // under the License.
 //
 
+#include <algorithm>
 #include <cstdlib>
 #include <iostream>
 #include <s7.h>
@@ -37,7 +38,7 @@
 #include <wordexp.h>
 #endif
 
-#define GOLDFISH_VERSION "17.10.5"
+#define GOLDFISH_VERSION "17.10.6"
 #define GOLDFISH_PATH_MAXN TB_PATH_MAXN
 
 static std::vector<std::string> command_args= std::vector<std::string> ();
@@ -457,9 +458,12 @@ static void
 display_help () {
   cout << "Goldfish Scheme " << GOLDFISH_VERSION << " by LiiiLabs" << endl;
   cout << "--version\t"
-       << "display version" << endl;
+       << "Display version" << endl;
+  cout << "-m default\t"
+       << "Allowed mode: default, liii, sicp, r7rs, s7" << endl;
   cout << "-e       \t"
-       << "-e '(+ 1 2)'" << endl;
+       << "Load the scheme code on the command line" << endl
+       << "\t\teg. -e '(begin (display `Hello) (+ 1 2))'" << endl;
   cout << "-l FILE  \t"
        << "Load the scheme code on path" << endl;
   cout << "FILE     \t"
@@ -534,11 +538,18 @@ repl_for_community_edition (int argc, char** argv) {
     command_args.push_back (all_args[i]);
   }
 
+  // zero args
+  vector<string> args (argv + 1, argv + argc);
+  if (args.size () == 0) {
+    display_help ();
+    exit (0);
+  }
+
   // Init the underlying S7 Scheme and add the load_path
   s7_scheme* sc;
   sc= s7_init ();
-  s7_load (sc, gf_boot);
   s7_add_to_load_path (sc, gf_lib);
+
   const char* errmsg= NULL;
   s7_pointer  old_port=
       s7_set_current_error_port (sc, s7_open_output_string (sc));
@@ -551,12 +562,47 @@ repl_for_community_edition (int argc, char** argv) {
   // Glues
   glue_for_community_edition (sc);
 
-  // Command options
-  vector<string> args (argv + 1, argv + argc);
-  if (args.size () == 0) {
-    display_help ();
+  // -m: Load the standard library by mode
+  string mode_flag= "-m";
+  string mode     = "default";
+  int    args_N   = args.size ();
+  int    i;
+  for (i= 0; i < args_N; i++) {
+    if (args[i] == mode_flag) {
+      break;
+    }
+  }
+  if (i < args_N && i + 1 >= args_N) {
+    cerr << "No mode specified after -m" << endl;
+    exit (-1);
+  }
+  if (i < args_N) {
+    mode= args[i + 1];
+    args.erase (args.begin () + i);
+    args.erase (args.begin () + i);
+  }
+
+  // only when it is not s7 mode, we load `boot.scm`
+  if (mode != "s7") {
+    s7_load (sc, gf_boot);
+  }
+  // import the preload standard libraries
+  if (mode == "default" || mode == "liii") {
+    s7_eval_c_string (sc, "(import (liii base) (liii error))");
+  }
+  else if (mode == "sicp") {
+    s7_eval_c_string (sc, "(import (srfi sicp))");
   }
-  else if (args.size () == 1 && args[0].size () > 0 && args[0][0] == '-') {
+  else if (mode == "r7rs") {
+    s7_eval_c_string (sc, "(import (scheme base))");
+  }
+  else {
+    cerr << "No such mode: " << mode << endl;
+    exit (-1);
+  }
+
+  // Command options
+  if (args.size () == 1 && args[0].size () > 0 && args[0][0] == '-') {
     if (args[0] == "--version") {
       display_version ();
     }

TeXmacs/plugins/literate/progs/utils/literate/lp-build.scm

@@ -188,11 +188,11 @@
                (l-code-nl (map (cut string-append <> "\n") l-code))
                (s-code (apply string-append l-code-nl)))
           (hash-table-set! r key s-code)))
-      (hash-table->alist ht))
+      (map values ht))
     r))
 
 (define (write-table ht dir)
-  ((list-view (hash-table->alist ht))
+  ((list-view (map values ht))
     for-each
     (lambda (pair)
       (let* ((key (car pair))