Import Upstream version 5d6upstream/5d6

1 files changed, 241 insertions, 52 deletions

diff --git a/build.scm b/build.scm
index 4c4d88d..7f896d4 100644
--- a/build.scm
+++ b/build.scm
@@ -1,13 +1,13 @@
 ;;; "build.scm" Build database and program	-*-scheme-*-
-;;; Copyright (C) 1994-1999 Aubrey Jaffer.
+;;; Copyright (C) 1994-2002 Aubrey Jaffer.
 ;;; See the file `COPYING' for terms applying to this program.
 
 (require 'parameters)
-(require 'database-utilities)
+(require 'databases)
+(require 'database-commands)
 (set! OPEN_WRITE "w")			; Because MS-DOS scripts need ^M
 
-;;;(define build (create-database "buildscm.scm" 'alist-table))
-(define build (create-database #f 'alist-table))
+(define build (add-command-tables (create-database #f 'alist-table)))
 
 (require 'glob)
 (require 'batch)
@@ -73,7 +73,8 @@
      ("setjump.s"	Cray-asm	platform-specific	"provides setjump and longjump for the Cray YMP.")
      ("Init.scm"	Scheme	required	"Scheme initialization.")
      ("Transcen.scm"	Scheme	required	"inexact builtin procedures.")
-     ("Link.scm"	Scheme	required	"compiles and dynamically links.")
+     ("Link.scm"	Scheme	required	"Dynamic link/loading.")
+     ("compile.scm"	Scheme	required	"Hobbit compilation to C.")
      ("Macro.scm"	Scheme	required	"Supports Syntax-Rules Macros.")
      ("scmfig.h"	c-header	required	"contains system dependent definitions.")
      ("patchlvl.h"	c-header	required	"patchlevel of this release.")
@@ -91,6 +92,7 @@
      ("eval.c"	c-source	required	"evaluator, apply, map, and foreach.")
      ("sys.c"	c-source	required	"call-with-current-continuation, opening and closing files, storage allocation and garbage collection.")
      ("subr.c"	c-source	required	"the rest of IEEE functions.")
+     ("debug.c" c-source	required	"debugging, printing code.")
      ("unif.c"	c-source	required	"uniform vectors.")
      ("rope.c"	c-source	required	"C interface functions.")
      ("ramap.c"	c-source	optional	"array mapping")
@@ -215,7 +217,7 @@
 #;Alias for ARRAYS
 (define-build-feature
  'array
- '((define "ARRAYS")))
+ '((features arrays)))
 
 #;array-map! and array-for-each (arrays must also be featured).
 (define-build-feature
@@ -298,7 +300,7 @@
 (define-build-feature
  'turtlegr
  '((c-file "turtlegr.c") (c-lib graphics) (features inexact)
-   (init "init_turtlegr")))
+   (compiled-init "init_turtlegr")))
 
 #;Interface to Xlib graphics routines.
 (define-build-feature
@@ -323,7 +325,7 @@
 #;Client connections to the mysql databases.
 (define-build-feature
  'mysql
- '((c-file "database.c") (c-lib mysql) (init "init_database")))
+ '((c-file "database.c") (c-lib mysql) (compiled-init "init_database")))
 
 #;String regular expression matching.
 (define-build-feature
@@ -447,12 +449,15 @@
      (irix		 mips	   irix	     gcc       ) ;gcc
      (linux		 i386	   linux     gcc       ) ;gcc
      (linux-aout	 i386	   linux     gcc       ) ;gcc
+     (darwin		 powerpc   unix      cc	       ) ;gcc
      (microsoft-c	 8086	   ms-dos    cl	       ) ;link
      (microsoft-c-nt	 i386	   ms-dos    cl	       ) ;link
      (microsoft-quick-c	 8086	   ms-dos    qcl       ) ;qlink
      (ms-dos		 8086	   ms-dos    cc	       ) ;link
+     (openbsd		 *unknown* unix	     gcc       ) ;gcc
      (os/2-cset		 i386	   os/2	     icc       ) ;link386
      (os/2-emx		 i386	   os/2	     gcc       ) ;gcc
+     (plan9-8		 i386	   plan9     8c        ) ;8l
      (svr4-gcc-sun-ld	 sparc	   sunos     gcc       ) ;ld
      (sunos		 sparc	   sunos     cc	       ) ;ld
      (svr4		 *unknown* unix	     cc	       ) ;ld
@@ -484,9 +489,10 @@
      (debug *unknown* "-g" "-g" #f () ())
      (socket *unknown* "" "" #f () ())
      (lib *unknown* "" "" #f () ("scmmain.c"))
-     (mysql *unknown* ""
-	    "-lmysqlclient" "/usr/lib/mysql/libmysqlclient.la" () ())
+     (mysql *unknown* "-I/usr/include/mysql" "-L/usr/lib/mysql -lmysqlclient"
+	    "/usr/lib/mysql/libmysqlclient.a" () ())
 
+     (m cygwin32 "" "" "" () ())
      (c cygwin32 "" "" "" () ())
      (m linux-aout "" "-lm" "/usr/lib/libm.sa" () ())
      (c linux-aout "" "-lc" "/usr/lib/libc.sa" () ())
@@ -523,13 +529,16 @@
      (m atari-st-gcc "" "-lpml" #f () ())
      (m atari-st-turbo-c "" "" #f () ())
 
+     (c plan9-8 "" "" #f () ())
+     (m plan9-8 "" "" #f () ())
+
      (m sunos "" "-lm" #f () ())
      (dlll sunos "-DSUN_DL" "-ldl" #f () ())
      (nostart sunos "" "-e __start -nostartfiles -static" #f ("ecrt0.c") ())
      (dump sunos "" "" #f ("unexelf.c" "gmalloc.c") ())
 
      (m svr4-gcc-sun-ld "" "-lm" #f () ())
-     (dlll svr4-gcc-sun-ld "-DSUN_DL" "-Wl,-ldl" #f () ())
+     (dlll svr4-gcc-sun-ld "-DSUN_DL" "-Wl,-ldl -export-dynamic" #f () ())
      (nostart svr4-gcc-sun-ld "" "-e __start -nostartfiles" #f ("ecrt0.c") ())
      (dump svr4-gcc-sun-ld "" "" #f ("unexelf.c" "gmalloc.c") ())
      (socket svr4-gcc-sun-ld "" "-lsocket -lnsl" #f () ())
@@ -559,6 +568,7 @@
      (m Microsoft-C "" "" #f () ())
      (c Microsoft-C-nt "" "" #f () ("findexec.c"))
      (m Microsoft-C-nt "" "" #f () ())
+     (debug Microsoft-C-nt "-Zi" "/debug" #f () ())
      (c Microsoft-Quick-C "" "" #f () ("findexec.c"))
      (m Microsoft-Quick-C "" "" #f () ())
 
@@ -575,12 +585,20 @@
      (m highc "" "" #f () ())
      (windows highc "-Hwin" "-Hwin" #f () ())
 
+     (m darwin "" "" #f () ())
+     (c darwin "" "" #f () ())
+     (curses darwin "" "" #f () ())
+     (regex darwin "" "" #f () ())
+
      (m freebsd "" "-lm" #f () ())
+     (curses freebsd "" "-lncurses" "/usr/lib/libncurses.a" () ())
      (regex freebsd "" "-lgnuregex" "" () ())
      (editline freebsd "" "-lreadline" "" () ())
      (dlll freebsd "-DSUN_DL" "" "" () ())
      (nostart freebsd "" "-e start -dc -dp -Bstatic -lgnumalloc" #f ("pre-crt0.c") ())
      (dump freebsd "" "/usr/lib/crt0.o" "" ("unexsunos4.c") ())
+     (m openbsd "" "-lm" #f () ())
+     (curses openbsd "" "-lcurses" "/usr/lib/libcurses.a" () ())
      ))
 
   '(compile-commands
@@ -673,12 +691,15 @@
 	   oexe))))
 (defcommand compile-c-files Microsoft-C-nt
   (lambda (files parms)
-    (and (batch:try-chopped-command parms
-				    "cl" "-c" "-nologo" "-O2"
-				    (include-spec "-I" parms)
-				    (c-includes parms)
-				    (c-flags parms)
-				    files)
+    (and (batch:try-chopped-command
+	  parms
+	  "cl" "-c" "-nologo"
+	  (if (memq 'stack-limit (parameter-list-ref parms 'features))
+	      "-Oityb1" "-Ox")
+	  (include-spec "-I" parms)
+	  (c-includes parms)
+	  (c-flags parms)
+	  files)
 	 (truncate-up-to (map c->obj files) #\\))))
 (defcommand link-c-program Microsoft-C-nt
   (lambda (oname objects libs parms)
@@ -880,19 +901,6 @@
 ;			       objects)
 ;			      (batch:rebuild-catalog parms)
 ;			      (string-append oname ".sl"))))
-(defcommand make-dll-archive sunos
-  (lambda (oname objects libs parms)
-    (and (batch:try-command
-	  parms
-	  "ld" "-assert" "pure-text" "-o"
-	  (string-append
-	   (car (parameter-list-ref parms 'implvic))
-	   oname ".so.1.0")
-	  objects)
-	 (batch:rebuild-catalog parms)
-	 (string-append
-	  (car (parameter-list-ref parms 'implvic))
-	  oname ".so.1.0"))))
 
 (defcommand compile-c-files linux-aout
   (lambda (files parms)
@@ -937,11 +945,9 @@
       "-fpic" "-c" (c-includes parms)
       (c-flags parms)
       files)
-     (let* ((platform (car (parameter-list-ref
-			    parms 'platform)))
+     (let* ((platform (car (parameter-list-ref parms 'platform)))
 	    (ld-opts
-	     (map (lambda (l)
-		    (build:lib-ld-flag l platform))
+	     (map (lambda (l) (build:lib-ld-flag l platform))
 		  (parameter-list-ref parms 'c-lib)))
 	    (results
 	     (map
@@ -968,8 +974,7 @@
 	     (car (parameter-list-ref parms 'implvic))
 	     oname ".so")
 	    objects
-	    (map (lambda (l)
-		   (build:lib-ld-flag l platform))
+	    (map (lambda (l) (build:lib-ld-flag l platform))
 		 (parameter-list-ref parms 'c-lib)))
 	   (batch:rebuild-catalog parms)
 	   (string-append
@@ -984,7 +989,7 @@
 	   (append objects libs)))
 	 oname)))
 
-(defcommand compile-c-files Unicos
+(defcommand compile-c-files unicos
   (lambda (files parms)
     (and (batch:try-chopped-command
 	  parms
@@ -1000,6 +1005,34 @@
 	  parms "cc" "setjump.o" "-o" oname objects libs)
 	 oname)))
 
+;; George Bronnikov <goga@rubinstein.mccme.ru> describes options for the
+;; PLAN9 native C compiler `8c':
+;;
+;; -F Enable type-checking of calls to print(2) and other
+;;    formatted print routines.
+;; -V By default, the compilers are non-standardly lax about
+;;    type equality between void* values and other pointers.
+;;    This flag requires ANSI C conformance.
+;; -w Print warning messages about unused variables etc. (It
+;;    does print a lot of them, indeed.)
+;; -p Invoke a standard ANSI C preprocessor before compiling
+;;    (instead of a rudimentary builtin one used by default).
+(defcommand compile-c-files plan9-8
+  (lambda (files parms)
+    (and (batch:try-chopped-command
+	  parms
+	  "8c" "-Fwp" "-DPLAN9"		;"-V"
+	  ;;(include-spec "-i" parms)
+	  (c-includes parms)
+	  (c-flags parms)
+	  files)
+	 (truncate-up-to (map c->8 files) #\/))))
+(defcommand link-c-program plan9-8
+  (lambda (oname objects libs parms)
+    (and (batch:try-command
+	  parms "8l" "-o" oname objects libs)
+	 oname)))
+
 (defcommand compile-c-files gcc
   (lambda (files parms)
     (and (batch:try-chopped-command parms
@@ -1029,6 +1062,19 @@
 				    (c-flags parms)
 				    files)
 	 (truncate-up-to (map c->o files) "\\/]"))))
+(defcommand make-dll-archive gcc
+  (lambda (oname objects libs parms)
+    (and (batch:try-command
+	  parms
+	  "ld" "-assert" "pure-text" "-o"
+	  (string-append
+	   (car (parameter-list-ref parms 'implvic))
+	   oname ".so.1.0")
+	  objects)
+	 (batch:rebuild-catalog parms)
+	 (string-append
+	  (car (parameter-list-ref parms 'implvic))
+	  oname ".so.1.0"))))
 
 (defcommand compile-c-files cygwin32
   (lambda (files parms)
@@ -1074,6 +1120,33 @@
 			       "/usr/lib/crt0.o")
 			     (append objects libs)))
 	 oname)))
+(defcommand compile-dll-c-files svr4-gcc-sun-ld
+  (lambda (files parms)
+    (and
+     (batch:try-chopped-command
+      parms
+      "gcc" "-O2"
+      "-fpic" "-c" (c-includes parms)
+      (c-flags parms)
+      files)
+     (let* ((platform (car (parameter-list-ref parms 'platform)))
+	    (ld-opts
+	     (map (lambda (l) (build:lib-ld-flag l platform))
+		  (parameter-list-ref parms 'c-lib)))
+	    (results
+	     (map
+	      (lambda (fname)
+		(and (batch:try-command
+		      parms
+		      "ld" "-G" "-o"
+		      (string-append fname ".so")
+		      (string-append fname ".o")
+		      ld-opts)
+		     (batch:delete-file
+		      parms (string-append fname ".o"))
+		     (string-append fname ".so")))
+	      (truncate-up-to (map c-> files) #\/))))
+       (and (apply and? results) results)))))
 
 (defcommand compile-c-files svr4
   (lambda (files parms)
@@ -1397,6 +1470,79 @@
 	  (car (parameter-list-ref parms 'implvic))
 	  oname ".so"))))
 
+(defcommand compile-c-files darwin
+  (lambda (files parms)
+    (and (batch:try-chopped-command
+	  parms
+	  "cc" "-O3" "-c"
+	  (c-includes parms)
+	  (c-flags parms)
+	  files)
+	 (map c->o files))))
+(defcommand link-c-program darwin
+  (lambda (oname objects libs parms)
+    (batch:rename-file parms
+		       oname (string-append oname "~"))
+    (and (batch:try-command parms
+			    "cc" "-o" oname
+			    (append objects libs))
+	 oname)))
+
+(defcommand compile-c-files openbsd
+  (lambda (files parms)
+    (and (batch:try-chopped-command
+	  parms
+	  "cc" "-O2" "-Wall" "-c"
+	  (c-includes parms)
+	  (c-flags parms)
+	  files)
+	 (map c->o files))))
+(defcommand link-c-program openbsd
+  (lambda (oname objects libs parms)
+    (batch:rename-file parms
+		       oname (string-append oname "~"))
+    (and (batch:try-command parms
+			    "cc" "-o" oname
+			    (must-be-first
+			     '("-nostartfiles"
+			       "pre-crt0.o" "crt0.o"
+			       "/usr/lib/crt0.o")
+			     (append libs objects)))
+	 oname)))
+(defcommand compile-dll-c-files openbsd
+  (lambda (files parms)
+    (and (batch:try-chopped-command
+	  parms
+	  "cc" "-O2" "-Wall" "-fPIC" "-c"
+	  (string-append
+	   "-I" (parameter-list-ref parms 'scm-srcdir))
+	  (c-includes parms)
+	  (c-flags parms)
+	  files)
+	 (let ((objs (map c->o files)))
+	   (every
+	    (lambda (f)
+	      (and (batch:try-command
+		    parms "gcc" "-shared" "-fPIC" f)
+		   (batch:try-command
+		    parms "mv" "a.out" f)))
+	    objs)
+	   objs))))
+
+(defcommand make-dll-archive openbsd
+  (lambda (oname objects libs parms)
+    (and (batch:try-command
+	  parms
+	  "gcc" "-shared" "-fPIC" "-o"
+	  (string-append
+	   (car (parameter-list-ref parms 'implvic))
+	   oname ".so")
+	  objects)
+	 (batch:rebuild-catalog parms)
+	 (string-append
+	  (car (parameter-list-ref parms 'implvic))
+	  oname ".so"))))
+
 (for-each (build 'add-domain)
 	  '((C-libraries C-libraries #f symbol #f)))
 
@@ -1406,7 +1552,7 @@
     *parameter-columns*
     *parameter-columns*
     ((1 platform single platform
-	(lambda (pl) (list batch:platform))
+	(lambda (pl) (list *operating-system*))
 	#f
 	"what to build it for")
      (2 target-name single string (lambda (pl) '("scm")) #f
@@ -1446,12 +1592,9 @@
      (16 scm-srcdir single filename
 	 (lambda (pl) (list (user-vicinity))) #f
 	 "directory path for files in the manifest")
-     (17 scm-libdir single filename
-	 (lambda (pl) (list (implementation-vicinity))) #f
-	 "directory path for files in the manifest")
-     (18 c-defines nary expression #f #f "#defines for C")
-     (19 c-includes nary expression #f #f "library induced defines for C")
-     (20 batch-port nary expression #f #f
+     (17 c-defines nary expression #f #f "#defines for C")
+     (18 c-includes nary expression #f #f "library induced defines for C")
+     (19 batch-port nary expression #f #f
 	 "port batch file will be written to.")
      ))
   '(build-pnames
@@ -1473,7 +1616,6 @@
      ("compiler options" 14)
      ("linker options" 15)
      ("scm srcdir" 16)
-     ("scm libdir" 17)
      ))
 
   '(*commands*
@@ -1493,9 +1635,6 @@
       #f
       "SCM Build Database"))))
 
-;;;((build 'close-database))
-;;;(define build (open-database! "buildscm.scm" 'alist-table))
-
 (define build:error slib:error)
 (define build:c-libraries #f)
 (define build:lib-cc-flag #f)
@@ -1503,6 +1642,7 @@
 (define build:c-lib-support #f)
 (define build:c-suppress #f)
 (define plan-command #f)
+(define platform->os #f)
 
 ;;; Look up command on a platform, but default to '*unknown* if not
 ;;; initially found.
@@ -1588,10 +1728,15 @@
 	    parms (cons 'batch-dialect (list (os->batch-dialect os)))))))
 
       (adjoin-parameters!
-       parms
-       (cons 'c-defines c-defines)
-       (cons 'c-includes c-includes))
-
+	     parms
+	     (cons 'c-defines c-defines)
+	     (cons 'c-includes c-includes))
+      (set! parms
+	    (cons
+	     (cons 'operating-system
+		   (map platform->os (parameter-list-ref parms 'platform)))
+	     parms))
+      
       (let ((name (parameter-list-ref parms 'who)))
 	(set! name (if (null? name) (current-output-port) (car name)))
 	(batch:call-with-output-script
@@ -1678,6 +1823,7 @@
 
 (define c-> (filename:substitute?? "*.c" "*"))
 (define c->o (filename:substitute?? "*.c" "*.o"))
+(define c->8 (filename:substitute?? "*.c" "*.8"))
 (define c->obj (filename:substitute?? "*.c" "*.obj"))
 (define obj-> (filename:substitute?? "*.obj" "*"))
 (define obj->exe (filename:substitute?? "*.obj" "*.exe"))
@@ -1701,6 +1847,46 @@
 				  "slibcat"))
   #t)
 
+(define (logger . args)
+  (define cep (current-error-port))
+  (cond ((provided? 'bignum)
+	 (require 'posix-time)
+	 (let ((ct (ctime (current-time))))
+	   (string-set! ct (+ -1 (string-length ct)) #\:)
+	   (for-each (lambda (x) (display x cep))
+		     (cons ct (cons #\  args)))))
+	(else (for-each (lambda (x) (display x cep)) args)))
+  (newline cep))
+
+(define build:qacs #f)
+(define (build:serve request-line query-string header)
+  (define query-alist (and query-string (uri:decode-query query-string)))
+  (if (not build:qacs)
+      (set! build:qacs (make-query-alist-command-server build '*commands* #t)))
+  (call-with-outputs
+   (lambda () (build:qacs query-alist))
+   (lambda (stdout stderr . status)
+     (cond ((or (substring? ": ERROR: " stderr)
+		(substring? ": WARN: " stderr))
+	    => (lambda (idx)
+		 (set! stderr (substring stderr (+ 2 idx)
+					 (string-length stderr))))))
+     (cond ((null? status)
+	    (logger "Aborting query")
+	    (pretty-print query-alist)
+	    (display stderr)
+	    (list "buildscm Abort" (html:pre stdout)
+		  "<B>" (html:pre stderr) "</B>"))
+	   (else
+	    (display stderr)		;query is already logged
+	    (if (car status)
+		(http:content '(("Content-Type" . "text/plain")) ;application/x-sh
+			      stdout)
+		(list "buildscm Error" "<B>" (html:pre stderr) "</B>"
+		      "<HR>"
+		      (html:pre stdout))))))))
+;;; (print 'request-line '= (cgi:request-line)) (print 'header '=) (for-each print (cgi:query-header))
+
 (define build:initializer
   (lambda (rdb)
     (set! build:c-libraries ((rdb 'open-table) 'c-libraries #f))
@@ -1716,10 +1902,13 @@
     (set! build:c-suppress
 	  (make-defaulting-platform-lookup
 	   (build:c-libraries 'get 'suppress-files)))
+    (set! platform->os (((rdb 'open-table) 'platform #f)
+			'get 'operating-system))
     (set! plan-command
 	  (let ((lookup (make-defaulting-platform-lookup
 			 (((rdb 'open-table) 'compile-commands #f)
 			  'get 'procedure))))
 	    (lambda (thing plat)
+	      ;;(print 'thing thing 'plat plat)
 	      (slib:eval (lookup thing plat)))))))
 (build:initializer build)