Merge branch 'fricas:master' into master

ChangeLog

@@ -1,3 +1,19 @@
+2025-02-04  Waldek Hebisch  <[email protected]>
+
+	* src/interp/i-map.boot: Fix multiple assignment in
+	interpreter functions
+
+2025-02-03  Camm Maguire <[email protected]>
+
+	* src/include/com.h, src/lib/cfuns-c.c, src/lib/sockio-c.c,
+	src/lisp/fricas-lisp.lisp, src/lisp/fricas-package.lisp,
+	src/lisp/primitives.lisp, src/lisp/Makefile.in,
+	src/interp/foam_l.lisp, src/interp/i-funsel.boot,
+	src/interp/i-toplev.boot, src/interp/lisplib.boot,
+	src/interp/macros.lisp, src/interp/nlib.lisp,
+	src/interp/util.lisp, src/interp/vmlisp.lisp: Update
+	GCL support
+
 2025-01-28  Waldek Hebisch  <[email protected]>
 
 	* src/algebra/intpar.spad: Add check for no solution

src/include/com.h

@@ -114,11 +114,16 @@ typedef struct {
 
 /* table of dedicated socket types */
 
+#ifndef GCL_SOURCE
+#define STATIC
 extern Sock *purpose_table[];
 extern Sock server[];
 extern Sock clients[];
 extern fd_set socket_mask;
 extern fd_set server_mask;
+#else
+#define STATIC static
+#endif
 
 /* Commands sent over the FRICAS session manager or menu socket */
 
@@ -160,7 +165,11 @@ fricas_write(Sock* s, const char* buf, size_t n)
 static inline int
 fricas_read(Sock* s, char* buf, size_t n)
 {
-   return recv(s->socket, buf, n, 0);
+#ifdef GCL_SOURCE
+  return read(s->socket, buf, n);
+#else
+  return recv(s->socket, buf, n, 0);
+#endif
 }
 
 #endif

src/interp/Makefile.in

@@ -140,8 +140,10 @@ makeint.lisp: ../boot/lobj_lst
 	@ echo '#+:GCL (si::gbc-time 0)' >> makeint.lisp
 
 ${SAVESYS}:
-	echo '(load "makeint.lisp") #-:ecl(BOOT::reclaim)' \
+	echo '#+gcl(setq si::*optimize-maximum-pages* nil)' \
+	     '(load "makeint.lisp") #-:ecl(BOOT::reclaim)' \
              '#+:ecl(FRICAS-LISP::make-program "$(BASE)$@" nil)' \
+             '#+:gcl(progn (setq si::*code-block-reserve* "")(si::gbc t)(setq si::*code-block-reserve* (make-array 10000000 :element-type (quote character) :static t) si::*optimize-maximum-pages* t))' \
              '#-:ecl(BOOT::spad-save "$(BASE)$@" t)' | \
            DAASE='$(fricas_src_datadir)' ${BOOTSYS}
 	ls $@
@@ -153,7 +155,11 @@ all-fricassys: ${FRICASSYS}
 
 ${FRICASSYS}: ../etc/stamp-databases
 	echo '(defparameter FRICAS-LISP::*building-fricassys* t)' \
+	   '#+gcl(setq si::*optimize-maximum-pages* nil)' \
 	   '(load "makeint.lisp") #-:ecl(BOOT::reclaim)' \
+           '#+:gcl(progn (setq si::*code-block-reserve* "")(si::gbc t)(setq si::*code-block-reserve* (make-array 10000000 :element-type (quote character) :static t) si::*optimize-maximum-pages* t))' \
+	   '#+:cmu (setf (ext:search-list "libspad:")' \
+	   '(list "${FRICAS}/lib/" "${libdir}/fricas/target/${target}/lib/"))' \
 	   '#+:cmu (setq ext:*top-level-auto-declare* t)' \
 	   '#+:cmu (setq *compile-verbose* nil)' \
 	   '#+:cmu (setq *compile-print* nil)' \

src/interp/foam_l.lisp

@@ -161,16 +161,10 @@
 (deftype |HInt| () '(integer #.(- (expt 2 15)) #.(1- (expt 2 15))))
 (deftype |SInt| () '(integer #.(- (expt 2 31)) #.(1- (expt 2 31))))
 
-#+:GCL
-(deftype |BInt| () t)
-#-:GCL
 (deftype |BInt| () 'integer)
 
 (deftype |SFlo| () 'short-float)
 
-#+:GCL
-(deftype |DFlo| () t)
-#-:GCL
 (deftype |DFlo| () 'double-float)
 
 (deftype |Level| () t) ;; structure??

src/interp/i-funsel.boot

@@ -1304,7 +1304,7 @@ orderMmCatStack st ==
     if not mem then haventvars := cons(s,haventvars)
   null havevars => st
   st := nreverse nconc(haventvars,havevars)
-  SORT(st, function mmCatComp)
+  STABLE_-SORT(st, function mmCatComp)
 
 mmCatComp(c1, c2) ==
   b1 := ASSQ(CADR c1, $Subst)

src/interp/i-map.boot

@@ -716,7 +716,10 @@ genMapCode(op,body,sig,fnName,parms,isRecursive) ==
 
   locals := SETDIFFERENCE(COPY $localVars, parms)
   if locals then
-    lets := [['LET, l, ''UNINITIALIZED__VARIABLE, op] for l in locals]
+    -- we should have more sensible $localVars, but ATM just skip
+    -- non-symbols
+    lets := [['LET, l, ''UNINITIALIZED__VARIABLE, op] for l in locals
+               | SYMBOLP(l)]
     body := ['PROGN, :lets, body]
 
   reportFunctionCompilation(op,fnName,parms,

src/interp/i-toplev.boot

@@ -86,7 +86,7 @@ from scratch.
 $spadroot := '""
 
 -- Prefix a filename with the {\bf |$spadroot|} variable.
-make_absolute_filename(name) == STRCONC($spadroot, '"/", name)
+make_absolute_filename(name) == append_directory_name($spadroot,name)
 
 reroot(dir) ==
     $spadroot := dir

src/interp/lisplib.boot

@@ -326,7 +326,7 @@ mkEvalableCategoryForm(c, e) ==       --from DEFINE
   c is [op,:argl] =>
     op="Join" =>
         nargs := [mkEvalableCategoryForm(x, e) or return nil for x in argl]
-        nargs => ["Join", :nargs]
+        nargs => ["JoinInner", ["LIST", :nargs]]
     op is "DomainSubstitutionMacro" =>
         mkEvalableCategoryForm(CADR argl, e)
     op is "mkCategory" => c

src/interp/macros.lisp

@@ -452,13 +452,10 @@ This function respects intermediate #\Newline characters and drops
            *standard-output*))
         (*compile-verbose* nil))
     (declare (special |$comp370_apply|))
-    #-:GCL
     (handler-bind ((warning #'muffle-warning)
                    #+:sbcl (sb-ext::compiler-note #'muffle-warning))
       (funcall driver fn)
       )
-    #+:GCL
-      (funcall driver fn)
 ))
 
 (defun |compQuietly| (fn)

src/interp/nlib.lisp

@@ -247,13 +247,13 @@
 ;; E.g.  "/"  "/u/smwatt"  "../src"
 (defun |DirToString| (d)
   (cond
-    ((equal d '(:root)) "/")
+    ((equal d '(:absolute)) "/")
     ((null d) "")
     ('t (string-right-trim "/" (namestring (make-pathname :directory d)))) ))
 
 (defun |StringToDir| (s)
   (cond
-    ((string= s "/") '(:root))
+    ((string= s "/") '(:absolute))
     ((string= s "")  nil)
     ('t
       (let ((lastc (aref s (- (length s) 1))))
@@ -288,10 +288,7 @@
 
 (defun |fnameReadable?| (f)
   (let ((s
-          #-:GCL
           (ignore-errors (open f :direction :input :if-does-not-exist nil))
-          #+:GCL
-          (open f :direction :input :if-does-not-exist nil)
         ))
     (cond (s (close s) 't) ('t nil)) )
   )

src/interp/util.lisp

@@ -256,12 +256,9 @@ After this function is called the image is clean and can be saved.
                  (apply cname args))))
 
 (defun |eval|(x)
-    #-:GCL
     (handler-bind ((warning #'muffle-warning)
                    #+:sbcl (sb-ext::compiler-note #'muffle-warning))
             (eval  x))
-    #+:GCL
-    (eval  x)
 )
 
 ;;; For evaluating categories we need to bind %.

src/interp/vmlisp.lisp

@@ -142,7 +142,8 @@
 ; 14.1 Creation
 
 ;;; needed for SPAD compiler output
-(define-function '|construct| #'list)
+#-gcl(define-function '|construct| #'list)
+#+gcl(define-function '|construct| #'cl::list)
 
 (defun VEC2LIST (vec) (coerce vec 'list))
 
@@ -289,19 +290,9 @@
 
 (defun GETZEROVEC (n) (MAKE-ARRAY n :initial-element 0))
 
-#-:GCL
 (defun LIST2VEC (list) (coerce list 'vector))
 
 ;;; At least in gcl 2.6.8 coerce is slow, so we roll our own version
-#+:GCL
-(defun LIST2VEC (list)
-    (if (consp list)
-        (let* ((len (length list))
-               (vec (make-array len)))
-             (dotimes (i len)
-                  (setf (aref vec i) (pop list)))
-             vec)
-        (coerce list 'vector)))
 
 
 (define-function 'LIST2REFVEC #'LIST2VEC)
@@ -673,8 +664,20 @@
 #+:poplog
 (defun reclaim () nil)
 
-
-#+(OR IBCL KCL)
+#+gcl
+(defun BPINAME (func)
+  (typecase func
+    (symbol func)
+    ((cons (eql lambda-block) t) (cadr func))
+    (function
+     (cond (#.(fboundp 'function-lambda-expression)
+	    (multiple-value-bind (x y z) (function-lambda-expression func)
+	      (or (and (symbolp z) (fboundp z) z) func)))
+	   ((compiled-function-p func)
+            (system:compiled-function-name func))
+           (func)))))
+
+#+(OR IBCL)
 (defun BPINAME (func)
   (if (functionp func)
       (cond ((symbolp func) func)

src/lib/cfuns-c.c

@@ -44,6 +44,10 @@ SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 #include "cfuns-c.H1"
 
+#ifdef GCL_SOURCE
+#undef HOST_HAS_DIRFD_FCHDIR
+#endif
+
 /* Most versions of Windows don't have the POSIX functions getuid(),
    geteuid(), getgid(), and getegid().  The following definitions are
    approximations, to patch for the deficiencies of Windows
@@ -193,7 +197,7 @@ static char * fricas_copy_string(char *str)
     if (res) {
         strcpy(res, str);
     } else {
-        fprintf(stderr, "Malloc failed (fricas_copy_string)\n");
+        perror("Malloc failed (fricas_copy_string)\n");
     }
     return res;
 }
@@ -217,25 +221,25 @@ remove_directory(char * name)
     struct file_list * flst = 0;
 #ifdef HOST_HAS_DIRFD_FCHDIR
     if (!cur_dir) {
-        fprintf(stderr, "Unable to open current directory\n");
+        perror("Unable to open current directory\n");
         return -1;
     }
 #else
     if (name_len > INT_MAX/5) {
-        fprintf(stderr, "directory name too long\n");
+        perror("directory name too long\n");
         return -1;
     }
 #endif
     dir = opendir(name);
     if (!dir) {
-        fprintf(stderr, "Unable to open directory to be removed\n");
+        perror("Unable to open directory to be removed\n");
         goto err1;
     }
 #ifdef HOST_HAS_DIRFD_FCHDIR
     cur_dir_fd = dirfd(cur_dir);
     dir_fd = dirfd(dir);
     if (cur_dir_fd == -1 || dir_fd == -1) {
-        fprintf(stderr, "dirfd failed\n");
+        perror("dirfd failed\n");
         goto err2;
     }
 #endif
@@ -251,7 +255,7 @@ remove_directory(char * name)
         } else {
             struct file_list * npos = malloc(sizeof(*npos));
             if (!npos) {
-                fprintf(stderr, "Malloc failed (npos)\n");
+                perror("Malloc failed (npos)\n");
                 break;
             }
             npos->file = fricas_copy_string(fname);
@@ -284,14 +288,12 @@ remove_directory(char * name)
 #else
         char pathbuf[PATH_MAX];
         if (strlen(flst->file) + name_len + 1 < PATH_MAX) {
-            strcpy(pathbuf, name);
-            strcat(pathbuf, "/");
-            strcat(pathbuf, flst->file);
-            if (unlink(pathbuf)) {
-                perror("Unlink failed");
-            }
+	  snprintf(pathbuf,sizeof(pathbuf),"%s/%s",name,flst->file);
+	  if (unlink(pathbuf)) {
+	    perror("Unlink failed");
+	  }
         } else {
-            fprintf(stderr, "panthname too long\n");
+            perror("pathname too long\n");
         }
 #endif
         free(flst->file);