[[project @ 1997-03-29 18:46:41 by ghouston]
ghouston**19970329184647
 Ignore-this: 3ce89a1ec12653e0730aec2d8491ac84
 * syscalls.scm (name->user-info, uid->user-info): defined, needed
 by fname.scm.
 
 * Makefile.am (subpkgdata_DATA): add fname.scm, syscalls.scm, scsh.scm.
 
 * init.scm: load fname.scm, scsh.scm and call init-scsh-vars.
 
 * scsh.scm: new file, list manipulation and global variable init
 parts from scsh.
 
 * fname.scm: copied from scsh.
 
 * init.scm (wait/poll, wait/stopped-children): defined, all that's
 needed from waitcodes.scm.
] addfile ./env-old.scm
addfile ./fname.scm
addfile ./scsh.scm
hunk ./ChangeLog 1
+Tue Mar 25 04:28:51 1997  Gary Houston  <ghouston@actrix.gen.nz>
+
+	* syscalls.scm (name->user-info, uid->user-info): defined, needed
+	by fname.scm.
+
+	* Makefile.am (subpkgdata_DATA): add fname.scm, syscalls.scm, scsh.scm.
+
+	* init.scm: load fname.scm, scsh.scm and call init-scsh-vars.
+
+	* scsh.scm: new file, list manipulation and global variable init
+	parts from scsh.
+
+	* fname.scm: copied from scsh.
+
+	* init.scm (wait/poll, wait/stopped-children): defined, all that's
+	needed from waitcodes.scm.
+
hunk ./Makefile.am 7
-	defrec.scm errno.scm init.scm let-opt.scm netconst.scm \
-	network.scm rdelim.scm receive.scm rw.scm syntax.scm utilities.scm
+	defrec.scm errno.scm fname.scm init.scm let-opt.scm netconst.scm \
+	network.scm rdelim.scm receive.scm \
+	rw.scm scsh.scm syntax.scm syscalls.scm utilities.scm
hunk ./Makefile.in 40
-VERSION = @VERSION@
+MAINT = @MAINT@
hunk ./Makefile.in 42
-module = @module@
hunk ./Makefile.in 43
-MAINT = @MAINT@
+module = @module@
+VERSION = @VERSION@
hunk ./Makefile.in 50
-	defrec.scm errno.scm init.scm let-opt.scm netconst.scm \
-	network.scm rdelim.scm receive.scm rw.scm syntax.scm utilities.scm
+	defrec.scm errno.scm fname.scm init.scm let-opt.scm netconst.scm \
+	network.scm rdelim.scm receive.scm \
+	rw.scm scsh.scm syntax.scm syscalls.scm utilities.scm
hunk ./env-old.scm 1
+;;; installed-scm-file
+
+;;;;  Copyright (C) 1996 Free Software Foundation, Inc.
+;;;;  Includes code from SCSH 0.4.4, Copyright (c) 1993 by Olin Shivers.
+
+;;; Additional Unix interface definitions SCSH-style.
+
+;;; Environment strings.
+;;; primitives: getenv, putenv, environ
+
+;;; FIXME: should getenv throw exception if variable not found?
+
+(define (setenv name value)
+  (putenv (string-append name "=" value)))
+
+(define (env->alist)
+  (let ((split (lambda (str)
+		 (let ((len (string-length str)))
+		   (let next-char ((pos 0))
+		     (if (= pos len)
+			 ;; represent missing '=' by #f.
+			 (cons str #f)
+			 (if (char=? (string-ref str pos) #\=)
+			     (cons (substring str 0 pos)
+				   (substring str (+ pos 1) len))
+			     (next-char (+ pos 1)))))))))
+    (map split
+	 (environ))))
+    
+(define (alist->env alist)
+  (environ 
+   (map (lambda (pair)
+	  (string-append (if (cdr pair)
+			     (string-append (car pair) "=" (cdr pair))
+			     ;; convert #f (back?) to a missing '='.
+			     (car pair))))
+	alist)))
+
+(define (alist-delete key alist)
+  (let next-pair ((rest alist)
+		  (result ()))
+    (if (null? rest)
+	(reverse result)
+	(next-pair (cdr rest)
+		   (if (equal? (caar rest) key)
+		       result
+		       (cons (car rest) result))))))
+
+(define (alist-update key val alist)
+  (cons (cons key val) (alist-delete key alist)))
+
+;alist-compress
+;with-env*
+;with-total-env*
+;with-env
+;with-total-env
+;add-before
+;add-after
hunk ./fname.scm 1
+;;; Code for processing Unix file names.
+;;; Copyright (c) 1992 by Olin Shivers (shivers@lcs.mit.edu).
+;;; Please imagine a long, tedious, legalistic 5-page gnu-style copyright
+;;; notice appearing here to the effect that you may use this code any
+;;; way you like, as long as you don't charge money for it, remove this
+;;; notice, or hold me liable for its results.
+
+;;; We adhere to Posix file name rules, plus we treat files beginning with
+;;; ~ as absolute paths.
+
+;;; Relevant bits of CScheme:
+;;;    pathnm sfile strnin unxcwd unxdir unxpar unxprm unxpth unxunp wrkdir
+
+(define (file-name-directory? fname)
+  (or (string=? fname "")			; Note! "" is directory (cwd)
+      (char=? #\/ (string-ref fname (- (string-length fname) 1)))))
+
+(define (file-name-non-directory? fname)
+  (or (string=? fname "")			; and file-name (root).
+      (not (char=? #\/ (string-ref fname (- (string-length fname) 1))))))
+
+(define (file-name-as-directory fname)
+  (if (string=? fname ".") ""
+      (let ((len (string-length fname)))
+	(if (and (> len 0)
+		 (char=? #\/ (string-ref fname (- len 1))))
+	    fname
+	    (string-append fname "/")))))
+
+
+;;; Return #f if str doesn't contain a slash at all.
+(define (last-non-slash str)
+  (let lp ((i (- (string-length str) 1)))
+    (and (>= i 0)
+	 (if (char=? #\/ (string-ref str i))
+	     (lp (- i 1))
+	     i))))
+
+(define (directory-as-file-name fname)
+  (let ((len (string-length fname)))
+    (if (zero? len) "."		; "" -> "."
+
+	;; Trim trailing slashes.
+	(cond ((last-non-slash fname) =>
+	       (lambda (i)
+		 (if (= i (- len 1)) fname ; No slash.
+		     (substring fname 0 (+ i 1))))) ; Trim slashes.
+
+	      ;;; Solid slashes -- invoke weird Posix rule.
+	      (else (if (= len 2) "//" "/"))))))
+
+
+(define (ensure-file-name-is-directory fname)
+  (if (string=? fname "") ""
+      (file-name-as-directory fname)))
+
+
+(define (ensure-file-name-is-nondirectory fname)
+  (if (string=? fname "") ""
+      (directory-as-file-name fname)))
+
+
+(define (file-name-absolute? fname)
+  (or (= (string-length fname) 0)
+      (char=? #\/ (string-ref fname 0))
+      (char=? #\~ (string-ref fname 0))))
+
+
+;;; Returns FNAME's directory component in *directory form.*
+(define (file-name-directory fname)
+  (cond ((rindex fname #\/) =>
+	 (lambda (rslash)
+	   (if (last-non-slash fname)
+	       (substring fname 0 (+ 1 rslash))
+	       ""))) ; Posix strangeness: solid slashes are root.
+	(else "")))
+
+
+(define (file-name-nondirectory fname)
+  (cond ((rindex fname #\/) =>
+	 (lambda (rslash)
+	   (if (last-non-slash fname)
+	       (substring fname (+ 1 rslash) (string-length fname))
+	       fname)))	; Posix strangeness: solid slashes are root.
+	(else fname)))
+
+    
+(define (split-file-name fname)
+  (let* ((fname (ensure-file-name-is-nondirectory fname))
+	 (len (string-length fname)))
+    (let split ((start 0))
+      (cond ((>= start len) '())
+	    ((index fname #\/ start) =>
+	     (lambda (slash)
+	       (cons (substring fname start slash)
+		     (split (+ slash 1)))))
+	    (else (list (substring fname start len)))))))
+
+
+(define (path-list->file-name pathlist . maybe-dir)
+  (let ((root (ensure-file-name-is-nondirectory (:optional maybe-dir ".")))
+	;; Insert slashes *between* elts of PATHLIST.
+	(w/slashes (if (pair? pathlist)
+		       (let insert-slashes ((pathlist pathlist))
+			 (let ((elt (car pathlist))
+			       (pathlist (cdr pathlist)))
+			   (cons elt (if (pair? pathlist)
+					 (cons "/" (insert-slashes pathlist))
+					 '()))))
+		       '(""))))
+    (apply string-append
+	   (if (and (pair? pathlist)
+		    (string=? "" (car pathlist)))
+	       w/slashes ; Absolute path not relocated.
+	       (cons (file-name-as-directory root) w/slashes)))))
+		   
+
+(define (parse-file-name fname)
+  (let ((nd (file-name-nondirectory fname)))
+    (values (file-name-directory fname)
+	    (file-name-sans-extension nd)
+	    (file-name-extension nd))))
+
+
+;;; Return the index of the . separating the extension from the rest of
+;;; the file name. If no extension, returns an index pointing off the
+;;; end of the string, i.e. (string-length fname). "Dot-files," such as
+;;; /usr/shivers/.login are not considered extensions.
+
+(define (file-name-extension-index fname)
+  (let ((dot (rindex fname #\.)))
+    (if (and dot
+	     (> dot 0)
+	     (not (char=? #\/ (string-ref fname (- dot 1)))))
+	dot
+	(string-length fname))))
+
+(define (file-name-sans-extension fname)
+  (substring fname 0 (file-name-extension-index fname)))
+
+(define (file-name-extension fname)
+  (substring fname (file-name-extension-index fname)
+	           (string-length fname)))
+
+(define (replace-extension fname ext)
+  (string-append (file-name-sans-extension fname) ext))
+
+
+(define (resolve-tilde-file-name fname)
+  (let ((len (string-length fname)))
+    (if (and (> len 0) (char=? #\~ (string-ref fname 0)))
+	(let ((tilde->homedir (lambda (end)
+				(if (= end 1) home-directory ; Just ~
+				    (let* ((user (substring fname 1 end))
+					   (ui (name->user-info user)))
+				      (user-info:home-dir ui))))))
+	  (cond ((index fname #\/ 1) =>
+		 (lambda (slash)
+		   (string-append (tilde->homedir slash) "/"
+				  (substring fname (+ slash 1) len))))
+		(else (tilde->homedir len))))
+	fname)))
+
+(define (resolve-file-name fname . maybe-root)
+  (let* ((root (ensure-file-name-is-nondirectory (:optional maybe-root ".")))
+	 (fname (ensure-file-name-is-nondirectory fname))
+	 (len (string-length fname)))
+    (if (zero? len) "/"
+	(let ((c (string-ref fname 0)))
+	  (cond ((char=? #\/ c) fname) 	; Absolute file name.
+
+		((char=? #\~ c) 	; ~ file name
+		 (resolve-tilde-file-name fname))
+
+		(else (string-append (file-name-as-directory root) fname)))))))
+
+
+;;; - Remove leading and internal occurrences of dot. A trailing dot
+;;;   is left alone, in case the parent is a symlink.
+;;; - Remove internal and trailing double-slashes. A leading double-slash
+;;;   is left alone, in accordance w/Posix. However, triple and more leading
+;;;   slashes are reduced to a single slash, in accordance w/Posix.
+;;; - Double-dots are left alone, in case they come after symlinks.
+
+(define (simplify-file-name fname)
+  ;; First, we simplify leading multiple slashes:
+  ;; 1 or >2 slashes -> /, 2 slashes -> //
+  (receive (slashes fname)
+	   (let ((len (string-length fname)))
+	     (if (and (> len 0) (char=? #\/ (string-ref fname 0)))
+		 (let ((j (let lp ((i 1)) ; j is index of first non-slash.
+			    (if (and (< i len)
+				     (char=? (string-ref fname i) #\/))
+				(lp (+ i 1))
+				i))))
+		   (if (< j 3)
+		       (values (substring fname 0 j); One or two slashes - OK.
+			       (substring fname j len))
+		       (values "/" (substring fname (- j 1) len))))
+		 (values "" fname)))
+
+    ;; At this point, all leading slashes have been pulled off of FNAME.
+    ;; Any remaining repeated slashes are fair game for removal.
+    (let* ((path-list (split-file-name fname))
+	   (ans (if (pair? path-list)
+		    (reverse (let lp ((path-list path-list)
+				      (ans (list slashes)))
+			       (let ((elt (car path-list))
+				     (path-list (cdr path-list)))
+				 (if (pair? path-list)
+				     (lp path-list
+					 (if (or (string=? "." elt) ; kill .
+						 (string=? "" elt)) ; and //
+					     ans
+					     `("/" ,elt ,@ans)))
+				     (cons elt ans)))))
+		    (list slashes))))
+      (apply string-append ans))))
+
+
+(define (expand-file-name fname . maybe-dir)
+  (simplify-file-name (apply resolve-file-name fname maybe-dir)))
+
+
+(define (home-dir . maybe-user)
+  (if (pair? maybe-user)
+      (let ((user (car maybe-user)))
+	(ensure-file-name-is-nondirectory
+	    (or (%homedir user)
+		(error "Cannot get user's home directory"
+		       user))))
+      home-directory))
+
+
+;;; (home-file [user] fname)
+
+(define (home-file arg1 . maybe-arg2)
+  (receive (dir fname)
+	   (if (pair? maybe-arg2)
+	       (values (home-dir arg1) (car maybe-arg2))
+	       (values home-directory  arg1))
+    (string-append (file-name-as-directory dir) fname)))
+
+
+;;; Ugh.
+(define (substitute-env-vars str)
+  (let lp ((ans '()) (s str))
+    (let ((len (string-length s)))
+      (cond
+        ((zero? len) (apply string-append (reverse! ans)))
+	((index s #\$) =>
+	 (lambda (i)
+	   (let ((ans (cons (substring s 0 i) ans))
+		 (s (substring s (+ i 1) len))
+		 (len (- len (+ i 1))))
+	     (if (zero? len) (lp ans "")
+		 (let ((next-char (string-ref s 0)))
+		   (cond ((char=? #\{ next-char)
+			  (cond ((index s #\}) =>
+				 (lambda (i)
+				   (lp (cons (getenv (substring s 1 i)) ans)
+				       (substring s (+ i 1) len))))
+				(else (error "Unbalanced ${ delimiter in string" s))))
+			 (else
+			  (let ((i (or (index s #\/) len)))
+			    (lp (cons (getenv (substring s 0 i)) ans)
+				(substring s i len))))))))))
+	(else (lp (cons s ans) ""))))))
hunk ./init.scm 24
+;; waitcodes.scm.
+(define wait/poll 		WNOHANG)
+(define wait/stopped-children	WUNTRACED)
+
hunk ./init.scm 42
+(load-from-path "scsh/fname.scm")
hunk ./init.scm 44
-
hunk ./init.scm 51
+(load-from-path "scsh/scsh.scm")
+
+(init-scsh-vars #f)
hunk ./scsh.scm 1
+;;; A Scheme shell.
+;;; Copyright (c) 1992 by Olin Shivers.
+;;; Copyright (c) 1994 by Brian D. Carlstrom.
+
+;;; Guile port is incomplete.
+
+;;; Environment stuff
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; These two functions are obsoleted by the more general INFIX-SPLITTER and
+;;; JOIN-STRINGS functions. However, we keep SPLIT-COLON-LIST defined
+;;; internally so the top-level startup code (INIT-SCSH) can use it
+;;; to split up $PATH without requiring the field-splitter or regexp code.
+
+(define (split-colon-list clist)
+  (let ((len (string-length clist)))
+    (if (= 0 len) '()			; Special case "" -> ().
+
+	;; Main loop.
+	(let split ((i 0))
+	  (cond ((index clist #\: i) =>
+		 (lambda (colon)
+		   (cons (substring clist i colon)
+			 (split (+ colon 1)))))
+		(else (list (substring clist i len))))))))
+
+;;; Unix colon lists typically use colons as separators, which
+;;; is not as clean to deal with as terminators, but that's Unix.
+;;; Note ambiguity: (s-l->c-l '()) = (s-l->c-l '("")) = "".
+
+; (define (string-list->colon-list slist)
+;   (if (pair? slist)
+;       (apply string-append
+; 	     (let colonise ((lis slist))	; LIS is always
+; 	       (let ((tail (cdr lis))) 		; a pair.
+; 		 (cons (car lis)
+; 		       (if (pair? tail)
+; 			   (cons ":" (colonise tail))
+; 			   '())))))
+;       ""))	; () case.
+
+
+(define (alist-delete key alist)
+  (filter (lambda (key/val) (not (equal? key (car key/val)))) alist))
+
+(define (alist-update key val alist)
+  (cons (cons key val)
+	(alist-delete key alist)))
+
+;;; Remove shadowed entries from ALIST. Preserves element order.
+;;; (This version shares no structure.)
+
+(define (alist-compress alist) 
+  (reverse (let compress ((alist alist) (ans '()))
+	     (if (pair? alist)
+		 (let ((key/val (car alist))
+		       (alist (cdr alist)))
+		   (compress alist (if (assoc (car key/val) ans) ans
+				       (cons key/val ans))))
+		 ans))))
+
+;; Tail-recursive loops suck.
+;; (define (alist-compress alist)
+;;   (loop (initial (ans '()))
+;;	   (for key/val in alist)
+;;   
+;;	   (when (not (assoc (car key/val) ans)))
+;;	   (next (ans (cons key/val ans)))
+;;   
+;;	   (result (reverse ans))))
+
+(define (add-before elt before list)
+  (let rec ((list list))
+    (if (pair? list)
+	(let ((x (car list)))
+	  (if (equal? x before)
+	      (cons elt list)
+	      (cons x (rec (cdr list)))))
+	(cons elt list))))
+
+;;; In ADD-AFTER, the labelled LET adds ELT after the last occurrence of AFTER
+;;; in LIST, and returns the list. However, if the LET finds no occurrence 
+;;; of AFTER in LIST, it returns #F instead.
+
+(define (add-after elt after list)
+  (or (let rec ((list list))
+	(if (pair? list)
+	    (let* ((x (car list))
+		   (tail (cdr list))
+		   (ans (rec tail))) ; #f if AFTER wasn't encountered.
+	      (cond (ans (cons x ans))
+		    ((equal? x after)
+		     (cons x (cons elt tail)))
+		    (else #f)))		; AFTER doesn't appear in LIST.
+	    #f))			; AFTER doesn't appear in LIST.
+      (cons elt list))) 
+
+;;; Or, just say...
+;;; (reverse (add-before elt after (reverse list)))
+
+;;; Some globals:
+(define home-directory "")
+(define exec-path-list '())
+
+(define (init-scsh-vars quietly?)
+  (set! home-directory
+	(cond ((getenv "HOME") => ensure-file-name-is-nondirectory)
+	      (else (if (not quietly?)
+			(warn "Starting up with no home directory ($HOME)."))
+		    "/")))
+  (set! exec-path-list
+	(cond ((getenv "PATH") => split-colon-list)
+	      (else (if (not quietly?)
+			(warn "Starting up with no path ($PATH)."))
+		    '()))))
+
+
hunk ./syscalls.scm 25
-
+(define name->user-info user-info)
+(define uid->user-info user-info)
+