*** ../gcl-cvs/./ansi-tests/makefile Sun May 16 15:02:09 2004 --- ./ansi-tests/makefile Wed May 19 15:08:19 2004 *************** *** 1,4 **** ! # LISP=gcl test: @rm -rf scratch --- 1,4 ---- ! LISP=gcl test: @rm -rf scratch *** ../gcl-cvs/./configure.in Tue May 11 20:38:44 2004 --- ./configure.in Wed May 19 14:15:44 2004 *************** AC_SUBST(INFO_DIR) *** 1550,1555 **** --- 1550,1556 ---- AC_MSG_CHECKING([for tcl/tk]) + if test "$have_x" = "disabled" ; then echo -n no X no TK ... ; TK_CONFIG_PREFIX="without-tk"; else if test -d "${TCL_CONFIG_PREFIX}" ; then true ; else rm -f conftest.tcl *************** if test "$have_dl" = "0" ; then *** 1649,1654 **** --- 1650,1659 ---- TCL_LIBS=`echo ${TCL_LIBS} | sed -e "s:-ldl::g"` fi + TK_LISP_LIB='gcl-tk/tk-package.lsp gcl-tk/tkl.o gcl-tk/tinfo.o gcl-tk/decode.tcl gcl-tk/demos/*.lsp gcl-tk/demos/*.lisp gcl-tk/demos/*.o' + TCL_EXES='gcl-tk/gcl.tcl gcl-tk/gcltkaux$(EXE)' + + fi AC_SUBST(TK_CONFIG_PREFIX) AC_SUBST(TK_LIBRARY) *************** AC_SUBST(TK_XINCLUDES) *** 1663,1673 **** AC_SUBST(TCL_LIB_SPEC) AC_SUBST(TCL_DL_LIBS) AC_SUBST(TCL_LIBS) ! ! ! ! ! if test -d "${TK_CONFIG_PREFIX}" ; then AC_MSG_RESULT([using TK_VERSION=${TK_VERSION} in ${TK_CONFIG_PREFIX}]) --- 1668,1675 ---- AC_SUBST(TCL_LIB_SPEC) AC_SUBST(TCL_DL_LIBS) AC_SUBST(TCL_LIBS) ! AC_SUBST(TK_LISP_LIB) ! AC_SUBST(TCL_EXES) if test -d "${TK_CONFIG_PREFIX}" ; then AC_MSG_RESULT([using TK_VERSION=${TK_VERSION} in ${TK_CONFIG_PREFIX}]) *************** fi *** 1678,1686 **** NOTIFY=$enable_notify AC_SUBST(NOTIFY) - - - # for sgbc the mprotect capabilities. # the time handling for unixtime, add timezone --- 1680,1685 ---- *** ../gcl-cvs/./makedefc.in Wed Mar 10 23:57:15 2004 --- ./makedefc.in Wed May 19 14:15:44 2004 *************** address@hidden@ *** 39,44 **** --- 39,46 ---- address@hidden@ address@hidden@ address@hidden@ + address@hidden@ + address@hidden@ address@hidden@ address@hidden@ *** ../gcl-cvs/./makefile Sat Mar 20 02:31:49 2004 --- ./makefile Wed May 19 14:15:44 2004 *************** prefix=/usr/local *** 10,17 **** # ./configure --prefix=/usr/share # Allow platform defs file to override this. ! TK_LISP_LIB=gcl-tk/tkl.o gcl-tk/tinfo.o gcl-tk/decode.tcl gcl-tk/demos/*.lsp gcl-tk/demos/*.lisp gcl-tk/demos/*.o ! TCL_EXES=gcl-tk/gcl.tcl gcl-tk/gcltkaux$(EXE) GCL_DVI=gcl-tk.dvi gcl-si.dvi gcl.dvi GCL_HTML=gcl-si_toc.html gcl-tk_toc.html gcl_toc.html --- 10,17 ---- # ./configure --prefix=/usr/share # Allow platform defs file to override this. ! # TK_LISP_LIB=gcl-tk/tkl.o gcl-tk/tinfo.o gcl-tk/decode.tcl gcl-tk/demos/*.lsp gcl-tk/demos/*.lisp gcl-tk/demos/*.o ! # TCL_EXES=gcl-tk/gcl.tcl gcl-tk/gcltkaux$(EXE) GCL_DVI=gcl-tk.dvi gcl-si.dvi gcl.dvi GCL_HTML=gcl-si_toc.html gcl-tk_toc.html gcl_toc.html *************** VERSION=`cat majvers`.`cat minvers` *** 37,42 **** --- 37,51 ---- all: $(BUILD_BFD) $(PORTDIR)/$(FLISP) command cmpnew/gcl_collectfn.o lsp/gcl_info.o do-gcl-tk do-info + retry: + make $(PORTDIR)/$(FLISP) + + remake: + -rm -f unixport/saved_* unixport/lib* unixport/raw_* */*.o + make all + + gcl: $(PORTDIR)/saved_gcl + xgcl: $(PORTDIR)/saved_xgcl $(PORTDIR)/saved_xgcl: $(PORTDIR)/saved_gcl *************** command: *** 131,137 **** merge: $(CC) -o merge merge.c ! LISP_LIB=clcs/myload1.lisp clcs/clcs_macros.lisp cmpnew/gcl_collectfn.o cmpnew/gcl_collectfn.lsp lsp/gcl_gprof.lsp lsp/gcl_info.o lsp/gcl_profile.lsp lsp/gcl_export.lsp lsp/gcl_autoload.lsp cmpnew/gcl_cmpmain.lsp cmpnew/gcl_cmpopt.lsp cmpnew/gcl_lfun_list.lsp lsp/gcl_auto_new.lsp h/cmpinclude.h unixport/init_$(SYSTEM).lsp unixport/lib$(SYSTEM).a unixport/libgclp.a gcl-tk/tk-package.lsp $(TK_LISP_LIB) $(RL_LIB) $(FIRST_FILE) $(LAST_FILE) $(addsuffix /sys-proclaim.lisp,lsp cmpnew pcl clcs) install-command: rm -f $(DESTDIR)$(prefix)/bin/gcl --- 140,146 ---- merge: $(CC) -o merge merge.c ! LISP_LIB=clcs/myload1.lisp clcs/clcs_macros.lisp cmpnew/gcl_collectfn.o cmpnew/gcl_collectfn.lsp lsp/gcl_gprof.lsp lsp/gcl_info.o lsp/gcl_profile.lsp lsp/gcl_export.lsp lsp/gcl_autoload.lsp cmpnew/gcl_cmpmain.lsp cmpnew/gcl_cmpopt.lsp cmpnew/gcl_lfun_list.lsp lsp/gcl_auto_new.lsp h/cmpinclude.h unixport/init_$(SYSTEM).lsp unixport/lib$(SYSTEM).a unixport/libgclp.a $(TK_LISP_LIB) $(RL_LIB) $(FIRST_FILE) $(LAST_FILE) $(addsuffix /sys-proclaim.lisp,lsp cmpnew pcl clcs) install-command: rm -f $(DESTDIR)$(prefix)/bin/gcl *************** clean: *** 228,234 **** -cd binutils/bfd && $(MAKE) distclean -cd binutils/libiberty && $(MAKE) distclean ! CMPINCLUDE_FILES=$(HDIR)cmpincl1.h $(HDIR)gclincl.h $(HDIR)compbas.h $(HDIR)enum.h $(HDIR)mgmp.h $(HDIR)object.h $(HDIR)vs.h \ $(HDIR)bds.h $(HDIR)frame.h \ $(HDIR)lex.h $(HDIR)eval.h $(HDIR)funlink.h \ $(HDIR)att_ext.h $(HDIR)new_decl.h $(HDIR)compbas2.h \ --- 237,244 ---- -cd binutils/bfd && $(MAKE) distclean -cd binutils/libiberty && $(MAKE) distclean ! CMPINCLUDE_FILES=$(HDIR)cmpincl1.h $(HDIR)gclincl.h $(HDIR)compbas.h \ ! $(HDIR)enum.h $(HDIR)mgmp.h $(HDIR)object.h $(HDIR)vs.h \ $(HDIR)bds.h $(HDIR)frame.h \ $(HDIR)lex.h $(HDIR)eval.h $(HDIR)funlink.h \ $(HDIR)att_ext.h $(HDIR)new_decl.h $(HDIR)compbas2.h \ *************** kcp: *** 264,267 **** (cd go ; $(MAKE) "CFLAGS = -I../h -pg -c -g ") (cd unixport ; $(MAKE) gcp) ! .INTERMEDIATE: unixport/saved_pcl_gcl \ No newline at end of file --- 274,277 ---- (cd go ; $(MAKE) "CFLAGS = -I../h -pg -c -g ") (cd unixport ; $(MAKE) gcp) ! # .INTERMEDIATE: unixport/saved_pcl_gcl *** ../gcl-cvs/./clcs/clcs_kcl_cond.lisp Fri Jan 9 00:28:34 2004 --- ./clcs/clcs_kcl_cond.lisp Sat May 22 16:41:52 2004 *************** *** 4,37 **** (defvar *internal-error-table* (make-hash-table :test 'equal)) ! ;(defmacro find-internal-error-data (error-name error-format-string) ! ; `(gethash (list ,error-name ,error-format-string) *internal-error-table*)) ! (defmacro find-internal-error-data (error-name) ! `(gethash (list ,error-name) *internal-error-table*)) ! ! ;(defun clcs-universal-error-handler (error-name correctable function-name ! ; continue-format-string error-format-string ! ; &rest args) ! ; (if correctable ! ; (with-simple-restart ! ; (continue "~a" (apply #'format nil continue-format-string args)) ! ; (error 'internal-simple-error ! ; :function-name function-name ! ; :format-string error-format-string ! ; :format-arguments args)) ! ; (let ((e-d (find-internal-error-data error-name error-format-string))) ! ; (if e-d ! ; (let ((condition-name (car e-d))) ! ; (apply #'error condition-name ! ; :function-name function-name ! ; (let ((k-a (mapcan #'list (cdr e-d) args))) ! ; (if (simple-condition-class-p condition-name) ! ; (list* :format-string error-format-string ! ; :format-arguments args ! ; k-a) ! ; k-a)))) ! ; (error 'internal-simple-error :function-name function-name ! ; :format-string error-format-string :format-arguments args))))) (defvar *internal-error-parms* nil) --- 4,11 ---- (defvar *internal-error-table* (make-hash-table :test 'equal)) ! (defmacro find-internal-error-data (error-name error-format-string) ! `(gethash (list ,error-name ,error-format-string) *internal-error-table*)) (defvar *internal-error-parms* nil) *************** *** 45,53 **** (format t "Universal error handler called recursively ~S~%" internal-error-parms) (return-from clcs-universal-error-handler)) ! (let* ((*internal-error-parms* (list error-name correctable function-name ! continue-format-string error-format-string)) ! (e-d (find-internal-error-data error-name))) (if e-d (let ((condition-name (car e-d))) (if correctable --- 19,31 ---- (format t "Universal error handler called recursively ~S~%" internal-error-parms) (return-from clcs-universal-error-handler)) ! (let* ((*internal-error-parms* (list error-name ! correctable ! function-name ! continue-format-string ! error-format-string)) ! (e-d (or (find-internal-error-data error-name error-format-string) ! (find-internal-error-data error-name t) ))) (if e-d (let ((condition-name (car e-d))) (if correctable *************** *** 69,83 **** :format-arguments args k-a) k-a))))) ! (error 'internal-simple-error :function-name function-name ! :format-string error-format-string :format-arguments args)))) (defun set-internal-error (error-keyword error-format condition-name &rest keyword-list) (declare (ignore error-format)) ! ; (setf (find-internal-error-data error-keyword error-format) ! (setf (find-internal-error-data error-keyword) ! (cons condition-name keyword-list))) (defun initialize-internal-error-table () (declare (special *internal-error-list*)) --- 47,72 ---- :format-arguments args k-a) k-a))))) ! (if correctable ! (with-simple-restart ! (continue "~a" (apply #'format nil continue-format-string args)) ! (error 'internal-simple-error ! :function-name function-name ! :format-string error-format-string ! :format-arguments args)) ! (error 'internal-simple-error ! :function-name function-name ! :format-string error-format-string ! :format-arguments args) ! )))) (defun set-internal-error (error-keyword error-format condition-name &rest keyword-list) (declare (ignore error-format)) ! (setf (find-internal-error-data error-keyword error-format) ! (cons condition-name keyword-list)) ! (setf (find-internal-error-data error-keyword t) ! (cons condition-name keyword-list)) ) (defun initialize-internal-error-table () (declare (special *internal-error-list*)) *************** but only ~R ~:*~[were~;was~:;were~] supp *** 136,167 **** internal-simple-error) ("vfun_wrong_number_of_args" :error "Expected ~S args but received ~S args" internal-simple-control-error) ! ("end_of_stream" :error "Unexpected end of ~S." ! internal-end-of-file :stream) ! ("open_stream" :error "~S is an illegal IF-DOES-NOT-EXIST option." ! internal-simple-control-error) ! ("open_stream" :error "The file ~A already exists." ! internal-simple-file-error :pathname) ! ("open_stream" :error "Cannot append to the file ~A." ! internal-simple-file-error :pathname) ! ("open_stream" :error "~S is an illegal IF-EXISTS option." ! internal-simple-control-error) ! ("control error" :control-error "control error" ! internal-simple-control-error) ! ("close_stream" :error "Cannot close the standard output." ! internal-simple-stream-error) ; no stream here!! ! ("close_stream" :error "Cannot close the standard input." ! internal-simple-stream-error) ; no stream here!! ! ("too_long_file_name" :error "~S is a too long file name." ! internal-simple-file-error :pathname) ! ("cannot_open" :error "Cannot open the file ~A." ! internal-simple-file-error :pathname) ! ("cannot_create" :error "Cannot create the file ~A." ! internal-simple-file-error :pathname) ! ("cannot_read" :error "Cannot read the stream ~S." ! internal-simple-stream-error :stream) ! ("cannot_write" :error "Cannot write to the stream ~S." ! internal-simple-stream-error :stream) ("" :error "" internal-simple-error) )) --- 125,164 ---- internal-simple-error) ("vfun_wrong_number_of_args" :error "Expected ~S args but received ~S args" internal-simple-control-error) ! ! ("file_cannot_create" :error "Cannot create the file ~A." internal-simple-file-error :pathname) ! ("file_cannot_open" :error "Cannot open the file ~A." internal-simple-file-error :pathname) ! ("file_cannot_read" :error "Cannot read the stream ~S." internal-simple-stream-error :stream) ! ("file_cannot_write" :error "Cannot write to the stream ~S." internal-simple-stream-error :stream) ! ("file_close_stream" :error "Cannot close the standard input." internal-simple-stream-error) ; no stream here!! ! ("file_close_stream" :error "Cannot close the standard output." internal-simple-stream-error) ; no stream here!! ! ("file_control error" :control-error "control error" internal-simple-control-error) ! ("file_end_of_stream" :error "Unexpected end of ~S." internal-end-of-file :stream) ! ("file_open_stream" :error "Cannot append to the file ~A." internal-simple-file-error :pathname) ! ("file_open_stream" :error "The file ~A already exists." internal-simple-file-error :pathname) ! ("file_open_stream" :error "~S is an illegal IF-DOES-NOT-EXIST option." internal-simple-control-error) ! ("file_open_stream" :error "~S is an illegal IF-EXISTS option." internal-simple-control-error) ! ("file_too_long_file_name" :error "~S is a too long file name." internal-simple-file-error :pathname) ! ! ! ("pathname_designator" :pathname-error "Cannot parse the namestring stream ~S." internal-simple-file-error :pathname) ! ("pathname_designator" :pathname-error "Cannot parse the namestring thing ~S." internal-simple-file-error :pathname) ! ("pathname_designator" :pathname-error "Cannot coerce ~S to a namestring." internal-simple-file-error :pathname) ! ("pathname_designator" :pathname-error "Cannot coerce ~S to a pathname." internal-simple-file-error :pathname) ! ("pathname_device" :pathname-error "Invalid device in pathname ~S." internal-simple-file-error :pathname) ! ("pathname_directory" :pathname-error "Invalid directory in logical pathname ~S." internal-simple-file-error :pathname) ! ("pathname_directory" :pathname-error "Invalid directory in pathname ~S." internal-simple-file-error :pathname) ! ("pathname_host" :pathname-error "Invalid host in logical pathname ~S." internal-simple-file-error :pathname) ! ("pathname_host" :pathname-error "The pathname ~S does not match the host." internal-simple-file-error :pathname) ! ("pathname_key" :pathname-error "Invalid key for wild-pathname-p ~S." internal-simple-control-error) ! ("pathname_name" :pathname-error "Invalid name in pathname ~S." internal-simple-file-error :pathname) ! ("pathname_string" :pathname-error "Invalid 4th name component in namestring ~S." internal-simple-file-error :pathname) ! ("pathname_string" :pathname-error "Invalid blank component in namestring ~S." internal-simple-file-error :pathname) ! ("pathname_string" :pathname-error "Invalid character in logical pathname namestring ~S." internal-simple-file-error :pathname) ! ("pathname_string" :pathname-error "Invalid device or host in namestring ~S." internal-simple-file-error :pathname) ! ("pathname_type" :pathname-error "Invalid type in pathname ~S." internal-simple-file-error :pathname) ! ("pathname_version" :pathname-error "Invalid version in pathname ~S." internal-simple-file-error :pathname) ! ("" :error "" internal-simple-error) )) *** ../gcl-cvs/./clcs/makefile Wed Dec 3 16:19:03 2003 --- ./clcs/makefile Wed May 19 14:15:44 2004 *************** saved_full_gcl: ${LISP} *** 34,37 **** clean: rm -f *.o *.fn saved_full_gcl$(EXE) saved_full_gcl cmpinclude.h *.c *.h *.data ! .INTERMEDIATE: saved_clcs_gcl \ No newline at end of file --- 34,38 ---- clean: rm -f *.o *.fn saved_full_gcl$(EXE) saved_full_gcl cmpinclude.h *.c *.h *.data ! ! # .INTERMEDIATE: saved_clcs_gcl *** ../gcl-cvs/./h/att_ext.h Thu Nov 6 17:08:07 2003 --- ./h/att_ext.h Sat May 22 16:07:45 2004 *************** EXTER object sKroot; *** 394,405 **** EXTER object sKcurrent; EXTER object sKparent; EXTER object sKper; ! /* object parse_namestring(); */ ! object coerce_to_pathname(); ! /* object default_device(); */ object merge_pathnames(); object namestring(); object coerce_to_namestring(); /* prediate.c */ --- 394,423 ---- EXTER object sKcurrent; EXTER object sKparent; EXTER object sKper; ! EXTER object sKabsolute; ! EXTER object sKrelative; ! EXTER object sKlocal; ! EXTER object sKcommon; ! EXTER object sKback; ! EXTER object sKup; ! EXTER object sKwildinf; ! EXTER object sKunspecific; ! EXTER object sKsys; ! EXTER object sKhome; ! EXTER object sKpathname_error; ! object merge_pathnames(); object namestring(); object coerce_to_namestring(); + object coerce_to_pathname(); + + extern int pathname_resolve(); + extern object pathname_lookup(); + extern object translate_logical_pathname(); + extern object coerce_to_local_namestring(); + + /* object parse_namestring(); */ + /* object default_device(); */ /* prediate.c */ *************** object terpri(); *** 454,459 **** --- 472,483 ---- EXTER object sSpretty_print_format; EXTER int line_length; + /* file.d definied but not yet implemented */ + EXTER object sLAprint_linesA; + EXTER object sLAprint_miser_widthA; + EXTER object sLAprint_right_marginA; + EXTER object sLAread_evalA; + /* Read.d */ EXTER object standard_readtable; EXTER object Vreadtable; *** ../gcl-cvs/./lsp/gcl_auto_new.lsp Sun Sep 14 04:43:04 2003 --- ./lsp/gcl_auto_new.lsp Sat May 22 22:44:02 2004 *************** *** 138,143 **** --- 138,145 ---- (autoload 'y-or-n-p '|gcl_iolib|) (autoload 'yes-or-no-p '|gcl_iolib|) + (autoload 'logical-pathname-translations '|gcl_iolib|) + (autoload 'si::set-logical-pathname-translations '|gcl_iolib|) (set-dispatch-macro-character #\# #\a 'si::sharp-a-reader) (set-dispatch-macro-character #\# #\A 'si::sharp-a-reader) *************** *** 182,187 **** --- 184,191 ---- (autoload-macro 'with-open-file '|gcl_iolib|) (autoload-macro 'with-open-stream '|gcl_iolib|) (autoload-macro 'with-output-to-string '|gcl_iolib|) + (autoload-macro 'with-standard-io-syntax '|gcl_iolib|) + ) ;;end autoloads of normally loaded files.j (if (find-package "COMPILER") (push :compiler *features*)) #+compiler *** ../gcl-cvs/./lsp/gcl_autoload.lsp Sun Mar 21 17:07:10 2004 --- ./lsp/gcl_autoload.lsp Sat May 22 22:44:02 2004 *************** Good luck! The GCL Development Team" *** 417,422 **** --- 417,423 ---- (setf (get 'with-input-from-string 'si:pretty-print-format) 1) (setf (get 'with-open-file 'si:pretty-print-format) 1) (setf (get 'with-open-stream 'si:pretty-print-format) 1) + (setf (get 'with-standard-io-syntax 'si:pretty-print-format) 1) (setf (get 'with-output-to-string 'si:pretty-print-format) 1) *************** Good luck! The GCL Development Team" *** 424,427 **** (defvar *lib-directory* (namestring (probe-file "../"))) ! (import '(*lib-directory* *load-path* *system-directory*) 'si::user) \ No newline at end of file --- 425,428 ---- (defvar *lib-directory* (namestring (probe-file "../"))) ! (import '(*lib-directory* *load-path* *system-directory*) 'si::user) *** ../gcl-cvs/./lsp/gcl_export.lsp Fri Oct 10 04:54:45 2003 --- ./lsp/gcl_export.lsp Sat May 22 22:44:02 2004 *************** with-output-to-string *** 261,266 **** --- 261,268 ---- write-to-string y-or-n-p yes-or-no-p + with-standard-io-syntax + logical-pathname-translations proclaim proclamation *** ../gcl-cvs/./lsp/gcl_iolib.lsp Sun Sep 14 04:43:05 2003 --- ./lsp/gcl_iolib.lsp Sat May 22 22:44:02 2004 *************** *** 24,37 **** (in-package 'lisp) - (export '(with-open-stream with-input-from-string with-output-to-string)) (export '(read-from-string)) (export '(write-to-string prin1-to-string princ-to-string)) (export 'with-open-file) (export '(y-or-n-p yes-or-no-p)) (export 'dribble) ! (in-package 'system) --- 24,37 ---- (in-package 'lisp) (export '(with-open-stream with-input-from-string with-output-to-string)) (export '(read-from-string)) (export '(write-to-string prin1-to-string princ-to-string)) (export 'with-open-file) (export '(y-or-n-p yes-or-no-p)) (export 'dribble) ! (export 'with-standard-io-syntax) ! (export 'logical-pathname-translations) (in-package 'system) *************** *** 192,195 **** --- 192,286 ---- (format t "~&Starts dribbling to ~A (~d/~d/~d, ~d:~d:~d)." namestring year month day hour min sec)))))) + ;;; copied from ECL under LGPL by Michael Koehne + ;;; with-standard-io-syntax + + (defmacro with-standard-io-syntax (&body body) + "Syntax: ({forms}*) + The forms of the body are executed in a print environment that corresponds to + the one defined in the ANSI standard. *print-base* is 10, *print-array* is t, + *package* is \"CL-USER\", etc." + `(let*((*package* (find-package :cl-user)) + (*print-array* t) + (*print-base* 10) + (*print-case* :upcase) + (*print-circle* nil) + (*print-escape* t) + (*print-gensym* t) + (*print-length* nil) + (*print-level* nil) + (*print-lines* nil) + (*print-miser-width* nil) + (*print-pretty* nil) + (*print-radix* nil) + (*print-readably* t) + (*print-right-margin* nil) + (*read-base* 10) + (*read-default-float-format* 'single-float) + (*read-eval* t) + (*read-suppress* nil) + (*readtable* (copy-readtable (si::standard-readtable)))) + ,@body)) + + ;;; new logical pathname translation + ; + ;;; examples : + ; + ;; (setf (logical-pathname-translations "source") + ;; '(("SRC;**;*.*.*" "/home/kraehe/lisp/**/*.*") + ;; ("LIB;**;*.*.*" "/usr/local/lib/**/*.*") + ;; ("BIN;*.*.*" "/usr/local/bin/*.*"))) + ; + ;; (setf (logical-pathname-translations "var") + ;; '(("**;*.*.*" "/var/**/*.*"))) + ; + ;; This is tricky ! Translate a logical pathname into something unix like. + ; + ;; (setf (logical-pathname-translations "home") + ;; '(("*;**;*.*.*" "~*/**/*.*"))) + ; + ;; Try: (TRUENAME "home:games;zork.exec") + + (setq si:*pathname-logical* nil) + (setq si:*pathname-virtual* nil) + (setq si:*pathname-devices* nil) + + #-WINDOWS (setq si:*pathname-resolve* :host) + #+WINDOWS (setq si:*pathname-resolve* '(:host :device)) + + (defun logical-pathname-translations (key) + (si:pathname-lookup key si:*pathname-logical*)) + + (defun set-logical-pathname-translations (key value) + (let (k v) + (setq k (if (stringp key) (string-downcase key) key)) + (setq si:*pathname-logical* + (si:set-pathname-lookup k si:*pathname-logical* t)) + (setq v (if (listp value) + (mapcar #'(lambda (s) (list + (if (stringp (car s)) (parse-namestring (car s) key) (car s)) + (if (stringp (cadr s)) (parse-namestring (cadr s)) (cadr s)))) + value) value)) + (setq si:*pathname-logical* + (si:set-pathname-lookup key si:*pathname-logical* v)) + (si:pathname-lookup key si:*pathname-logical*))) + + (defsetf logical-pathname-translations si::set-logical-pathname-translations) + + (defun virtual-pathname-translations (key) + (si:pathname-lookup key si:*pathname-virtual*)) + + (defun set-virtual-pathname-translations (key value) + (setq si:*pathname-virtual* + (si:set-pathname-lookup key si:*pathname-virtual* value))) + + (defsetf virtual-pathname-translations set-virtual-pathname-translations) + + (defun device-pathname-translations (key) + (si:pathname-lookup key si:*pathname-devices*)) + + (defun set-device-pathname-translations (key value) + (setq si:*pathname-devices* + (si:set-pathname-lookup key si:*pathname-devices* value))) + (defsetf device-pathname-translations set-device-pathname-translations) *** ../gcl-cvs/./o/fasdump.c Thu Feb 12 06:24:42 2004 --- ./o/fasdump.c Wed May 19 14:15:44 2004 *************** read_fasl_vector(object in) *** 1499,1505 **** d->pn.pn_directory, d->pn.pn_name, make_simple_string("data"), ! d->pn.pn_version); d = coerce_to_namestring(d); in = open_stream(d,smm_input,Cnil,Cnil); if (in == Cnil) --- 1499,1506 ---- d->pn.pn_directory, d->pn.pn_name, make_simple_string("data"), ! d->pn.pn_version, ! Cnil); d = coerce_to_namestring(d); in = open_stream(d,smm_input,Cnil,Cnil); if (in == Cnil) *** ../gcl-cvs/./o/file.d Fri May 7 23:49:34 2004 --- ./o/file.d Sat May 22 12:53:46 2004 *************** object if_exists, if_does_not_exist; *** 423,429 **** /* goto AGAIN; */ /* /\* should not get here *\/ */ /* else { unlink(tmp);}} */ ! /* }} */ if (if_does_not_exist == sKerror) cannot_open(fn); else if (if_does_not_exist == sKcreate) { --- 423,429 ---- /* goto AGAIN; */ /* /\* should not get here *\/ */ /* else { unlink(tmp);}} */ ! /* } */ if (if_does_not_exist == sKerror) cannot_open(fn); else if (if_does_not_exist == sKcreate) { *************** LFD(Lstream_element_type)() *** 1688,1695 **** &aux strm) enum smmode smm=0; @ check_type_or_pathname_string_symbol_stream(&filename); ! filename = coerce_to_namestring(filename); if (direction == sKinput) { smm = smm_input; if (!idnesp) --- 1688,1697 ---- &aux strm) enum smmode smm=0; @ + vs_mark; check_type_or_pathname_string_symbol_stream(&filename); ! filename = coerce_to_local_namestring(filename); ! vs_push(filename); if (direction == sKinput) { smm = smm_input; if (!idnesp) *************** LFD(Lstream_element_type)() *** 1724,1729 **** --- 1726,1732 ---- FEerror("~S is an illegal DIRECTION for OPEN.", 1, direction); strm = open_stream(filename, smm, if_exists, if_does_not_exist); + vs_reset; @(return strm) @) *************** DEFVAR("*BINARY-MODULES*",sSAbinary_modu *** 1786,1792 **** defaults = coerce_to_pathname(defaults); pathname = merge_pathnames(pathname, defaults, sKnewest); pntype = pathname->pn.pn_type; ! filename = coerce_to_namestring(pathname); if (user_match(filename->st.st_self,filename->st.st_fillp)) @(return Cnil) old_bds_top=bds_top; --- 1789,1795 ---- defaults = coerce_to_pathname(defaults); pathname = merge_pathnames(pathname, defaults, sKnewest); pntype = pathname->pn.pn_type; ! filename = coerce_to_local_namestring(pathname); if (user_match(filename->st.st_self,filename->st.st_fillp)) @(return Cnil) old_bds_top=bds_top; *************** DEFVAR("*BINARY-MODULES*",sSAbinary_modu *** 1799,1805 **** #endif pathname->pn.pn_type = FASL_string; ! fasl_filename = coerce_to_namestring(pathname); } if (pntype == Cnil || pntype == sKwild || (type_of(pntype) == t_string && --- 1802,1808 ---- #endif pathname->pn.pn_type = FASL_string; ! fasl_filename = coerce_to_local_namestring(pathname); } if (pntype == Cnil || pntype == sKwild || (type_of(pntype) == t_string && *************** DEFVAR("*BINARY-MODULES*",sSAbinary_modu *** 1810,1816 **** #endif pathname->pn.pn_type = LSP_string; ! lsp_filename = coerce_to_namestring(pathname); } if (fasl_filename != Cnil && file_exists(fasl_filename)) { if (verbose != Cnil) { --- 1813,1819 ---- #endif pathname->pn.pn_type = LSP_string; ! lsp_filename = coerce_to_local_namestring(pathname); } if (fasl_filename != Cnil && file_exists(fasl_filename)) { if (verbose != Cnil) { *** ../gcl-cvs/./o/makefile Sat Mar 20 03:05:44 2004 --- ./o/makefile Wed May 19 14:15:44 2004 *************** decls1: $(INI_FILES) *** 120,127 **** $(DECL): $(HDIR)/make-decl.h $(INI_FILES) echo '#include "make-decl.h"' > foo.c cat ${INI_FILES} >> foo.c ! ${CC} -E -I${HDIR} foo.c | sed -n -e '/#/d' -e '/DO_/d' -e '/[a-zA-Z;]/p' > $@ ! rm foo.c grab_defs: grab_defs.c ${CC} $(OFLAGS) -o grab_defs grab_defs.c --- 120,128 ---- $(DECL): $(HDIR)/make-decl.h $(INI_FILES) echo '#include "make-decl.h"' > foo.c cat ${INI_FILES} >> foo.c ! ${CC} -E -I${HDIR} foo.c | sed -n -e '/#/d' -e '/DO_/d' -e '/[a-zA-Z;]/p' > tmpini ! ../xbin/move-if-changed mv tmpini $@ ! -rm foo.c tmpini grab_defs: grab_defs.c ${CC} $(OFLAGS) -o grab_defs grab_defs.c *** ../gcl-cvs/./o/mingfile.c Sat Feb 15 01:38:28 2003 --- ./o/mingfile.c Wed May 19 14:15:44 2004 *************** void Ldirectory ( void ) *** 8,20 **** --- 8,31 ---- char filename[MAXPATHLEN]; object *top=vs_top; object path; + int wildversion=0; + check_arg(1); + check_type_or_pathname_string_symbol_stream(&vs_base[0]); path = vs_base[0] = truename(coerce_to_pathname(vs_base[0])); + if ((pathname_resolve(sKversion) && + (vs_base[0]->pn.pn_version == sKwild)) { + wildversion=1; + vs_base[0]->pn.pn_version = Cnil; + } if (vs_base[0]->pn.pn_name==Cnil && vs_base[0]->pn.pn_type==Cnil) { coerce_to_filename(vs_base[0], filename); strcat(filename, "*.*"); + if (wildversion) + vs_base[0]->pn.pn_version = sKwild; + wildversion=0; } else if (vs_base[0]->pn.pn_name==Cnil) { vs_base[0]->pn.pn_name = sKwild; coerce_to_filename(vs_base[0], filename); *************** void Ldirectory ( void ) *** 22,29 **** --- 33,48 ---- } else if (vs_base[0]->pn.pn_type==Cnil) { coerce_to_filename(vs_base[0], filename); strcat(filename, ".*"); + if (wildversion) + vs_base[0]->pn.pn_version = sKwild; + wildversion=0; } else coerce_to_filename(vs_base[0], filename); + if (wildversion) { + strcat(filename, "*"); + vs_base[0]->pn.pn_version = sKwild; + wildversion=0; + } { WIN32_FIND_DATA data; HANDLE dirHandle = FindFirstFile(filename,&data); *************** void Ldirectory ( void ) *** 39,45 **** path->pn.pn_directory, new->pn.pn_name, new->pn.pn_type, ! new->pn.pn_version)); } } while (FindNextFile(dirHandle,&data)); FindClose(dirHandle); --- 58,65 ---- path->pn.pn_directory, new->pn.pn_name, new->pn.pn_type, ! new->pn.pn_version, ! Cnil)); } } while (FindNextFile(dirHandle,&data)); FindClose(dirHandle); *** ../gcl-cvs/./o/pathname.d Fri Apr 23 21:36:34 2004 --- ./o/pathname.d Sat May 22 22:39:03 2004 *************** any later version. *** 10,19 **** GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ! FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. ! You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ --- 10,19 ---- GCL is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or ! FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License for more details. ! You should have received a copy of the GNU Library General Public License along with GCL; see the file COPYING. If not, write to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */ *************** Foundation, 675 Mass Ave, Cambridge, MA *** 25,427 **** This file contains those functions that interpret namestrings. */ #include "include.h" object ! make_pathname(host, device, directory, name, type, version) ! object host, device, directory, name, type, version; { ! object x; x = alloc_object(t_pathname); x->pn.pn_host = host; x->pn.pn_device = device; x->pn.pn_directory = directory; x->pn.pn_name = name; x->pn.pn_type = type; x->pn.pn_version = version; return(x); } ! static void ! make_one(s, end) char *s; ! int end; ! { int i; ! #ifdef UNIX ! for (i = 0; i < end; i++) ! token->st.st_self[i] = s[i]; ! #endif ! #ifdef AOSVS ! #endif ! token->st.st_fillp = end; ! vs_push(copy_simple_string(token)); } ! /* The function below does not attempt to handle DOS pathnames ! which use backslashes as directory separators. It needs ! TLC from someone who feels pedantic. MJT */ - /* !!!!! Bug Fix. NLG */ object ! parse_namestring(s, start, end, ep) ! object s; int start, end, *ep; { ! int i, j, k, founddosdev = FALSE, oldstart=start, oldend=end, justdevice = FALSE; ! int d; ! object *vsp; ! object x; ! vs_mark; ! ! #ifndef IS_DIR_SEPARATOR ! #define IS_DIR_SEPARATOR(x) (x == '/') ! #endif ! ! *ep=oldend; ! vsp = vs_top + 1; ! for (;--end >= start && isspace((int)s->st.st_self[end]);); ! ! /* Check for a DOS path and process later */ ! if ( ( (start+1) <= end) && (s->st.st_self[start+1] == ':' )) { ! start+=2; ! founddosdev = TRUE; ! } ! if ( start > end ) { ! make_one(&s->st.st_self[0], 0); ! justdevice = TRUE; } else { ! for (i = j = start; i <= end; ) { ! #ifdef UNIX ! if (IS_DIR_SEPARATOR(s->st.st_self[i])) { ! #endif ! if (j == start && i == start) { ! i++; ! vs_push(sKroot); ! j = i; ! continue; ! } ! #ifdef UNIX ! if (i-j == 1 && s->st.st_self[j] == '.') { ! vs_push(sKcurrent); ! } else if (i-j==2 && s->st.st_self[j]=='.' && s->st.st_self[j+1]=='.') { ! vs_push(sKparent); ! } else { ! make_one(&s->st.st_self[j], i-j); ! } ! #endif ! i++; ! j = i; ! } else { ! i++; } } ! *ep = i; ! vs_push(Cnil); ! while (vs_top > vsp) ! stack_cons(); ! if (i == j) { ! /* no file and no type */ ! vs_push(Cnil); ! vs_push(Cnil); ! goto L; ! } ! for (k = j, d = -1; k < i; k++) ! if (s->st.st_self[k] == '.') ! d = k; ! if (d == -1) { ! /* no file type */ ! #ifdef UNIX ! if (i-j == 1 && s->st.st_self[j] == '*') ! #endif ! vs_push(sKwild); ! else ! make_one(&s->st.st_self[j], i-j); ! ! vs_push(Cnil); ! } else if (d == j) { ! /* no file name */ ! vs_push(Cnil); ! #ifdef UNIX ! if (i-d-1 == 1 && s->st.st_self[d+1] == '*') ! #endif ! vs_push(sKwild); ! else ! make_one(&s->st.st_self[d+1], i-d-1); } else { ! /* file name and file type */ ! #ifdef UNIX ! if (d-j == 1 && s->st.st_self[j] == '*') ! #endif ! vs_push(sKwild); ! else { ! make_one(&s->st.st_self[j], d-j); ! } ! #ifdef UNIX ! if (i-d-1 == 1 && s->st.st_self[d+1] == '*') ! #endif ! vs_push(sKwild); ! else ! make_one(&s->st.st_self[d+1], i-d-1); } - } - L: - /* Process DOS device name found earlier, build a string in a list and push it */ - if ( founddosdev ) { - /* Drive letter */ - token->st.st_self[0] = s->st.st_self[oldstart]; - /* Colon */ - token->st.st_self[1] = s->st.st_self[oldstart+1]; - /* Fill pointer */ - token->st.st_fillp = 2; - /* Push */ - vs_push(make_cons(copy_simple_string(token),Cnil)); - } else { - /* No device name */ - vs_push(Cnil); } ! if ( justdevice ) { ! x = make_pathname ( Cnil, vs_top[-1], Cnil, Cnil, Cnil, Cnil ); ! } else { ! x = make_pathname ( Cnil, vs_top[-1], vs_top[-4], vs_top[-3], vs_top[-2], Cnil ); ! } ! vs_reset; return(x); } object coerce_to_pathname(x) object x; { ! object y; int e; ! L: ! switch (type_of(x)) { ! case t_symbol: ! case t_string: ! /* !!!!! Bug Fix. NLG */ ! y = parse_namestring(x, 0, x->st.st_fillp, &e); ! if (y == OBJNULL || e != x->st.st_fillp) ! goto CANNOT_COERCE; ! return(y); ! ! case t_pathname: return(x); ! case t_stream: switch (x->sm.sm_mode) { ! case smm_input: ! case smm_output: ! case smm_probe: ! case smm_io: x = x->sm.sm_object1; ! /* ! The file was stored in sm.sm_object1. ! See open. ! */ ! goto L; ! case smm_synonym: x = symbol_value(x->sm.sm_object0); ! goto L; ! default: ! goto CANNOT_COERCE; } ! default: ! CANNOT_COERCE: ! FEerror("~S cannot be coerced to a pathname.", 1, x); ! return(Cnil); } } static object default_device(host) object host; { return(Cnil); - /* not implemented yet */ } object merge_pathnames(path, defaults, default_version) object path, defaults, default_version; { ! object host, device, directory, name, type, version; ! if (path->pn.pn_host == Cnil) ! host = defaults->pn.pn_host; ! else host = path->pn.pn_host; - if (path->pn.pn_device == Cnil) - if (path->pn.pn_host == Cnil) - device = defaults->pn.pn_device; - else if (path->pn.pn_host == defaults->pn.pn_host) - device = defaults->pn.pn_device; - else - device = default_device(path->pn.pn_host); else ! device = path->pn.pn_device; ! if (defaults->pn.pn_directory==Cnil || ! (type_of(path->pn.pn_directory)==t_cons ! && path->pn.pn_directory->c.c_car==sKroot)) ! directory=path->pn.pn_directory; ! else ! directory=path->pn.pn_directory==Cnil ? ! defaults->pn.pn_directory : ! append(defaults->pn.pn_directory,path->pn.pn_directory); ! if (path->pn.pn_name == Cnil) name = defaults->pn.pn_name; ! else name = path->pn.pn_name; if (path->pn.pn_type == Cnil) type = defaults->pn.pn_type; else type = path->pn.pn_type; ! version = Cnil; ! /* ! In this implimentation, version is not counted ! */ ! return(make_pathname(host,device,directory,name,type,version)); } /* ! Namestring(x) converts a pathname to a namestring. ! */ object namestring(x) object x; { - - int i, j; object l, y; ! i = 0; ! l = x->pn.pn_device; ! if (endp(l)) { ! goto D; ! } ! y = l->c.c_car; ! y = coerce_to_string(y); ! for (j = 0; j < y->st.st_fillp; j++) { ! token->st.st_self[i++] = y->st.st_self[j]; ! } ! ! D: l = x->pn.pn_directory; ! if (endp(l)) ! goto L; ! y = l->c.c_car; ! if (y == sKroot) { ! #ifdef UNIX ! token->st.st_self[i++] = '/'; ! #endif ! l = l->c.c_cdr; ! } ! for (; !endp(l); l = l->c.c_cdr) { ! y = l->c.c_car; ! #ifdef UNIX ! if (y == sKcurrent) { ! token->st.st_self[i++] = '.'; ! token->st.st_self[i++] = '/'; ! continue; ! } else if (y == sKparent) { ! token->st.st_self[i++] = '.'; ! token->st.st_self[i++] = '.'; ! token->st.st_self[i++] = '/'; ! continue; } ! #endif ! y = coerce_to_string(y); ! for (j = 0; j < y->st.st_fillp; j++) ! token->st.st_self[i++] ! = y->st.st_self[j]; ! #ifdef UNIX ! token->st.st_self[i++] = '/'; ! #endif ! #ifdef AOSVS ! #endif } ! L: y = x->pn.pn_name; ! if (y == Cnil) ! goto M; ! if (y == sKwild) { ! #ifdef UNIX ! token->st.st_self[i++] = '*'; ! #endif ! #ifdef AOSVS - #endif - goto M; - } - if (type_of(y) != t_string) - FEerror("~S is an illegal pathname name.", 1, y); - for (j = 0; j < y->st.st_fillp; j++) - token->st.st_self[i++] = y->st.st_self[j]; - M: y = x->pn.pn_type; ! if (y == Cnil) ! goto N; ! if (y == sKwild) { ! token->st.st_self[i++] = '.'; ! #ifdef UNIX ! token->st.st_self[i++] = '*'; ! #endif ! #ifdef AOSVS ! ! #endif ! goto N; } ! if (type_of(y) != t_string) ! FEerror("~S is an illegal pathname name.", 1, y); ! token->st.st_self[i++] = '.'; ! for (j = 0; j < y->st.st_fillp; j++) ! token->st.st_self[i++] = y->st.st_self[j]; ! N: ! token->st.st_fillp = i; #ifdef FIX_FILENAME ! {char buf[MAXPATHLEN]; ! if (i > MAXPATHLEN-1) i =MAXPATHLEN-1; ! bcopy(token->st.st_self,buf,i); ! buf[i]=0; ! FIX_FILENAME(x,buf); ! return (make_simple_string(buf)); ! } #endif ! return(copy_simple_string(token)); } object ! coerce_to_namestring(x) ! object x; { ! L: switch (type_of(x)) { case t_symbol: ! {BEGIN_NO_INTERRUPT; ! vs_push(alloc_simple_string(x->s.s_fillp)); ! /* By Nick Gall */ ! vs_head->st.st_self = alloc_relblock(x->s.s_fillp); ! { ! int i; ! for (i = 0; i < x->s.s_fillp; i++) ! vs_head->st.st_self[i] = x->s.s_self[i]; ! } ! END_NO_INTERRUPT;} ! return(vs_pop); case t_string: return(x); --- 25,999 ---- This file contains those functions that interpret namestrings. */ + /* hacked by Michael Koehne (c) GNU LGPL + * kraehe (at) copyleft.de + * Sun Apr 25 07:43:08 CEST 2004 + * + * beware of new bugs^h^h^h^h features ! + * + * feed them to http://www.copyleft.de/gecko/ + * or enjoy http://www.copyleft.de/lisp/ + * for other Lisp code + * + * many thanks to pfdietz, piso and many other people in #lisp. This hack + * would never been possible without the regression test and their help. + * ------------------------------------------------------------------------- */ + #include "include.h" + #include + #include + + object sSApathname_resolveA, sSApathname_logicalA, + sSApathname_virtualA, sSApathname_devicesA, + sSApathname_error1pA, sSApathname_error1lA, + sSApathname_errorstA, sSApathname_noerrorA; + DEFVAR("*PATHNAME-RESOLVE*",sSApathname_resolveA,SI,Cnil, + "list of enableing keyword for pathname resolver"); + DEFVAR("*PATHNAME-LOGICAL*",sSApathname_logicalA,SI,Cnil, + "pathname logical hostname translation assoc"); + DEFVAR("*PATHNAME-VIRTUAL*",sSApathname_virtualA,SI,Cnil, + "pathname virtual hostname translation assoc"); + DEFVAR("*PATHNAME-DEVICES*",sSApathname_devicesA,SI,Cnil, + "pathname device translation assoc"); + DEFVAR("*PATHNAME-ERROR1P*",sSApathname_error1pA,SI,Cnil, + "last pathname throwing an error"); + DEFVAR("*PATHNAME-ERROR1L*",sSApathname_error1lA,SI,Cnil, + "last pathname throwing an error"); + DEFVAR("*PATHNAME-ERRORST*",sSApathname_errorstA,SI,Cnil, + "errorstring when throwing an error"); + DEFVAR("*PATHNAME-NOERROR*",sSApathname_noerrorA,SI,Cnil, + "disable throwing pathname errors"); + + static object expand_pathname(o) + object o; + { + object n,p; + if (type_of(o) == t_pathname) { + vs_mark; + n=make_cons(Cnil,Cnil); p=n; + vs_push(n); + if (o->pn.pn_device != Cnil) { + p->c.c_cdr=make_cons(sKdevice,Cnil); p=p->c.c_cdr; + p->c.c_cdr=make_cons(o->pn.pn_device,Cnil); p=p->c.c_cdr; + } + if (o->pn.pn_host != Cnil) { + p->c.c_cdr=make_cons(sKhost,Cnil); p=p->c.c_cdr; + p->c.c_cdr=make_cons(o->pn.pn_host,Cnil); p=p->c.c_cdr; + } + if (o->pn.pn_directory != Cnil) { + p->c.c_cdr=make_cons(sKdirectory,Cnil); p=p->c.c_cdr; + p->c.c_cdr=make_cons(o->pn.pn_directory,Cnil); p=p->c.c_cdr; + } + if (o->pn.pn_name != Cnil) { + p->c.c_cdr=make_cons(sKname,Cnil); p=p->c.c_cdr; + p->c.c_cdr=make_cons(o->pn.pn_name,Cnil); p=p->c.c_cdr; + } + if (o->pn.pn_type != Cnil) { + p->c.c_cdr=make_cons(sKtype,Cnil); p=p->c.c_cdr; + p->c.c_cdr=make_cons(o->pn.pn_type,Cnil); p=p->c.c_cdr; + } + if (o->pn.pn_version != Cnil) { + p->c.c_cdr=make_cons(sKversion,Cnil); p=p->c.c_cdr; + p->c.c_cdr=make_cons(o->pn.pn_version,Cnil); p=p->c.c_cdr; + } + n=n->c.c_cdr; + vs_reset; + } else { + n=o; + } + return n; + } + + object + file_error(str,obj) + char *str; + object obj; + { + sSApathname_errorstA->s.s_dbind=make_simple_string(str); + sSApathname_error1pA->s.s_dbind=obj; + sSApathname_error1lA->s.s_dbind=expand_pathname(obj); + if (symbol_value(sSApathname_noerrorA) == Ct) + return Cnil; + Icall_error_handler(sKpathname_error, + sSApathname_errorstA->s.s_dbind,1, + sSApathname_error1lA->s.s_dbind); + return Cnil; + } + + /* + * pathname_resolve + * lookup the SI:*PATHNAME-RESOLVE* variable, if I need to + * show :host, :device or :version. + * + * examples: + * (setq SI:*PATHNAME-RESOLVE* :device) ;;; show device on DOS + * (setq SI:*PATHNAME-RESOLVE* '(:host :device)) ;;; show host and version + * + * this variable is also used by Ldirectory from unixfsys and mingfile. + * + * pathname_resolve + * query SI:*PATHNAME-RESOLVE* and return 0 or 1 + */ + + int + pathname_resolve(key) + object key; + { + object o=symbol_value(sSApathname_resolveA); + if (o == key) return 1; + while (type_of(o) == t_cons) { + if (o->c.c_car==key) return 1; + o=o->c.c_cdr; + } + return 0; + } + + /* + * get_pathname_lookup + * a poor mens assoc - easier to call than assoc from inline C + * + * returns (ASSOC item a_list :TEST 'STRING-EQUAL) + */ + static object + get_pathname_lookup(item,a_list) + object item,a_list; + { + if ((item == Cnil) || (a_list == Cnil) || + ((type_of(item)!=t_string) && (type_of(item)!=t_symbol))) + return Cnil; + + if (type_of(a_list) == t_symbol) + a_list = symbol_value(a_list); + + while ((a_list != Cnil) && + (type_of(a_list) == t_cons) && + !endp(a_list)) + if ((a_list->c.c_car != Cnil) && + (type_of(a_list->c.c_car) == t_cons) && + ((type_of(a_list->c.c_car->c.c_car) == t_symbol) || + (type_of(a_list->c.c_car->c.c_car) == t_string)) && + (string_equal(item, a_list->c.c_car->c.c_car) == TRUE)) + return(a_list->c.c_car); + else + a_list = a_list->c.c_cdr; + + return Cnil; + } object ! pathname_lookup(item,a_list) ! object item,a_list; { ! object r; ! r=get_pathname_lookup(item,a_list); ! if (type_of(r)==t_cons) return r->c.c_cdr; ! return Cnil; ! } ! ! @(defun pathname_lookup (item a_list) ! @ ! @(return `get_pathname_lookup(item,a_list)`) ! @) ! ! /* ! * set_pathname_lookup ! * defsetf hook for poor mans assoc ! * ! * returns new a_list ! */ + object + set_pathname_lookup(item,a_list,value) + object item,a_list,value; + { + object l; + + if ((type_of(item)!=t_string) && (type_of(item)!=t_symbol)) + return Cnil; + + l=get_pathname_lookup(item,a_list); + if ((l!=Cnil) && (type_of(l)==t_cons)) { + l->c.c_cdr = value; + return(a_list); + } + + vs_mark; + vs_push(make_cons(item,value)); + l=make_cons(vs_head,a_list); + vs_reset; + return l; + } + + @(defun set_pathname_lookup (item a_list value) + @ + @(return `set_pathname_lookup(item,a_list,value)`) + @) + + /* + * pathname_case_word + * checks if a word is a string convert if :case :common. + * + * vs_push and return symbol or new string + */ + + object + pathname_case_word(word, casekey) + object word, casekey; + { + object x=word; + int seen_lower=0; + int seen_upper=0; + int i; + + if ((type_of(word) == t_string) || (type_of(word) == t_symbol)) { + if (casekey == sKcommon) { + for (i=0; ist.st_fillp; i++) { + if (isupper(word->st.st_self[i])) seen_upper=1; + if (islower(word->st.st_self[i])) seen_lower=1; + } + if (seen_lower != seen_upper) { + x=copy_simple_string(word); + for (i=0; ist.st_fillp; i++) { + if (isupper(word->st.st_self[i])) + x->st.st_self[i]=tolower(x->st.st_self[i]); + else + if (islower(word->st.st_self[i])) + x->st.st_self[i]=toupper(x->st.st_self[i]); + } + } + } else + if (casekey == sKdowncase) { + x=copy_simple_string(word); + for (i=0; ist.st_fillp; i++) + if (isupper(word->st.st_self[i])) + x->st.st_self[i]=tolower(x->st.st_self[i]); + } + } + + vs_push(x); /* make-pathname will vs_reset later */ + return(x); + } + + /* + * make_pathname + * creates a new object of t_pathname. + * checks case and constrains directory to t_cons + * + * vs_mark; vs_push lot of junk; vs_reset; return new pathname + */ + + object constrain_pathname(x) + object x; + { + if ((type_of(x->pn.pn_directory) == t_string) || + (x->pn.pn_directory == sKwild) || + (x->pn.pn_directory == sKwildinf)) { + vs_push(make_cons(x->pn.pn_directory,Cnil)); + x->pn.pn_directory=make_cons(sKabsolute,vs_head); + vs_popp; + } else + if ((x->pn.pn_directory == sKroot) || + (x->pn.pn_directory == sKhome) || + (x->pn.pn_directory == sKabsolute) || + (x->pn.pn_directory == sKcurrent) || + (x->pn.pn_directory == sKrelative) || + (x->pn.pn_directory == sKup) || + (x->pn.pn_directory == sKback) || + (x->pn.pn_directory == sKparent)) { + vs_push(make_cons(x->pn.pn_directory,Cnil)); + x->pn.pn_directory=vs_head; + vs_popp; + } else + if ((x->pn.pn_directory != Cnil) && + (type_of(x->pn.pn_directory) != t_cons)) { + return(file_error("Invalid directory in pathname ~S.",x)); + } + return x; + } + + object + make_pathname(host, device, directory, name, type, version, casekey) + object host, device, directory, name, type, version, casekey; + { + object x,y,z; + int common_case=(casekey == sKcommon); + + vs_mark; x = alloc_object(t_pathname); + vs_push(x); + x->pn.pn_host = host; x->pn.pn_device = device; x->pn.pn_directory = directory; x->pn.pn_name = name; x->pn.pn_type = type; x->pn.pn_version = version; + + x=constrain_pathname(x); + + if (common_case) { + x->pn.pn_host = pathname_case_word(host,sKcommon); + x->pn.pn_device = pathname_case_word(device,sKcommon); + + if (type_of(x->pn.pn_directory) == t_cons) { + z = x->pn.pn_directory; + vs_push(z); + y = make_cons( pathname_case_word(z->c.c_car,sKcommon), Cnil); + x->pn.pn_directory=y; + for (z = z->c.c_cdr; type_of(z) == t_cons; z = z->c.c_cdr) { + y->c.c_cdr = make_cons( + pathname_case_word(z->c.c_car,sKcommon), Cnil); + y = y->c.c_cdr; + } + y->c.c_cdr = pathname_case_word(z,sKcommon); + vs_popp; + } + + x->pn.pn_name = pathname_case_word(name,sKcommon); + x->pn.pn_type = pathname_case_word(type,sKcommon); + x->pn.pn_version = pathname_case_word(version,sKcommon); + } + + vs_reset; return(x); } ! /* ! * parse_namestring_check ! * looks ahead for a character ! * ! * return string length or -1 if not found ! */ ! ! int ! parse_namestring_check(s,start,end,c,restrict) char *s; ! int start, end; ! char c; ! int restrict; ! { int i; + for (i=start; (s[i]!=c) && (ist.st_dim);) + token->st.st_self[i++] = s[j++]; + token->st.st_fillp = i; + x=copy_simple_string(token); + vs_push(x); /* parse_namestring will vs_reset later */ + if (j != end) + return(file_error("Token overrun at ~S.", x)); + return(x); + } + /* + * parse_namestring_key + * checks the namestring object for known keys + * realm and assume tell what to do on the object + * + * might silently drop the old object - return old string or new keyword + */ ! object ! parse_namestring_key(o,realm,assume) ! object o,realm; ! int assume; ! { ! object x=o; ! if (type_of(o) == t_string) { ! if (realm == sKhost) { ! if ((o->st.st_fillp == 3) && !strncasecmp(o->st.st_self,"sys",2)) ! x=sKsys; ! } else ! if (realm == sKdirectory) { ! if ((o->st.st_fillp == 2) && !strncmp(o->st.st_self,"**",2)) ! x=sKwildinf; ! if (assume != ';') { ! if ((o->st.st_fillp == 2) && !strncmp(o->st.st_self,"..",2)) ! x=sKup; ! else ! if ((o->st.st_fillp == 1) && (o->st.st_self[0]=='.')) ! x=sKcurrent; ! else ! if ((o->st.st_fillp == 1) && (o->st.st_self[0]=='~')) ! x=sKhome; ! } ! } else ! if (realm == sKversion) { ! if ((o->st.st_fillp == 6) && !strncasecmp(o->st.st_self,"newest",6)) ! x=sKnewest; ! } ! if ((o->st.st_fillp == 1) && (o->st.st_self[0]=='*')) ! x= ((realm == sKhost) || (realm == sKdevice)) ? ! sKunspecific : sKwild; ! } ! return(x); } ! /* ! * parse_namestring ! * parses a namestring - trying varios forms like : ! * ! * SYS:HOME;KRAEHE;LISP;FOO.LISP :sys is host CLHS like ! * c:/home/kraehe/lisp/foo.lisp c is a device DOS like ! * source:/home/kraehe/lisp/foo.lisp source is a host Unix like ! * ! * vs_mark; vs_push some junk; vs_reset and return new string object ! */ object ! parse_namestring(s, defhost, defaults, start, end, ep) ! object s, defhost, defaults; int start, end, *ep; { ! int i, j; ! object host=Cnil, device=Cnil, directory=Cnil, ! name=Cnil, type=Cnil, version=Cnil; ! object x=Cnil,dirend=Cnil; ! int assume=0; ! int relative=0; ! int name_type_key=0; ! char *p; ! vs_mark; /* only push stack - but dont'nt use it */ ! *ep=end; ! ! p = s->st.st_self; ! ! /* ignore leading and trailing spaces */ ! for (;isspace(p[start]) && (start= 0) { ! x=sKunspecific; ! if (j>i) { ! x=parse_namestring_make(p,i,j); ! x=parse_namestring_key(x,sKhost,assume); ! if ((x == sKsys) || ! (pathname_lookup(x,sSApathname_logicalA) != Cnil)) { ! assume=';'; ! host = (x == sKsys) ? sKsys : ! pathname_case_word(x,sKdowncase); ! } else ! if (pathname_lookup(x,sSApathname_virtualA) != Cnil) { ! assume='/'; ! host=x; ! } else ! if ((j-i==1) || ! (pathname_lookup(x,sSApathname_devicesA) != Cnil)) { ! assume='/'; ! device=x; ! } else ! return(file_error("Invalid device or host in namestring ~S.", s)); ! } ! i=j+1; } else { ! x = Cnil; ! if (defhost != Cnil) ! x = defhost; ! else ! if ((defaults != Cnil) && (defaults->pn.pn_host != Cnil)) ! x = defaults->pn.pn_host; ! ! if (x != Cnil) { ! if ((x == sKsys) || ! (pathname_lookup(x,sSApathname_logicalA) != Cnil)) { ! assume=';'; ! host = (x == sKsys) ? sKsys : ! pathname_case_word(x,sKdowncase); ! } else ! if (pathname_lookup(x,sSApathname_virtualA) != Cnil) { ! assume='/'; ! host=x; } } ! } ! ! while (i= 0) { ! if (assume==';') ! return(file_error("Invalid character in logical pathname namestring ~S.", s)); ! assume='/'; ! x=Cnil; ! if (j>i) { ! x=parse_namestring_make(p,i,j); ! x=parse_namestring_key(x,sKdirectory,assume); ! } ! if ((directory == Cnil) && (x==Cnil)) { ! directory=make_cons(sKabsolute,Cnil); ! vs_push(directory); /* vs_push the list */ ! dirend=directory; ! } else ! if ((directory == Cnil) && (x!=Cnil)) { ! directory=make_cons(x,Cnil); ! vs_push(directory); /* vs_push the list */ ! dirend=directory; ! } else ! if ((directory != Cnil) && (x!=Cnil)) { ! dirend->c.c_cdr=make_cons(x,Cnil); ! dirend=dirend->c.c_cdr; ! } else ! return(file_error("Invalid blank component in namestring ~S.", s)); ! i=j+1; ! } else ! ! /* try on lisp like directories */ ! if ((assume != '/') && ! ((j=parse_namestring_check(p,i,end,';',';')) >= 0)) { ! assume=';'; ! x=Cnil; ! if (j>i) { ! x=parse_namestring_make(p,i,j); ! x=pathname_case_word(x,sKdowncase); ! x=parse_namestring_key(x,sKdirectory,assume); ! } ! if ((directory == Cnil) && (x==Cnil)) { ! if (relative) ! return(file_error("Invalid blank component in namestring ~S.", s)); ! relative=1; ! } else ! if ((directory == Cnil) && (x!=Cnil)) { ! if (relative) { ! directory=make_cons(x,Cnil); ! dirend=directory; ! relative=0; ! } else { ! directory=make_cons(sKabsolute,Cnil); ! directory->c.c_cdr=make_cons(x,Cnil); ! dirend=directory->c.c_cdr; ! } ! } else ! if ((directory != Cnil) && (x!=Cnil)) { ! dirend->c.c_cdr=make_cons(x,Cnil); ! dirend=dirend->c.c_cdr; ! } else ! return(file_error("Invalid blank component in namestring ~S.", s)); ! i=j+1; ! } else ! ! /* try on special cases */ ! if ((directory==Cnil) && ( ! ((end-i==1) && !strncmp(p+i,".",1)) || ! ((end-i==1) && !strncmp(p+i,"~",1)) || ! ((end-i==2) && !strncmp(p+i,"..",2)))) { ! x=parse_namestring_make(p,i,end); ! x=parse_namestring_key(x,sKdirectory,'/'); ! directory=make_cons(x,Cnil); ! vs_push(directory); /* vs_push the list */ ! assume='/'; ! i=end; } else { ! ! /* try on name, type and version */ ! j=parse_namestring_check(p,i,end,'.',assume); ! if ((j==-2) && (assume == ';')) ! return(file_error("Invalid character in logical pathname namestring ~S.", s)); ! if ((j==-1) || ((assume != ';') && (name_type_key==1))) ! j=end; ! x=Cnil; ! if (j>i) { ! x=parse_namestring_make(p,i,j); ! if (assume == ';') ! x=pathname_case_word(x,sKdowncase); ! switch (name_type_key++) { ! case 0: ! name=parse_namestring_key(x,sKname,assume); ! if (j+1==end) ! type=parse_namestring_make(p,j+1,end); ! break; ! case 1: ! type=parse_namestring_key(x,sKtype,assume); ! break; ! case 2: ! version=parse_namestring_key(x,sKversion,assume); ! break; ! default: ! return(file_error("Invalid 4th name component in namestring ~S.", s)); ! } ! } else ! name_type_key++; ! i=j+1; } } ! ! x = make_pathname(host, device, directory, name, type, version, Cnil); ! vs_reset; /* release all that junk */ return(x); } + /* + * coerce_to_pathname + * coerce a string, symbol, stream, pathname into a pathname + * + * still old code - NO vs handling + * might contain SGC race conditions + */ + object coerce_to_pathname(x) object x; { ! object y=x; ! object n; int e; ! while (x != Cnil) { ! switch (type_of(x)) { ! case t_pathname: return(x); ! case t_symbol: ! case t_string: ! n = parse_namestring(x, Cnil, Cnil, 0, x->st.st_fillp, &e); ! if ((n == OBJNULL) || (e != x->st.st_fillp)) ! n = Cnil; ! x = n; ! break; ! ! case t_stream: switch (x->sm.sm_mode) { ! case smm_input: ! case smm_output: ! case smm_probe: ! case smm_io: ! /* The file was stored in sm.sm_object1. */ x = x->sm.sm_object1; ! break; ! case smm_synonym: ! /* The file was stored in sybol of sm.sm_object0. */ x = symbol_value(x->sm.sm_object0); ! break; ! default: ! x = Cnil; } + break; ! default: ! x=Cnil; ! } } + return(file_error("Cannot coerce ~S to a pathname.", y)); } static object default_device(host) object host; { + /* not implemented yet */ return(Cnil); } + /* + * merge_pathnames + * merges pathname, defaults and default_version + * + * does NOT YET handle :back. + * does NOT YET check for illegal conditions. + * + * vs_mark; vs_push; vs_reset; return new pathname + */ + object merge_pathnames(path, defaults, default_version) object path, defaults, default_version; { ! object host=Cnil, device=Cnil, directory=Cnil, ! name=Cnil, type=Cnil, version=Cnil; ! object x; ! vs_mark; ! ! if (path->pn.pn_host != Cnil) host = path->pn.pn_host; else ! host = defaults->pn.pn_host; ! if (path->pn.pn_device != Cnil) ! device = path->pn.pn_device; ! else ! if (path->pn.pn_host == Cnil) ! device = defaults->pn.pn_device; ! else ! if ((defaults->pn.pn_host != Cnil) && ! ((type_of(path->pn.pn_host) == t_symbol) || ! (type_of(path->pn.pn_host) == t_string)) && ! ((type_of(defaults->pn.pn_host) == t_symbol) || ! (type_of(defaults->pn.pn_host) == t_string)) && ! (string_equal(path->pn.pn_host, defaults->pn.pn_host) == TRUE)) ! device = defaults->pn.pn_device; ! else ! device = default_device(path->pn.pn_host); ! if (path->pn.pn_name == Cnil) { name = defaults->pn.pn_name; ! if (path->pn.pn_version != Cnil) ! version = path->pn.pn_version; ! else ! version = defaults->pn.pn_version; ! } else { name = path->pn.pn_name; + if (path->pn.pn_version != Cnil) + version = path->pn.pn_version; + else + version = default_version; + } if (path->pn.pn_type == Cnil) type = defaults->pn.pn_type; else type = path->pn.pn_type; ! ! if (defaults->pn.pn_directory==Cnil || ! ((type_of(path->pn.pn_directory)==t_cons) && ! ((path->pn.pn_directory->c.c_car==sKroot) || ! (path->pn.pn_directory->c.c_car==sKabsolute) || ! (path->pn.pn_directory->c.c_car==sKhome) || ! ((type_of(path->pn.pn_directory->c.c_car)==t_string) && ! (path->pn.pn_directory->c.c_car->st.st_self[0] == '~'))))) ! directory=path->pn.pn_directory; ! else ! if (path->pn.pn_directory==Cnil) ! directory=defaults->pn.pn_directory; ! else { ! directory=append(defaults->pn.pn_directory,path->pn.pn_directory); ! vs_push(directory); ! } ! ! x=make_pathname(host,device,directory,name,type,version, Cnil); ! vs_reset; ! return(x); } /* ! * Namestring(x) converts a pathname to a namestring. ! * creates a new namestring at token space ! * ignores :device or :host depending on *PATHNAME-RESOLVE* ! * ignores :version on non logical hosts depending on *PATHNAME-RESOLVE* ! * ! * return new string ! */ ! ! void namestring_add_char(c) ! char c; ! { ! if (token->st.st_fillp < token->st.st_dim) ! token->st.st_self[token->st.st_fillp++] = c; ! else { ! object x=copy_simple_string(token); ! vs_push(x); ! file_error("Token overrun at ~S.", x); ! return; ! } ! } ! ! void namestring_add_word(s,casekey) ! object s; ! object casekey; ! { ! int i=token->st.st_fillp; ! int j=0; ! ! if (s == sKwild) { ! namestring_add_char('*'); ! } else ! if (s == sKwildinf) { ! namestring_add_char('*'); ! namestring_add_char('*'); ! } else ! if ((s == sKrelative) || (s == sKcurrent)) { ! namestring_add_char('.'); ! } else ! if ((s == sKparent) || (s == sKup) || (s == sKback)) { ! namestring_add_char('.'); ! namestring_add_char('.'); ! } else ! if (s == sKhome) { ! namestring_add_char('~'); ! } else { ! if (casekey == sKcommon) { ! if (type_of(s) == t_symbol) ! s=symbol_name(s); ! s=pathname_case_word(s,casekey); ! } ! if (token->st.st_fillp + s->st.st_fillp <= token->st.st_dim) { ! while (jst.st_fillp) ! token->st.st_self[i++]=s->st.st_self[j++]; ! token->st.st_fillp += s->st.st_fillp; ! } else { ! object x; ! while (ist.st_dim) ! token->st.st_self[i++]=s->st.st_self[j++]; ! token->st.st_fillp = token->st.st_dim; ! x=copy_simple_string(token); ! vs_push(x); ! file_error("Token overrun at ~S.", x); ! } ! } ! } ! object namestring(x) object x; { object l, y; + int flag_host=0; + vs_mark; ! token->st.st_fillp=0; ! if (pathname_resolve(sKhost)) { ! l = x->pn.pn_host; ! y = x->pn.pn_device; ! if ((l!=Cnil) && (l!=sKunspecific) && ! (y!=Cnil) && (y!=sKunspecific)) ! return(file_error("Invalid device in pathname ~S.", x)); ! ! if (l == sKsys) { ! namestring_add_word(l,sKlocal); ! namestring_add_char(':'); ! flag_host=1; ! } else ! if (type_of(l) == t_string) { ! if (pathname_lookup(l,sSApathname_logicalA) != Cnil) { ! namestring_add_word(l,sKcommon); ! namestring_add_char(':'); ! flag_host=1; ! } else { ! namestring_add_word(l,sKlocal); ! namestring_add_char(':'); ! flag_host=0; } ! } else ! if ((l!=Cnil) && (l!=sKunspecific)) ! return(file_error("Invalid host in logical pathname ~S.",x)); ! } ! if (pathname_resolve(sKdevice)) { ! l = x->pn.pn_device; ! if (type_of(l) == t_string) { ! namestring_add_word(l,sKlocal); ! namestring_add_char(':'); ! } else ! if ((l!=Cnil) && (l!=sKunspecific)) ! return(file_error("Invalid device in pathname ~S.", x)); } ! ! l = x->pn.pn_directory; ! if (type_of(l) == t_cons) { ! y = l->c.c_car; ! if ((y == sKroot) || (y == sKabsolute)) { ! if (!flag_host) ! namestring_add_char('/'); ! l = l->c.c_cdr; ! } else if (y == sKrelative) { ! if (flag_host) ! namestring_add_char(';'); ! l = l->c.c_cdr; ! } else ! if (flag_host) ! namestring_add_char(';'); ! ! while (!endp(l)) { ! y = l->c.c_car; ! if ((y == sKcurrent) || (y == sKparent) || ! (y == sKup) || (y == sKback) || (y == sKhome)) { ! if (flag_host) ! return(file_error("Invalid directory in logical pathname ~S.",x)); ! namestring_add_word(y,flag_host ? sKcommon : sKlocal); ! } else ! if ((y == sKwild) || (y == sKwildinf) || ! (type_of(y) == t_string)) ! namestring_add_word(y,flag_host ? sKcommon : sKlocal); ! else ! return(file_error("Invalid directory in pathname ~S.",x)); ! namestring_add_char(flag_host ? ';' : '/'); ! l = l->c.c_cdr; ! } ! } else ! if (l != Cnil) ! return(file_error("Invalid directory in pathname ~S.",x)); ! y = x->pn.pn_name; ! if ((y == sKwild) || (type_of(y) == t_string)) ! namestring_add_word(y,flag_host ? sKcommon : sKlocal); ! else ! if (y != Cnil) ! return(file_error("Invalid name in pathname ~S.", x)); y = x->pn.pn_type; ! if ((y == sKwild) || (type_of(y) == t_string)) { ! namestring_add_char('.'); ! namestring_add_word(y,flag_host ? sKcommon : sKlocal); ! } else ! if (y != Cnil) ! return(file_error("Invalid type in pathname ~S.", x)); ! ! if (flag_host || pathname_resolve(sKversion)) { ! y = x->pn.pn_version; ! if ((y == sKwild) || (type_of(y) == t_string)) { ! namestring_add_char('.'); ! namestring_add_word(y,flag_host ? sKcommon : sKlocal); ! } else ! if (y == sKnewest) { ! if (flag_host) { ! namestring_add_char('.'); ! /* sKnewest is a keyword, so case is other way round */ ! namestring_add_word(y,flag_host ? sKlocal : sKcommon); ! } ! } else ! if (y != Cnil) ! return(file_error("Invalid version in pathname ~S.", x)); } ! #ifdef FIX_FILENAME ! /* ugly broken OS dependency in old GCL - I hope nobody needs it ! */ ! if (token->st.st_fillp > MAXPATHLEN-1) ! return(file_error("Pathname ~S is to long for your filesystem.", x)); ! /* token->st.st_fillp = MAXPATHLEN-1; */ #endif ! y=copy_simple_string(token); ! vs_reset; ! return(y); } object ! coerce_to_namestring(y) ! object y; { + object x=y; ! while(x != Cnil) { switch (type_of(x)) { case t_symbol: ! x=symbol_name(x); case t_string: return(x); *************** L: *** 436,460 **** case smm_probe: case smm_io: x = x->sm.sm_object1; ! /* ! The file was stored in sm.sm_object1. ! See open. ! */ ! goto L; case smm_synonym: x = symbol_value(x->sm.sm_object0); ! goto L; default: ! goto CANNOT_COERCE; } default: ! CANNOT_COERCE: ! FEerror("~S cannot be coerced to a namestring.", 1, x); ! return(Cnil); } } LFD(Lpathname)(void) --- 1008,1052 ---- case smm_probe: case smm_io: x = x->sm.sm_object1; ! break; case smm_synonym: x = symbol_value(x->sm.sm_object0); ! break; default: ! x = Cnil; } + break; default: ! x = Cnil; ! } ! } ! return(file_error("Cannot coerce ~S to a namestring.", y)); ! } ! ! object ! coerce_to_local_namestring(pathname) ! object pathname; ! { ! object namestring; ! ! vs_mark; ! check_type_or_pathname_string_symbol_stream(&pathname); ! if (pathname_resolve(sKhost)) { ! object n; ! n = coerce_to_pathname(pathname); ! vs_push(n); ! if ((n->pn.pn_host == sKsys) || ((n->pn.pn_host != Cnil) && ! (pathname_lookup(n->pn.pn_host,sSApathname_logicalA) != Cnil))) { ! pathname = translate_logical_pathname(n,32); ! vs_push(pathname); } + } + namestring = coerce_to_namestring(pathname); + vs_reset; + return namestring; } LFD(Lpathname)(void) *************** LFD(Lpathname)(void) *** 464,541 **** vs_base[0] = coerce_to_pathname(vs_base[0]); } ! @(defun parse_namestring (thing ! &o host ! (defaults `symbol_value(Vdefault_pathname_defaults)`) ! &k start end junk_allowed ! &a x y) ! int s, e, ee; ! @ ! check_type_or_pathname_string_symbol_stream(&thing); ! check_type_or_pathname_string_symbol_stream(&defaults); ! defaults = coerce_to_pathname(defaults); ! x = thing; ! L: ! switch (type_of(x)) { ! case t_symbol: ! case t_string: get_string_start_end(x, start, end, &s, &e); ! for (; s < e && isspace((int)x->st.st_self[s]); s++) ! ; ! y ! /* !!!!! Bug Fix. NLG */ ! = parse_namestring(x, ! s, ! e - s, ! &ee); ! if (junk_allowed == Cnil) { ! for (; ee < e - s; ee++) ! if (!isspace((int)x->st.st_self[s + ee])) ! break; ! if (y == OBJNULL || ee != e - s) ! FEerror("Cannot parse the namestring ~S~%\ ! from ~S to ~S.", ! 3, x, start, end); ! } else ! if (y == OBJNULL) ! @(return Cnil `make_fixnum(s + ee)`) ! start = make_fixnum(s + ee); break; ! case t_pathname: y = x; break; ! case t_stream: switch (x->sm.sm_mode) { case smm_input: case smm_output: case smm_probe: case smm_io: x = x->sm.sm_object1; ! /* ! The file was stored in sm.sm_object1. ! See open. ! */ ! goto L; case smm_synonym: x = symbol_value(x->sm.sm_object0); ! goto L; default: ! goto CANNOT_PARSE; } ! default: ! CANNOT_PARSE: ! FEerror("Cannot parse the namestring ~S.", 1, x); } ! if (host != Cnil && y->pn.pn_host != Cnil && ! host != y->pn.pn_host) ! FEerror("The hosts ~S and ~S do not match.", ! 2, host, y->pn.pn_host); ! @(return y start) @) @(defun merge_pathnames (path --- 1056,1130 ---- vs_base[0] = coerce_to_pathname(vs_base[0]); } ! object parse_namestring_obj(x,host,defaults,start,end,eep) ! object x,host,defaults,start,end; ! int *eep; ! { ! int s, e; ! object y = Cnil; ! *eep=0; ! ! while ((x != Cnil) && (y == Cnil)) { ! switch (type_of(x)) { ! case t_symbol: ! case t_string: get_string_start_end(x, start, end, &s, &e); ! y = parse_namestring(x, host, defaults, s, e, eep); ! if (y == OBJNULL) ! return Cnil; break; ! case t_pathname: y = x; break; ! case t_stream: switch (x->sm.sm_mode) { case smm_input: case smm_output: case smm_probe: case smm_io: x = x->sm.sm_object1; ! break; case smm_synonym: x = symbol_value(x->sm.sm_object0); ! break; default: ! return(file_error("Cannot parse the namestring stream ~S.", x)); ! x=Cnil; } ! default: ! return(file_error("Cannot parse the namestring thing ~S.", x)); ! x=Cnil; ! } ! } ! if ( (host != Cnil) && (host != sKunspecific) && ! (y->pn.pn_host != Cnil) && (y->pn.pn_host != sKunspecific)) { ! check_type_or_symbol_string(&host); ! check_type_or_symbol_string(&y->pn.pn_host); ! if (string_equal(host, y->pn.pn_host)==FALSE) ! return(file_error("The pathname ~S does not match the host.", y)); } ! return y; ! } ! ! @(defun parse_namestring (thing ! &o host ! (defaults `symbol_value(Vdefault_pathname_defaults)`) ! &k start end junk_allowed ! &a x l) ! int ee; ! @ ! check_type_or_pathname_string_symbol_stream(&thing); ! check_type_or_pathname_string_symbol_stream(&defaults); ! defaults = coerce_to_pathname(defaults); ! x = thing; ! x = parse_namestring_obj(x,host,defaults,start,end,&ee); ! l = make_fixnum(ee); ! @(return x l) @) @(defun merge_pathnames (path *************** from ~S to ~S.", *** 556,580 **** (name `Cnil` name_supplied_p) (type `Cnil` type_supplied_p) (version `Cnil` version_supplied_p) ! defaults ! &aux x) @ if ( defaults == Cnil ) { ! defaults = symbol_value ( Vdefault_pathname_defaults ); ! defaults = coerce_to_pathname ( defaults ); ! defaults = make_pathname ( defaults->pn.pn_host, ! Cnil, Cnil, Cnil, Cnil, Cnil); } else { defaults = coerce_to_pathname(defaults); } ! x = make_pathname(host, device, directory, name, type, version); x = merge_pathnames(x, defaults, Cnil); ! if ( host_supplied_p) x->pn.pn_host = host; ! if (device_supplied_p) x->pn.pn_device = device; ! if (directory_supplied_p) x->pn.pn_directory = directory; ! if (name_supplied_p) x->pn.pn_name = name; ! if (type_supplied_p) x->pn.pn_type = type; ! if (version_supplied_p) x->pn.pn_version = version; @(return x) @) --- 1145,1170 ---- (name `Cnil` name_supplied_p) (type `Cnil` type_supplied_p) (version `Cnil` version_supplied_p) ! (case `Cnil` case_supplied_p) ! (defaults `Cnil` defaults_supplied_p) ! &aux x) @ if ( defaults == Cnil ) { ! if (defaults_supplied_p) ! defaults = make_pathname ( Cnil, ! Cnil, Cnil, Cnil, Cnil, Cnil, Cnil); ! else { ! defaults = symbol_value ( Vdefault_pathname_defaults ); ! defaults = coerce_to_pathname ( defaults ); ! defaults = make_pathname ( defaults->pn.pn_host, ! Cnil, Cnil, Cnil, Cnil, Cnil, Cnil); ! } } else { defaults = coerce_to_pathname(defaults); } ! x = make_pathname(host, device, directory, name, type, version, case); x = merge_pathnames(x, defaults, Cnil); ! @(return x) @) *************** LFD(Lpathnamep)(void) *** 588,637 **** vs_base[0] = Cnil; } ! LFD(Lpathname_host)(void) ! { ! check_arg(1); ! ! check_type_or_pathname_string_symbol_stream(&vs_base[0]); ! vs_base[0] = coerce_to_pathname(vs_base[0]); ! vs_base[0] = vs_base[0]->pn.pn_host; ! } ! ! LFD(Lpathname_device)(void) ! { ! check_arg(1); ! ! check_type_or_pathname_string_symbol_stream(&vs_base[0]); ! vs_base[0] = coerce_to_pathname(vs_base[0]); ! vs_base[0] = vs_base[0]->pn.pn_device; ! } ! ! LFD(Lpathname_directory)(void) ! { ! check_arg(1); ! ! check_type_or_pathname_string_symbol_stream(&vs_base[0]); ! vs_base[0] = coerce_to_pathname(vs_base[0]); ! vs_base[0] = vs_base[0]->pn.pn_directory; ! } ! LFD(Lpathname_name)(void) ! { ! check_arg(1); ! check_type_or_pathname_string_symbol_stream(&vs_base[0]); ! vs_base[0] = coerce_to_pathname(vs_base[0]); ! vs_base[0] = vs_base[0]->pn.pn_name; ! } ! LFD(Lpathname_type)(void) ! { ! check_arg(1); ! check_type_or_pathname_string_symbol_stream(&vs_base[0]); ! vs_base[0] = coerce_to_pathname(vs_base[0]); ! vs_base[0] = vs_base[0]->pn.pn_type; ! } LFD(Lpathname_version)(void) { --- 1178,1268 ---- vs_base[0] = Cnil; } ! @(defun pathname_host (pathname &key ! (case `Cnil` case_supplied_p) ! &aux x) ! @ ! vs_mark; ! check_type_or_pathname_string_symbol_stream(&pathname); ! x = coerce_to_pathname(pathname); ! x = x->pn.pn_host; ! if (case == sKcommon) ! x=pathname_case_word(x,sKcommon); ! vs_reset; ! @(return x) ! @) ! @(defun pathname_device (pathname &key ! (case `Cnil` case_supplied_p) ! &aux x) ! @ ! vs_mark; ! check_type_or_pathname_string_symbol_stream(&pathname); ! x = coerce_to_pathname(pathname); ! x = x->pn.pn_device; ! if (case == sKcommon) ! x=pathname_case_word(x,sKcommon); ! vs_reset; ! @(return x) ! @) ! @(defun pathname_directory (pathname &key ! (case `Cnil` case_supplied_p) ! &aux x) ! @ ! object y,z; ! vs_mark; ! check_type_or_pathname_string_symbol_stream(&pathname); ! x = coerce_to_pathname(pathname); ! x = x->pn.pn_directory; ! if (case == sKcommon) { ! if (type_of(x) == t_string) ! x=pathname_case_word(x,sKcommon); ! else ! if (type_of(x) == t_cons) { ! z = x; ! y = make_cons( pathname_case_word(z->c.c_car,sKcommon), Cnil); ! x = y; ! vs_push(y); ! for (z = z->c.c_cdr; type_of(z) == t_cons; z = z->c.c_cdr) { ! y->c.c_cdr = make_cons( ! pathname_case_word(z->c.c_car,sKcommon), Cnil); ! y = y->c.c_cdr; ! } ! y->c.c_cdr = pathname_case_word(z,sKcommon); ! } ! } ! vs_reset; ! @(return x) ! @) ! @(defun pathname_name (pathname &key ! (case `Cnil` case_supplied_p) ! &aux x) ! @ ! vs_mark; ! check_type_or_pathname_string_symbol_stream(&pathname); ! x = coerce_to_pathname(pathname); ! x = x->pn.pn_name; ! if (case == sKcommon) ! x=pathname_case_word(x,sKcommon); ! vs_reset; ! @(return x) ! @) ! @(defun pathname_type (pathname &key ! (case `Cnil` case_supplied_p) ! &aux x) ! @ ! vs_mark; ! check_type_or_pathname_string_symbol_stream(&pathname); ! x = coerce_to_pathname(pathname); ! x = x->pn.pn_type; ! if (case == sKcommon) ! x=pathname_case_word(x,sKcommon); ! vs_reset; ! @(return x) ! @) LFD(Lpathname_version)(void) { *************** LFD(Lfile_namestring)(void) *** 660,666 **** = make_pathname(Cnil, Cnil, Cnil, vs_base[0]->pn.pn_name, vs_base[0]->pn.pn_type, ! vs_base[0]->pn.pn_version); vs_base[0] = namestring(vs_base[0]); } --- 1291,1298 ---- = make_pathname(Cnil, Cnil, Cnil, vs_base[0]->pn.pn_name, vs_base[0]->pn.pn_type, ! vs_base[0]->pn.pn_version, ! Cnil); vs_base[0] = namestring(vs_base[0]); } *************** LFD(Ldirectory_namestring)(void) *** 673,679 **** vs_base[0] = make_pathname(Cnil, Cnil, vs_base[0]->pn.pn_directory, ! Cnil, Cnil, Cnil); vs_base[0] = namestring(vs_base[0]); } --- 1305,1312 ---- vs_base[0] = make_pathname(Cnil, Cnil, vs_base[0]->pn.pn_directory, ! Cnil, Cnil, Cnil, ! Cnil); vs_base[0] = namestring(vs_base[0]); } *************** LFD(Lhost_namestring)(void) *** 710,727 **** Cnil : path->pn.pn_type, equalp(path->pn.pn_version, defaults->pn.pn_version) ? ! Cnil : path->pn.pn_version); @(return `namestring(path)`) @) void gcl_init_pathname(void) { Vdefault_pathname_defaults = make_special("*DEFAULT-PATHNAME-DEFAULTS*", ! make_pathname(Cnil, Cnil, Cnil, Cnil, Cnil, Cnil)); sKwild = make_keyword("WILD"); sKnewest = make_keyword("NEWEST"); sKstart = make_keyword("START"); --- 1343,2003 ---- Cnil : path->pn.pn_type, equalp(path->pn.pn_version, defaults->pn.pn_version) ? ! Cnil : path->pn.pn_version, ! Cnil); @(return `namestring(path)`) @) + /* + * wild_component_p + * checks a pathname component + * + * return 0 or 1 + */ + + static int + wild_component_p(o) + object o; + { + int i; + + if (o == Cnil) + return 0; + while (type_of(o) == t_cons) { + if (wild_component_p(o->c.c_car)) + return 1; + o=o->c.c_cdr; + } + if (o == Cnil) + return 0; + if ((o == sKwild) || (o == sKwildinf)) + return 1; + if (type_of(o) == t_string) + for (i=0; ist.st_fillp; i++) + if ((o->st.st_self[i]=='*') || (o->st.st_self[i]=='?')) + return 1; + + return 0; + } + + static object wild_pathname_p(x,totest) + object x,totest; + { + int is_wild = 0; + + if (totest != Cnil) { + if (totest == sKdirectory) { + if (wild_component_p(x->pn.pn_directory)) is_wild++; + } else + if (totest == sKname) { + if (wild_component_p(x->pn.pn_name)) is_wild++; + } else + if (totest == sKtype) { + if (wild_component_p(x->pn.pn_type)) is_wild++; + } else + if (totest == sKdevice) { + if (wild_component_p(x->pn.pn_device)) is_wild++; + } else + if (totest == sKhost) { + if (wild_component_p(x->pn.pn_host)) is_wild++; + } else + if (totest == sKversion) { + if (wild_component_p(x->pn.pn_version)) is_wild++; + } else + return(file_error("Invalid key for wild-pathname-p ~S.",totest)); + } else { + if (wild_component_p(x->pn.pn_directory)) is_wild++; + else + if (wild_component_p(x->pn.pn_name)) is_wild++; + else + if (wild_component_p(x->pn.pn_type)) is_wild++; + else + if (wild_component_p(x->pn.pn_device)) is_wild++; + else + if (wild_component_p(x->pn.pn_host)) is_wild++; + else + if (wild_component_p(x->pn.pn_version)) is_wild++; + } + return is_wild ? Ct : Cnil; + } + + @(defun wild_pathname_p (pathname &o + (totest `Cnil` totest_supplied_p) + &aux x) + @ + vs_mark; + check_type_or_pathname_string_symbol_stream(&pathname); + x = coerce_to_pathname(pathname); + x = wild_pathname_p(x,totest); + vs_reset; + @(return x) + @) + + /* + * pathstring_match_add + * add a match to the list of matches + * + * returns (cons token build) + */ + + static object + pathstring_match_add(build,t) + object build,t; + { + if (t==token) + t=vs_push(copy_simple_string(t)); + if (build->c.c_car == Cnil) + build->c.c_car = t; + else { + build=make_cons(t,build); + vs_push(build); + } + + return(build); + } + + /* + * pathstring_match_range + * match to ranged strings + * + * build starts as Cnil to become t_cons while building build + * or Ct to return true without building. + * building will need vs_mark/vs_reset to clean garbage. + * + * return build or Cnil + */ + + static object + pathstring_match_range(s,sl,p,pl,build) + const char *s, *p; + int sl,pl; + object build; + { + const char *next, *try; + object r; + + while ((sl > 0) && *s) { + if ((pl <= 0) || !*p) + return Cnil; + + if ((*p == '*') || ((*p == '?') && (*s != '*'))) { + if ((pl == 1) && ((*p == '*') || + ((*p == '?') && (*s != '*') && (sl == 1)))) { + if (type_of(build)==t_cons) { + char *t; + t=token->st.st_self; + while ((sl > 0) && *s) { + *t++=*s++; sl--; + } + token->st.st_fillp=t-token->st.st_self; + build=pathstring_match_add(build,token); + } + return build; + } + next = p+1; + try = (*p == '*') ? s : s+1; + while ((s+sl-try>0) && *try) { + if (((*try == *next) || (*next == '?') || (*next == '*')) && + ((r=pathstring_match_range( + try,s+sl-try, next,pl-1, build))!=Cnil)) { + if (type_of(r)==t_cons) { + char *t; + t=token->st.st_self; + while ((sl > 0) && (sst.st_fillp=t-token->st.st_self; + build=pathstring_match_add(r,token); + } + return build; + } + + if (*p == '*') + try++; + else + return Cnil; + } + return Cnil; + } + if (*s == *p) { + s++, p++, sl--, pl--; + } else + return Cnil; + } + if ((*p == '*') && (pl == 1)) { + if (type_of(build)==t_cons) { + token->st.st_fillp=0; + build=pathstring_match_add(build,token); + } + return build; + } + return (pl == 0) ? build : Cnil; + } + + /* + * pathobject_match_p + * checks two pathes to match + * patches a 3rd object if its a cons + */ + + static object + pathobject_match_p(s,m,b) + object s,m,b; + { + object r; + + if ((m == sKwild) || (m == sKwildinf) || + (m == sKunspecific) || (m == Cnil)) + r = type_of(b) == t_cons ? pathstring_match_add(b,s) : b; + else + if ((s == m) || ((m == sKnewest) && + ((s == Cnil) || (s == sKunspecific) || (s == sKwild)))) + r = b; + else + if ((type_of(s) == t_string) && (type_of(m) == t_string)) + r = pathstring_match_range(s->st.st_self, s->st.st_fillp, + m->st.st_self, m->st.st_fillp, + b); + else + r = Cnil; + + return r; + } + + static object + pathlist_match_p(s,m,b) + object s,m,b; + { + while ((type_of(s) == t_cons) && (type_of(m) == t_cons)) { + if (pathobject_match_p(s->c.c_car,m->c.c_car,Ct) == Cnil) + return Cnil; + if (m->c.c_car == sKwildinf) { + object next,try,r,t; + try = s; + next = m->c.c_cdr; + if (next == Cnil) { + r = b; + if (type_of(b) == t_cons) { + t = make_cons(Cnil,Cnil); + vs_push(t); + r = pathstring_match_add(r,t); + while (type_of(s) == t_cons) { + if (t->c.c_car == Cnil) + t->c.c_car = s->c.c_car; + else { + t->c.c_cdr = make_cons(s->c.c_car,Cnil); + t = t->c.c_cdr; + } + s = s->c.c_cdr; + } + } + return r; + } + while (type_of(try) == t_cons) { + if ((pathobject_match_p(try->c.c_car,next->c.c_car,Ct) != Cnil) && + ((r=pathlist_match_p(try,next,b))!= Cnil)) { + if (type_of(r) == t_cons) { + t = make_cons(Cnil,Cnil); + vs_push(t); + r = pathstring_match_add(r,t); + while ((type_of(s) == t_cons) && (s != try)) { + if (t->c.c_car == Cnil) + t->c.c_car = s->c.c_car; + else { + t->c.c_cdr = make_cons(s->c.c_car,Cnil); + t = t->c.c_cdr; + } + s = s->c.c_cdr; + } + } + return r; + } + try=try->c.c_cdr; + } + return Cnil; + } else + if (wild_component_p(m->c.c_car)) { + b=pathlist_match_p(s->c.c_cdr,m->c.c_cdr,b); + if (b!=Cnil) + b=pathobject_match_p(s->c.c_car,m->c.c_car,b); + return b; + } + m=m->c.c_cdr; + s=s->c.c_cdr; + } + if ((s==Cnil) && (m->c.c_car == sKwildinf) && (m->c.c_cdr == Cnil)) { + vs_push(make_cons(Cnil,Cnil)); + b = pathstring_match_add(b,vs_head); + return b; + } + + return ((s==Cnil) && (m==Cnil)) ? b : Cnil; + } + + static object + pathdirect_match_p(s,m,b) + object s,m,b; + { + if (s==Cnil) { + if ((type_of(m) == t_cons) && + ((m->c.c_car == sKabsolute) || (m->c.c_car == sKrelative))) + m=m->c.c_cdr; + if ((m->c.c_car == sKwildinf) && (m->c.c_cdr == Cnil)) { + vs_push(make_cons(Cnil,Cnil)); + b = pathstring_match_add(b,vs_head); + return b; + } + return Cnil; + } + if ((type_of(s) == t_cons) && (type_of(m) == t_cons)) { + /* skip relative/absolute, if match */ + if ((s->c.c_car == sKabsolute) || (m->c.c_car == sKabsolute) || + (s->c.c_car == sKrelative) || (m->c.c_car == sKrelative)) { + if (s->c.c_car == m->c.c_car) { + s=s->c.c_cdr; + m=m->c.c_cdr; + } else + if ((s->c.c_car == sKrelative) && (m->c.c_car != sKabsolute)) + s=s->c.c_cdr; + else + if ((m->c.c_car == sKrelative) && (s->c.c_car != sKabsolute)) + m=m->c.c_cdr; + else + return Cnil; + } + /* do the real thing - run into recursion */ + return pathlist_match_p(s,m,b); + } + + /* directory must be t_cons */ + return Cnil; + } + + @(defun pathobject_match_p (s m) + @ + @(return `pathobject_match_p(s,m,Ct)`) + @) + + @(defun pathobject_match_t (s m) + @ + object x; + + vs_mark; + x=make_cons(Cnil,Cnil); + vs_push(x); + x=pathobject_match_p(s,m,x); + vs_reset; + + @(return x) + @) + + /* + * pathname_match_p + * returns T if pathname matches wildcard + */ + + object pathname_match_p(s,m,b) + object s,m,b; + { + object x = Ct; + vs_mark; + + check_type_or_pathname_string_symbol_stream(&s); + check_type_or_pathname_string_symbol_stream(&m); + s = coerce_to_pathname(s); vs_push(s); + m = coerce_to_pathname(m); vs_push(m); + + x=b; + if ((x != Cnil) && (m->pn.pn_version != Cnil)) + x=pathobject_match_p(s->pn.pn_version,m->pn.pn_version,x); + if ((x != Cnil) && (m->pn.pn_type != Cnil)) + x=pathobject_match_p(s->pn.pn_type,m->pn.pn_type,x); + if ((x != Cnil) && (m->pn.pn_name != Cnil)) + x=pathobject_match_p(s->pn.pn_name,m->pn.pn_name,x); + if ((x != Cnil) && (m->pn.pn_directory != Cnil)) + x=pathdirect_match_p(s->pn.pn_directory,m->pn.pn_directory,x); + if ((x != Cnil) && (m->pn.pn_device != Cnil)) + x=pathobject_match_p(s->pn.pn_device,m->pn.pn_device,x); + if ((x != Cnil) && (m->pn.pn_host != Cnil)) + x=pathobject_match_p(s->pn.pn_host,m->pn.pn_host,x); + + vs_reset; + return x; + } + + @(defun pathname_match_p (s m) + @ + @(return `pathname_match_p(s,m,Ct)`) + @) + + @(defun pathname_match_t (s m) + @ + object x; + + vs_mark; + x=make_cons(Cnil,Cnil); + vs_push(x); + x=pathname_match_p(s,m,x); + vs_reset; + + @(return x) + @) + + object pathobject_patch(s,xa) + object s,*xa; + { + int i,j; + char *t; + object p; + t=token->st.st_self; + + + if (s == sKwild) { + if ((type_of(*xa) == t_cons) && + (type_of((*xa)->c.c_car)==t_string)) { + p=(*xa)->c.c_car; + for (j=0;jst.st_fillp; j++) + *t++=p->st.st_self[j]; + p=(*xa)->c.c_cdr; + *xa=p; + } else + if ((type_of(*xa) == t_cons) && + (type_of((*xa)->c.c_car)==t_symbol)) { + p=*xa; + (*xa)=(*xa)->c.c_cdr; + return p->c.c_car; + } else + if (*xa == Cnil) + return Cnil; + else + FEerror("Invalid wild pathobject_patch ~S for sKwild",1,*xa); + } else + if (type_of(s) == t_string) { + for (i=0; ist.st_fillp; i++) { + if ((s->st.st_self[i]!='*') && (s->st.st_self[i]!='?')) + *t++=s->st.st_self[i]; + else + if ((type_of(*xa) == t_cons) && + (type_of((*xa)->c.c_car)==t_string)) { + p=(*xa)->c.c_car; + for (j=0;jst.st_fillp; j++) + *t++=p->st.st_self[j]; + p=(*xa)->c.c_cdr; + *xa=p; + } else + if (*xa != Cnil) + FEerror("Invalid wild pathobject_patch ~S for wild",1,*xa); + } + } else + FEerror("Invalid wild pathobject_patch ~S string",1,s); + token->st.st_fillp=t-token->st.st_self; + + p=copy_simple_string(token); + vs_push(p); + return p; + } + + object + translate_pathname(s,m,p) + object s,m,p; + { + object r,t,x,y,z; + vs_mark; + + check_type_or_pathname_string_symbol_stream(&s); + check_type_or_pathname_string_symbol_stream(&m); + check_type_or_pathname_string_symbol_stream(&p); + s = coerce_to_pathname(s); vs_push(s); + m = coerce_to_pathname(m); vs_push(m); + p = coerce_to_pathname(p); vs_push(p); + + x=make_cons(Cnil,Cnil); + vs_push(x); + x=pathname_match_p(s,m,x); + vs_push(x); + + if (x != Cnil) { + r = make_pathname(Cnil,Cnil,Cnil,Cnil,Cnil,Cnil,Cnil); + + if (p->pn.pn_host == Cnil) + r->pn.pn_host = Cnil; + else + if (wild_component_p(p->pn.pn_host)) + r->pn.pn_host = pathobject_patch(p->pn.pn_host,&x); + else + r->pn.pn_host = p->pn.pn_host; + + if (p->pn.pn_device == Cnil) + r->pn.pn_device = Cnil; + else + if (wild_component_p(p->pn.pn_device)) + r->pn.pn_device = pathobject_patch(p->pn.pn_device,&x); + else + r->pn.pn_device = p->pn.pn_device; + + if (p->pn.pn_directory == Cnil) + r->pn.pn_directory = s->pn.pn_directory; + else + if (wild_component_p(m->pn.pn_directory)) { + y=p->pn.pn_directory; + z=Cnil; + while (type_of(y) == t_cons) { + if (y->c.c_car == sKwildinf) { + if (type_of(x)==t_cons) { + t = x->c.c_car; + if ((type_of(t)!=t_cons) && (t!=Cnil)) + FEerror("Invalid wild pathobject_patch ~S for sKwildinf",1,t); + if (t->c.c_car != Cnil) + while (type_of(t)==t_cons) { + if (z == Cnil) { + z = make_cons(t->c.c_car,Cnil); + r->pn.pn_directory=z; + } else { + z->c.c_cdr=make_cons(t->c.c_car,Cnil); + z=z->c.c_cdr; + } + t=t->c.c_cdr; + } + x=x->c.c_cdr; + } else + if (x!=Cnil) + FEerror("Invalid wild pathobject_patch ~S for sKwildinf",1,x); + } else { + if (wild_component_p(y->c.c_car)) + t = pathobject_patch(y->c.c_car,&x); + else + t = y->c.c_car; + if (z == Cnil) { + z = make_cons(t,Cnil); + r->pn.pn_directory=z; + } else { + z->c.c_cdr=make_cons(t,Cnil); + z=z->c.c_cdr; + } + } + y=y->c.c_cdr; + } + } else + r->pn.pn_directory = p->pn.pn_directory; + + if (p->pn.pn_name == Cnil) + r->pn.pn_name = s->pn.pn_name; + else + if (wild_component_p(p->pn.pn_name)) + r->pn.pn_name = pathobject_patch(p->pn.pn_name,&x); + else + r->pn.pn_name = p->pn.pn_name; + + if (p->pn.pn_type == Cnil) + r->pn.pn_type = s->pn.pn_type; + else + if (wild_component_p(p->pn.pn_type)) + r->pn.pn_type = pathobject_patch(p->pn.pn_type,&x); + else + r->pn.pn_type = p->pn.pn_type; + + if (p->pn.pn_version == Cnil) + r->pn.pn_version = pathname_resolve(sKversion) ? + s->pn.pn_version : Cnil; + else + if (wild_component_p(p->pn.pn_version)) + r->pn.pn_version = pathobject_patch(p->pn.pn_version,&x); + else + r->pn.pn_version = p->pn.pn_version; + } else + r = Cnil; + + vs_reset; + return r; + } + + @(defun translate_pathname (s m p &key) + @ + @(return `translate_pathname(s,m,p)`) + @) + + object + translate_logical_pathname(s,c) + object s; + { + object l,r; + vs_mark; + + check_type_or_pathname_string_symbol_stream(&s); + s = coerce_to_pathname(s); vs_push(s); + + if (--c<=0) + return(file_error("translate logical pathname ~S recursion stop.",s)); + + /* NIL and :SYS are implementation defined and fixed as real host */ + if ((s->pn.pn_host == Cnil) || (s->pn.pn_host == sKsys)) { + r=make_pathname(Cnil, + pathname_resolve(sKdevice) ? s->pn.pn_device : Cnil, + s->pn.pn_directory, s->pn.pn_name, s->pn.pn_type, + pathname_resolve(sKversion) ? s->pn.pn_version : Cnil, + Cnil); + vs_reset; + return r; + } + + if ((l = pathname_lookup(s->pn.pn_host,sSApathname_logicalA)) == Cnil) + return(file_error("Invalid host in logical pathname ~S.",s)); + + while (type_of(l) == t_cons) { + if ((type_of(l->c.c_car) == t_cons) && + (type_of(l->c.c_car->c.c_cdr) == t_cons) && + ((r=translate_pathname(s,l->c.c_car->c.c_car, + l->c.c_car->c.c_cdr->c.c_car)) != Cnil)) { + vs_push(r); + r=translate_logical_pathname(r,c); + vs_reset; + return r; + } + l=l->c.c_cdr; + } + + vs_reset; + return(file_error("No translation matches ~S.",s)); + } + + @(defun translate_logical_pathname (s &key) + @ + @(return `translate_logical_pathname(s,32)`) + @) + + @(defun logical_pathname (pathname) + @ + object s=pathname; + vs_mark; + + check_type_or_pathname_string_symbol_stream(&s); + s = coerce_to_pathname(s); vs_push(s); + + if ((s->pn.pn_host == Cnil) && (s->pn.pn_device == Cnil)) + s->pn.pn_host = sKsys; + else + if (s->pn.pn_device == Cnil) { + file_error("Invalid device in logical pathname ~S.",s); + s=Cnil; + } else + if (pathname_lookup(s->pn.pn_host,sSApathname_logicalA) == Cnil) { + file_error("Invalid host in logical pathname ~S.",s); + s=Cnil; + } + + vs_reset; + @(return s) + @) + void gcl_init_pathname(void) { Vdefault_pathname_defaults = make_special("*DEFAULT-PATHNAME-DEFAULTS*", ! make_pathname(Cnil, Cnil, Cnil, Cnil, Cnil, Cnil, Cnil)); sKwild = make_keyword("WILD"); + sKwildinf = make_keyword("WILD-INFERIORS"); sKnewest = make_keyword("NEWEST"); sKstart = make_keyword("START"); *************** gcl_init_pathname(void) *** 736,745 **** sKversion = make_keyword("VERSION"); sKdefaults = make_keyword("DEFAULTS"); sKroot = make_keyword("ROOT"); sKcurrent = make_keyword("CURRENT"); sKparent = make_keyword("PARENT"); ! sKper = make_keyword("PER"); } void --- 2012,2031 ---- sKversion = make_keyword("VERSION"); sKdefaults = make_keyword("DEFAULTS"); + sKper = make_keyword("PER"); sKroot = make_keyword("ROOT"); sKcurrent = make_keyword("CURRENT"); sKparent = make_keyword("PARENT"); ! sKabsolute = make_keyword("ABSOLUTE"); ! sKrelative = make_keyword("RELATIVE"); ! sKup = make_keyword("UP"); ! sKback = make_keyword("BACK"); ! sKlocal = make_keyword("LOCAL"); ! sKcommon = make_keyword("COMMON"); ! sKunspecific = make_keyword("UNSPECIFIC"); ! sKsys = make_keyword("SYS"); ! sKhome = make_keyword("HOME"); ! sKpathname_error = make_keyword("PATHNAME-ERROR"); } void *************** gcl_init_pathname_function() *** 761,764 **** --- 2047,2061 ---- make_function("DIRECTORY-NAMESTRING", Ldirectory_namestring); make_function("HOST-NAMESTRING", Lhost_namestring); make_function("ENOUGH-NAMESTRING", Lenough_namestring); + make_function("WILD-PATHNAME-P", Lwild_pathname_p); + make_function("PATHNAME-MATCH-P", Lpathname_match_p); + make_function("TRANSLATE-PATHNAME", Ltranslate_pathname); + make_function("TRANSLATE-LOGICAL-PATHNAME", Ltranslate_logical_pathname); + make_function("LOGICAL-PATHNAME", Llogical_pathname); + + make_si_function("PATHNAME-LOOKUP", Lpathname_lookup); + make_si_function("SET-PATHNAME-LOOKUP", Lset_pathname_lookup); + make_si_function("PATHOBJECT-MATCH-P", Lpathobject_match_p); + make_si_function("PATHOBJECT-MATCH-T", Lpathobject_match_t); + make_si_function("PATHNAME-MATCH-T", Lpathname_match_t); } *** ../gcl-cvs/./o/print.d Thu Nov 6 17:08:10 2003 --- ./o/print.d Wed May 19 14:15:44 2004 *************** Foundation, 675 Mass Ave, Cambridge, MA *** 22,34 **** print.d */ #define NEED_ISFINITE #include "include.h" #include ! #define LINE_LENGTH line_length ! int line_length = 72; #ifndef WRITEC_NEWLINE #define WRITEC_NEWLINE(strm) (writec_stream('\n',strm)) --- 22,49 ---- print.d */ + /* hacked by Michael Koehne (c) GNU LGPL + * kraehe (at) copyleft.de + * Sun Apr 25 07:43:08 CEST 2004 + * + * beware of new bugs^h^h^h^h features ! + * + * many thanks to pfdietz - not only for ircing at #lisp to explain a + * few bits to me, but even more for writing the ansi-test. This hack + * would never been possible without his regression test ! + * ------------------------------------------------------------------------- */ + #define NEED_ISFINITE #include "include.h" #include ! #define LINE_LENGTH get_line_length() ! #define MINIMUM_RIGHT_MARGIN 1 ! #define DEFAULT_RIGHT_MARGIN 72 ! ! static int ! get_line_length(void); #ifndef WRITEC_NEWLINE #define WRITEC_NEWLINE(strm) (writec_stream('\n',strm)) *************** DEFVAR("*PRINT-PACKAGE*",sSAprint_packag *** 1835,1840 **** --- 1850,1865 ---- DEFVAR("*PRINT-STRUCTURE*",sSAprint_structureA,SI,Cnil,""); DEF_ORDINARY("PRETTY-PRINT-FORMAT",sSpretty_print_format,SI,""); + /* + * those variables are only defined to make the ansi-test happy + * they are NOT YET implemented + */ + + DEFVAR("*PRINT-LINES*",sLAprint_linesA,LISP,Cnil,""); + DEFVAR("*PRINT-MISER-WIDTH*",sLAprint_miser_widthA,LISP,Cnil,""); + DEFVAR("*PRINT-RIGHT-MARGIN*",sLAprint_right_marginA,LISP,Cnil,""); + DEFVAR("*READ-EVAL*",sLAread_evalA,LISP,Ct,""); + void gcl_init_print() { *************** object sym; *** 2017,2037 **** } ! ! static void ! pp(x) ! object x; { ! princ(x,Cnil); ! flush_stream(symbol_value(sLAstandard_outputA)); } ! static object ! FFN(set_line_length)(n) ! int n; { ! line_length=n; ! return make_fixnum(line_length); } DEFVAR("*PRINT-NANS*",sSAprint_nansA,SI,Cnil,""); --- 2042,2065 ---- } ! static int ! get_line_length(void) { ! int l=0; ! object o=symbol_value(sLAprint_right_marginA); ! if ((o!=Cnil) && (type_of(o)==t_fixnum)) ! l=fix(o); ! if (ls.s_dbind = vs_base[0]; } DEFVAR("*PRINT-NANS*",sSAprint_nansA,SI,Cnil,""); *************** gcl_init_print_function() *** 2054,2061 **** make_function("FORCE-OUTPUT", Lforce_output); make_function("CLEAR-OUTPUT", Lclear_output); make_function("WRITE-BYTE", Lwrite_byte); ! make_si_sfun("SET-LINE-LENGTH",set_line_length,ARGTYPE1(f_fixnum) ! | RESTYPE(f_fixnum)); } --- 2082,2090 ---- make_function("FORCE-OUTPUT", Lforce_output); make_function("CLEAR-OUTPUT", Lclear_output); make_function("WRITE-BYTE", Lwrite_byte); ! ! /* KCL compatibility function */ ! make_function("SET-LINE-LENGTH",Lset_line_length); } *** ../gcl-cvs/./o/unixfsys.c Sat May 22 20:01:31 2004 --- ./o/unixfsys.c Sat May 22 17:59:05 2004 *************** getwd(char *buffer) *** 152,254 **** } #endif - #ifdef DGUX - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - #endif - void coerce_to_filename(object pathname, char *p) { ! object namestring; ! namestring = coerce_to_namestring(pathname); #ifndef NO_PWD_H ! if(namestring->st.st_self[0]=='~') ! {char name[20]; ! int n; ! char *q = namestring->st.st_self; #ifndef __STDC__ ! extern struct passwd *getpwuid(); ! extern struct passwd *getpwnam(); #endif ! struct passwd *pwent; ! int m=0; ! q=namestring->st.st_self; ! for (n=0; n< namestring->st.st_fillp; n++) ! if (q[n]=='/') break; ! bcopy(q+1,name,n-1); ! name[n-1]= 0; ! pwent = (n==1 ? getpwuid(getuid()) : getpwnam(name)); ! if (pwent==0 || ((m = strlen(pwent->pw_dir)) ! && (m + namestring->st.st_fillp -n) >= MAXPATHLEN -16)) ! {FEerror("Can't expand pathname ~a", 1,namestring);} ! bcopy(pwent->pw_dir,p,m); ! bcopy(namestring->st.st_self+n,p+m,namestring->st.st_fillp-n); ! p[m+namestring->st.st_fillp-n]=0;} ! else ! #endif ! {if (namestring->st.st_fillp >= MAXPATHLEN - 16) { ! vs_push(namestring); ! FEerror("Too long filename: ~S.", 1, namestring);} ! bcopy(namestring->st.st_self,p,namestring->st.st_fillp); ! p[namestring->st.st_fillp]=0;} #ifdef FIX_FILENAME FIX_FILENAME(pathname,p); #endif ! } object truename(object pathname) --- 152,217 ---- } #endif void coerce_to_filename(object pathname, char *p) { ! object namestring; ! ! vs_mark; ! namestring = coerce_to_namestring(pathname); ! vs_push(namestring); ! #ifndef NO_PWD_H ! if(namestring->st.st_self[0]=='~') { ! char name[20]; ! int n; ! char *q = namestring->st.st_self; #ifndef __STDC__ ! extern struct passwd *getpwuid(); ! extern struct passwd *getpwnam(); #endif + struct passwd *pwent; + int m=0; ! q=namestring->st.st_self; ! for (n=0; n< namestring->st.st_fillp; n++) ! if (q[n]=='/') break; ! bcopy(q+1,name,n-1); ! name[n-1]= 0; ! pwent = (n==1 ? getpwuid(getuid()) : getpwnam(name)); ! if (pwent==0 || ((m = strlen(pwent->pw_dir)) && ! (m + namestring->st.st_fillp -n) >= MAXPATHLEN -16)) { ! FEerror("Can't expand pathname ~a", 1,namestring); ! } ! bcopy(pwent->pw_dir,p,m); ! bcopy(namestring->st.st_self+n,p+m,namestring->st.st_fillp-n); ! p[m+namestring->st.st_fillp-n]=0; ! } else ! #endif ! { if (namestring->st.st_fillp >= MAXPATHLEN - 16) { ! FEerror("Too long filename: ~S.", 1, namestring); ! } ! bcopy(namestring->st.st_self,p,namestring->st.st_fillp); ! p[namestring->st.st_fillp]=0; ! } #ifdef FIX_FILENAME FIX_FILENAME(pathname,p); #endif ! vs_reset; } + void + coerce_to_local_filename(object pathname, char *p) + { + object namestring; + vs_mark; /* gbc paranoia */ + vs_push(pathname); + namestring=coerce_to_local_namestring(pathname); + vs_push(namestring); + coerce_to_filename(namestring, p); + vs_reset; + } object truename(object pathname) *************** truename(object pathname) *** 259,268 **** char current_directory[MAXPATHLEN]; char directory[MAXPATHLEN]; static char *getwd(char *buffer); - coerce_to_filename(pathname, filename); - for (p = filename, q = 0; *p != '\0'; p++) if (*p == '/') q = p; --- 222,231 ---- char current_directory[MAXPATHLEN]; char directory[MAXPATHLEN]; static char *getwd(char *buffer); + vs_mark; + coerce_to_local_filename(pathname, filename); for (p = filename, q = 0; *p != '\0'; p++) if (*p == '/') q = p; *************** truename(object pathname) *** 275,293 **** p = getwd(current_directory); } else #ifdef __MINGW32__ ! if (q[-1]==':') { int current = (q++, q[0]); q[0]=0; getwd(current_directory); if (chdir(filename) < 0) ! FEerror("Cannot get the truename of ~S.", 1, pathname); p = getwd(directory); if (p[1]==':' && p[2]=='\\' && p[3]==0) p[2]=0; q[0]=current; ! } ! else #endif ! { *q++ = '\0'; getwd(current_directory); if (chdir(filename) < 0) --- 238,256 ---- p = getwd(current_directory); } else #ifdef __MINGW32__ ! if (q[-1]==':') { int current = (q++, q[0]); q[0]=0; getwd(current_directory); if (chdir(filename) < 0) ! FEerror("Cannot get the truename of ~S.", 1, pathname); p = getwd(directory); if (p[1]==':' && p[2]=='\\' && p[3]==0) p[2]=0; q[0]=current; ! } ! else #endif ! { *q++ = '\0'; getwd(current_directory); if (chdir(filename) < 0) *************** truename(object pathname) *** 315,321 **** chdir(current_directory); vs_push(make_simple_string(truefilename)); pathname = coerce_to_pathname(vs_head); ! vs_popp; return(pathname); } object sSAallow_gzipped_fileA; --- 278,284 ---- chdir(current_directory); vs_push(make_simple_string(truefilename)); pathname = coerce_to_pathname(vs_head); ! vs_reset; return(pathname); } object sSAallow_gzipped_fileA; *************** file_exists(object file) *** 326,332 **** char filename[MAXPATHLEN]; struct stat filestatus; ! coerce_to_filename(file, filename); if (stat(filename, &filestatus) >= 0) { #ifdef AIX --- 289,295 ---- char filename[MAXPATHLEN]; struct stat filestatus; ! coerce_to_local_filename(file, filename); if (stat(filename, &filestatus) >= 0) { #ifdef AIX *************** LFD(Lrename_file)(void) *** 386,396 **** check_arg(2); check_type_or_pathname_string_symbol_stream(&vs_base[0]); check_type_or_Pathname_string_symbol(&vs_base[1]); ! coerce_to_filename(vs_base[0], filename); vs_base[0] = coerce_to_pathname(vs_base[0]); vs_base[1] = coerce_to_pathname(vs_base[1]); vs_base[1] = merge_pathnames(vs_base[1], vs_base[0], Cnil); ! coerce_to_filename(vs_base[1], newfilename); #ifdef HAVE_RENAME if (rename(filename, newfilename) < 0) FEerror("Cannot rename the file ~S to ~S.", --- 349,359 ---- check_arg(2); check_type_or_pathname_string_symbol_stream(&vs_base[0]); check_type_or_Pathname_string_symbol(&vs_base[1]); ! coerce_to_local_filename(vs_base[0], filename); vs_base[0] = coerce_to_pathname(vs_base[0]); vs_base[1] = coerce_to_pathname(vs_base[1]); vs_base[1] = merge_pathnames(vs_base[1], vs_base[0], Cnil); ! coerce_to_local_filename(vs_base[1], newfilename); #ifdef HAVE_RENAME if (rename(filename, newfilename) < 0) FEerror("Cannot rename the file ~S to ~S.", *************** DEFUNO_NEW("DELETE-FILE",object,fLdelete *** 436,442 **** /* 1 args */ check_type_or_pathname_string_symbol_stream(&path); ! coerce_to_filename(path, filename); if (unlink(filename) < 0) FEerror("Cannot delete the file ~S.", 1, path); path = Ct; --- 399,405 ---- /* 1 args */ check_type_or_pathname_string_symbol_stream(&path); ! coerce_to_local_filename(path, filename); if (unlink(filename) < 0) FEerror("Cannot delete the file ~S.", 1, path); path = Ct; *************** LFD(Lfile_write_date)(void) *** 467,473 **** check_arg(1); check_type_or_pathname_string_symbol_stream(&vs_base[0]); ! coerce_to_filename(vs_base[0], filename); if (stat(filename, &filestatus) < 0) { vs_base[0] = Cnil; return;} vs_base[0] = unix_time_to_universal_time(filestatus.st_mtime); } --- 430,436 ---- check_arg(1); check_type_or_pathname_string_symbol_stream(&vs_base[0]); ! coerce_to_local_filename(vs_base[0], filename); if (stat(filename, &filestatus) < 0) { vs_base[0] = Cnil; return;} vs_base[0] = unix_time_to_universal_time(filestatus.st_mtime); } *************** LFD(Lfile_author)(void) *** 484,490 **** check_arg(1); check_type_or_pathname_string_symbol_stream(&vs_base[0]); ! coerce_to_filename(vs_base[0], filename); if (stat(filename, &filestatus) < 0) { vs_base[0] = Cnil; return;} pwent = getpwuid(filestatus.st_uid); vs_base[0] = make_simple_string(pwent->pw_name); --- 447,453 ---- check_arg(1); check_type_or_pathname_string_symbol_stream(&vs_base[0]); ! coerce_to_local_filename(vs_base[0], filename); if (stat(filename, &filestatus) < 0) { vs_base[0] = Cnil; return;} pwent = getpwuid(filestatus.st_uid); vs_base[0] = make_simple_string(pwent->pw_name); *************** FFN(Luser_homedir_pathname)(void) *** 523,557 **** } #ifdef BSD LFD(Ldirectory)(void) { char filename[MAXPATHLEN]; ! char command[MAXPATHLEN * 2]; FILE *fp; register int i, c; ! object *top = vs_top; char iobuffer[BUFSIZ]; extern FILE *popen(const char *, const char *); ! check_arg(1); check_type_or_pathname_string_symbol_stream(&vs_base[0]); vs_base[0] = coerce_to_pathname(vs_base[0]); if (vs_base[0]->pn.pn_name==Cnil && vs_base[0]->pn.pn_type==Cnil) { ! coerce_to_filename(vs_base[0], filename); strcat(filename, "*"); } else if (vs_base[0]->pn.pn_name==Cnil) { vs_base[0]->pn.pn_name = sKwild; ! coerce_to_filename(vs_base[0], filename); vs_base[0]->pn.pn_name = Cnil; } else if (vs_base[0]->pn.pn_type==Cnil) { ! coerce_to_filename(vs_base[0], filename); strcat(filename, "*"); } else ! coerce_to_filename(vs_base[0], filename); ! sprintf(command, "ls -d %s 2> /dev/null", filename); fp = popen(command, "r"); setbuf(fp, iobuffer); for (;;) { --- 486,549 ---- } + extern int pathname_resolve(); #ifdef BSD LFD(Ldirectory)(void) { char filename[MAXPATHLEN]; ! char command[MAXPATHLEN * 3]; FILE *fp; register int i, c; ! object *top; char iobuffer[BUFSIZ]; extern FILE *popen(const char *, const char *); + int wildversion=0; ! if (vs_top - vs_base < 1) ! too_few_arguments(); ! while (vs_top - vs_base > 1) ! vs_popp; ! ! top = vs_top; check_type_or_pathname_string_symbol_stream(&vs_base[0]); vs_base[0] = coerce_to_pathname(vs_base[0]); + + if (pathname_resolve(sKversion) && + (vs_base[0]->pn.pn_version == sKwild)) { + wildversion=1; + vs_base[0]->pn.pn_version = Cnil; + } if (vs_base[0]->pn.pn_name==Cnil && vs_base[0]->pn.pn_type==Cnil) { ! coerce_to_local_filename(vs_base[0], filename); strcat(filename, "*"); + if (wildversion) + vs_base[0]->pn.pn_version = sKwild; + wildversion=0; } else if (vs_base[0]->pn.pn_name==Cnil) { vs_base[0]->pn.pn_name = sKwild; ! coerce_to_local_filename(vs_base[0], filename); vs_base[0]->pn.pn_name = Cnil; } else if (vs_base[0]->pn.pn_type==Cnil) { ! coerce_to_local_filename(vs_base[0], filename); strcat(filename, "*"); + if (wildversion) + vs_base[0]->pn.pn_version = sKwild; + wildversion=0; } else ! coerce_to_local_filename(vs_base[0], filename); ! ! sprintf(command, "ls -d %s %s%s 2> /dev/null", ! filename, ! (wildversion ? filename : ""), ! (wildversion ? ".*" : "")); ! ! if (wildversion) { ! vs_base[0]->pn.pn_version = sKwild; ! wildversion=0; ! } ! fp = popen(command, "r"); setbuf(fp, iobuffer); for (;;) { *************** LFD(Ldirectory)() *** 586,603 **** char iobuffer[BUFSIZ]; struct direct dir; int i; check_arg(1); check_type_or_pathname_string_symbol_stream(&vs_base[0]); vs_base[0] = coerce_to_pathname(vs_base[0]); vs_push(vs_base[0]->pn.pn_name); vs_push(vs_base[0]->pn.pn_type); vs_base[0]->pn.pn_name = Cnil; vs_base[0]->pn.pn_type = Cnil; ! coerce_to_filename(vs_base[0], filename); type = vs_base[0]->pn.pn_type = vs_pop; name = vs_base[0]->pn.pn_name = vs_pop; i = strlen(filename); if (i > 1 && filename[i-1] == '/') filename[i-1] = '\0'; --- 578,606 ---- char iobuffer[BUFSIZ]; struct direct dir; int i; + int wildversion=0; check_arg(1); check_type_or_pathname_string_symbol_stream(&vs_base[0]); vs_base[0] = coerce_to_pathname(vs_base[0]); + + if (pathname_resolve(sKversion) && + (vs_base[0]->pn.pn_version == sKwild)) { + wildversion=1; + vs_base[0]->pn.pn_version = Cnil; + } vs_push(vs_base[0]->pn.pn_name); vs_push(vs_base[0]->pn.pn_type); vs_base[0]->pn.pn_name = Cnil; vs_base[0]->pn.pn_type = Cnil; ! coerce_to_local_filename(vs_base[0], filename); type = vs_base[0]->pn.pn_type = vs_pop; name = vs_base[0]->pn.pn_name = vs_pop; + if (wildversion) { + vs_base[0]->pn.pn_version = sKwild; + wildversion=0; + } i = strlen(filename); if (i > 1 && filename[i-1] == '/') filename[i-1] = '\0'; *************** LFD(Ldirectory)() *** 651,668 **** char iobuffer[BUFSIZ]; struct direct dir; int i; check_arg(1); check_type_or_pathname_string_symbol_stream(&vs_base[0]); vs_base[0] = coerce_to_pathname(vs_base[0]); vs_push(vs_base[0]->pn.pn_name); vs_push(vs_base[0]->pn.pn_type); vs_base[0]->pn.pn_name = Cnil; vs_base[0]->pn.pn_type = Cnil; ! coerce_to_filename(vs_base[0], filename); type = vs_base[0]->pn.pn_type = vs_pop; name = vs_base[0]->pn.pn_name = vs_pop; i = strlen(filename); if (i > 1 && filename[i-1] == '/') filename[i-1] = '\0'; --- 654,682 ---- char iobuffer[BUFSIZ]; struct direct dir; int i; + int wildversion=0; check_arg(1); check_type_or_pathname_string_symbol_stream(&vs_base[0]); vs_base[0] = coerce_to_pathname(vs_base[0]); + + if (pathname_resolve(sKversion) && + (vs_base[0]->pn.pn_version == sKwild)) { + wildversion=1; + vs_base[0]->pn.pn_version = Cnil; + } vs_push(vs_base[0]->pn.pn_name); vs_push(vs_base[0]->pn.pn_type); vs_base[0]->pn.pn_name = Cnil; vs_base[0]->pn.pn_type = Cnil; ! coerce_to_local_filename(vs_base[0], filename); type = vs_base[0]->pn.pn_type = vs_pop; name = vs_base[0]->pn.pn_name = vs_pop; + if (wildversion) { + vs_base[0]->pn.pn_version = sKwild; + wildversion=0; + } i = strlen(filename); if (i > 1 && filename[i-1] == '/') filename[i-1] = '\0'; *************** FFN(siLchdir)(void) *** 762,768 **** check_arg(1); check_type_or_pathname_string_symbol_stream(&vs_base[0]); ! coerce_to_filename(vs_base[0], filename); if (chdir(filename) < 0) FEerror("Can't change the current directory to ~S.", --- 776,782 ---- check_arg(1); check_type_or_pathname_string_symbol_stream(&vs_base[0]); ! coerce_to_local_filename(vs_base[0], filename); if (chdir(filename) < 0) FEerror("Can't change the current directory to ~S.", *** ../gcl-cvs/./pcl/sys-package.lisp Fri Oct 10 05:35:54 2003 --- ./pcl/sys-package.lisp Wed May 19 14:15:44 2004 *************** *** 201,206 **** --- 201,208 ---- LISP::SET-MACRO-CHARACTER LISP::GET-MACRO-CHARACTER LISP::*BREAK-ON-WARNINGS* LISP::INPUT-STREAM-P LISP::*PRINT-PRETTY* LISP::*QUERY-IO* LISP::*PRINT-ARRAY* + LISP::*PRINT-LINES* LISP::*PRINT-MISER-WIDTH* + LISP::*PRINT-RIGHT-MARGIN* LISP::*READ-EVAL* LISP::DEFCFUN LISP::*LOAD-VERBOSE* LISP::FIND-IF LISP::POSITION LISP::MAKE-SEQUENCE LISP::TAG LISP::BOOLE-C2 LISP::SET-DISPATCH-MACRO-CHARACTER *************** *** 392,398 **** LISP::ED LISP::BOOLE-1 LISP::BOOLE-NAND LISP::BSD386 LISP::REAL LISP::&AUX LISP::GETHASH LISP::CLEAR-OUTPUT LISP::COMPLEXP LISP::STEP LISP::*STANDARD-INPUT* LISP::APPLY ! LISP::WITH-OPEN-STREAM LISP::ECASE LISP::&REST LISP::CCASE LISP::FCEILING LISP::CLRHASH LISP::PARSE-INTEGER LISP::LOGANDC2 LISP::COUNT LISP::DIRECTORY-NAMESTRING LISP::PRIN1 LISP::READ LISP::CDDR LISP::SGC LISP::SAVE --- 394,403 ---- LISP::ED LISP::BOOLE-1 LISP::BOOLE-NAND LISP::BSD386 LISP::REAL LISP::&AUX LISP::GETHASH LISP::CLEAR-OUTPUT LISP::COMPLEXP LISP::STEP LISP::*STANDARD-INPUT* LISP::APPLY ! LISP::WITH-OPEN-STREAM LISP::WITH-STANDARD-IO-SYNTAX ! LISP::LOGICAL-PATHNAME-TRANSLATIONS ! LISP::SET-LOGICAL-PATHNAME-TRANSLATIONS ! LISP::ECASE LISP::&REST LISP::CCASE LISP::FCEILING LISP::CLRHASH LISP::PARSE-INTEGER LISP::LOGANDC2 LISP::COUNT LISP::DIRECTORY-NAMESTRING LISP::PRIN1 LISP::READ LISP::CDDR LISP::SGC LISP::SAVE *************** *** 479,484 **** --- 484,490 ---- LISP::LOGNAND LISP::TYPECASE LISP::SIMPLE-STRING-P LISP::SIMPLE-STRING LISP::SUBSTITUTE-IF-NOT LISP::CAAR LISP::RASSOC LISP::PARSE-NAMESTRING LISP::*MACROEXPAND-HOOK* + LISP::WILD-PATHNAME-P LISP::PATHNAME-MATCH-P LISP::MAP LISP::COND LISP::SIMPLE-WARNING LISP::T LISP::SPECIAL-FORM-P LISP::DESCRIBE LISP::RETURN-FROM LISP::CTYPECASE LISP::ETYPECASE LISP::SOME LISP::LABELS *************** *** 514,520 **** LISP::PRINC LISP::SIMPLE-VECTOR LISP::NSUBST LISP::FBOUNDP LISP::SIMPLE-STRING LISP::SPICE LISP::TRACE LISP::METHOD-COMBINATION LISP::BOUNDP LISP::SYMBOL-NAME ! LISP::WITH-OPEN-STREAM LISP::UNSIGNED-BYTE LISP::HELP* LISP::NOTINLINE LISP::GET-MACRO-CHARACTER LISP::SET-MACRO-CHARACTER LISP::POP LISP::LIST-ALL-PACKAGES WALKER::VARIABLE-DECLARATION LISP::UNDEFINED-FUNCTION --- 520,529 ---- LISP::PRINC LISP::SIMPLE-VECTOR LISP::NSUBST LISP::FBOUNDP LISP::SIMPLE-STRING LISP::SPICE LISP::TRACE LISP::METHOD-COMBINATION LISP::BOUNDP LISP::SYMBOL-NAME ! LISP::WITH-OPEN-STREAM LISP::WITH-STANDARD-IO-SYNTAX ! LISP::LOGICAL-PATHNAME-TRANSLATIONS ! LISP::SET-LOGICAL-PATHNAME-TRANSLATIONS ! LISP::UNSIGNED-BYTE LISP::HELP* LISP::NOTINLINE LISP::GET-MACRO-CHARACTER LISP::SET-MACRO-CHARACTER LISP::POP LISP::LIST-ALL-PACKAGES WALKER::VARIABLE-DECLARATION LISP::UNDEFINED-FUNCTION *************** *** 548,553 **** --- 557,563 ---- LISP::++ LISP::LIST* LISP::STRING< LISP::SOFTWARE-VERSION LISP::*GENSYM-COUNTER* LISP::REMOVE-DUPLICATES LISP::PARSE-NAMESTRING LISP::UPPER-CASE-P + LISP::WILD-PATHNAME-P LISP::PATHNAME-MATCH-P LISP::MAKE-CONCATENATED-STREAM LISP::DO-EXTERNAL-SYMBOLS LISP::CONCATENATE LISP::CHAR-CONTROL-BIT LISP::WARN LISP::BIGNUM LISP::SIMPLE-VECTOR-P LISP::DELETE-DUPLICATES *************** *** 586,591 **** --- 596,603 ---- LISP::PLUSP LISP::CASE LISP::MACHINE-TYPE LISP::LOAD LISP::ENDP LISP::FRESH-LINE LISP::DEFCONSTANT LISP::SYMBOL LISP::VALUES LISP::SET-DIFFERENCE LISP::*PRINT-ARRAY* + LISP::*PRINT-LINES* LISP::*PRINT-MISER-WIDTH* + LISP::*PRINT-RIGHT-MARGIN* LISP::*READ-EVAL* LISP::SET-EXCLUSIVE-OR LISP::PROG2 LISP::DIVISION-BY-ZERO LISP::PHASE LISP::CAAAR LISP::ETYPECASE LISP::CTYPECASE LISP::NOT LISP::BOOLE-C2 LISP::NTH LISP::SPECIAL-OPERATOR-P *************** *** 822,828 **** LISP::PRINC LISP::SIMPLE-VECTOR LISP::NSUBST LISP::FBOUNDP LISP::SIMPLE-STRING LISP::SPICE LISP::TRACE LISP::METHOD-COMBINATION LISP::BOUNDP LISP::SYMBOL-NAME ! LISP::WITH-OPEN-STREAM LISP::UNSIGNED-BYTE LISP::HELP* LISP::NOTINLINE LISP::GET-MACRO-CHARACTER LISP::SET-MACRO-CHARACTER LISP::POP LISP::LIST-ALL-PACKAGES LISP::UNDEFINED-FUNCTION LISP::IEEE-FLOATING-POINT --- 834,843 ---- LISP::PRINC LISP::SIMPLE-VECTOR LISP::NSUBST LISP::FBOUNDP LISP::SIMPLE-STRING LISP::SPICE LISP::TRACE LISP::METHOD-COMBINATION LISP::BOUNDP LISP::SYMBOL-NAME ! LISP::WITH-OPEN-STREAM LISP::WITH-STANDARD-IO-SYNTAX ! LISP::LOGICAL-PATHNAME-TRANSLATIONS ! LISP::SET-LOGICAL-PATHNAME-TRANSLATIONS ! LISP::UNSIGNED-BYTE LISP::HELP* LISP::NOTINLINE LISP::GET-MACRO-CHARACTER LISP::SET-MACRO-CHARACTER LISP::POP LISP::LIST-ALL-PACKAGES LISP::UNDEFINED-FUNCTION LISP::IEEE-FLOATING-POINT *************** *** 856,861 **** --- 871,877 ---- LISP::++ LISP::LIST* LISP::STRING< LISP::SOFTWARE-VERSION LISP::*GENSYM-COUNTER* LISP::REMOVE-DUPLICATES LISP::PARSE-NAMESTRING LISP::UPPER-CASE-P + LISP::WILD-PATHNAME-P LISP::PATHNAME-MATCH-P LISP::MAKE-CONCATENATED-STREAM LISP::DO-EXTERNAL-SYMBOLS LISP::CONCATENATE LISP::CHAR-CONTROL-BIT LISP::WARN LISP::BIGNUM LISP::SIMPLE-VECTOR-P LISP::DELETE-DUPLICATES *************** *** 894,899 **** --- 910,917 ---- LISP::PLUSP LISP::CASE LISP::MACHINE-TYPE LISP::LOAD LISP::ENDP LISP::FRESH-LINE LISP::DEFCONSTANT LISP::SYMBOL LISP::VALUES LISP::SET-DIFFERENCE LISP::*PRINT-ARRAY* + LISP::*PRINT-LINES* LISP::*PRINT-MISER-WIDTH* + LISP::*PRINT-RIGHT-MARGIN* LISP::*READ-EVAL* LISP::SET-EXCLUSIVE-OR LISP::PROG2 LISP::DIVISION-BY-ZERO LISP::PHASE LISP::CAAAR LISP::ETYPECASE LISP::CTYPECASE LISP::NOT LISP::BOOLE-C2 LISP::NTH LISP::SPECIAL-OPERATOR-P *************** *** 1158,1164 **** LISP::DOUBLE-FLOAT-EPSILON LISP::DOUBLE-FLOAT-NEGATIVE-EPSILON LISP::BOOLE-IOR LISP::ASSERT LISP::ADJUSTABLE-ARRAY-P LISP::COPY-TREE LISP::CLEAR-OUTPUT LISP::CODE-CHAR ! LISP::STRING-CAPITALIZE LISP::/// LISP::WITH-OPEN-STREAM SYSTEM::*INFO-WINDOW* LISP::REST LISP::ACOS LISP::MACHINE-TYPE LISP::DENOMINATOR LISP::TRACE LISP::FLOATING-POINT-INEXACT LISP::*READ-BASE* LISP::CDR SYSTEM::BEGIN LISP::STRING-EQUAL --- 1176,1185 ---- LISP::DOUBLE-FLOAT-EPSILON LISP::DOUBLE-FLOAT-NEGATIVE-EPSILON LISP::BOOLE-IOR LISP::ASSERT LISP::ADJUSTABLE-ARRAY-P LISP::COPY-TREE LISP::CLEAR-OUTPUT LISP::CODE-CHAR ! LISP::STRING-CAPITALIZE LISP::/// ! LISP::WITH-OPEN-STREAM LISP::WITH-STANDARD-IO-SYNTAX ! LISP::LOGICAL-PATHNAME-TRANSLATIONS ! LISP::SET-LOGICAL-PATHNAME-TRANSLATIONS SYSTEM::*INFO-WINDOW* LISP::REST LISP::ACOS LISP::MACHINE-TYPE LISP::DENOMINATOR LISP::TRACE LISP::FLOATING-POINT-INEXACT LISP::*READ-BASE* LISP::CDR SYSTEM::BEGIN LISP::STRING-EQUAL *************** *** 1214,1219 **** --- 1235,1242 ---- LISP::*MACROEXPAND-HOOK* LISP::PLUSP LISP::INTERNAL-TIME-UNITS-PER-SECOND LISP::LIST* LISP::*PRINT-ARRAY* LISP::FILE-WRITE-DATE LISP::LAMBDA + LISP::*PRINT-LINES* LISP::*PRINT-MISER-WIDTH* + LISP::*PRINT-RIGHT-MARGIN* LISP::*READ-EVAL* LISP::ED LISP::OPEN LISP::AREF LISP::RASSOC-IF LISP::LOGORC1 LISP::PROCLAIM LISP::CHAR-SUPER-BIT LISP::APPEND LISP::CONCATENATE LISP::WRITE-STRING LISP::MISMATCH *************** *** 1325,1330 **** --- 1348,1354 ---- LISP::AKCL LISP::FLOOR LISP::GBC LISP::GENSYM LISP::ARRAY-HAS-FILL-POINTER-P LISP::LOGIOR LISP::Y-OR-N-P LISP::CHAR-FONT LISP::PARSE-NAMESTRING LISP::ARRAY-RANK + LISP::WILD-PATHNAME-P LISP::PATHNAME-MATCH-P LISP::NINTH LISP::EVALHOOK LISP::WITH-INPUT-FROM-STRING LISP::INTEGER LISP::MAKE-SEQUENCE SYSTEM::*MATCH-DATA* LISP::SET-EXCLUSIVE-OR LISP::CHAR< LISP::INLINE LISP::CDDADR *************** *** 1473,1479 **** LISP::DOUBLE-FLOAT-EPSILON LISP::DOUBLE-FLOAT-NEGATIVE-EPSILON LISP::BOOLE-IOR LISP::ASSERT LISP::ADJUSTABLE-ARRAY-P LISP::COPY-TREE LISP::CLEAR-OUTPUT LISP::CODE-CHAR ! LISP::STRING-CAPITALIZE LISP::/// LISP::WITH-OPEN-STREAM LISP::REST LISP::ACOS LISP::MACHINE-TYPE LISP::DENOMINATOR LISP::TRACE LISP::FLOATING-POINT-INEXACT LISP::*READ-BASE* LISP::CDR LISP::STRING-EQUAL LISP::GMP LISP::DELETE-FILE --- 1497,1506 ---- LISP::DOUBLE-FLOAT-EPSILON LISP::DOUBLE-FLOAT-NEGATIVE-EPSILON LISP::BOOLE-IOR LISP::ASSERT LISP::ADJUSTABLE-ARRAY-P LISP::COPY-TREE LISP::CLEAR-OUTPUT LISP::CODE-CHAR ! LISP::STRING-CAPITALIZE LISP::/// ! LISP::WITH-OPEN-STREAM LISP::WITH-STANDARD-IO-SYNTAX ! LISP::LOGICAL-PATHNAME-TRANSLATIONS ! LISP::SET-LOGICAL-PATHNAME-TRANSLATIONS LISP::REST LISP::ACOS LISP::MACHINE-TYPE LISP::DENOMINATOR LISP::TRACE LISP::FLOATING-POINT-INEXACT LISP::*READ-BASE* LISP::CDR LISP::STRING-EQUAL LISP::GMP LISP::DELETE-FILE *************** *** 1526,1531 **** --- 1553,1560 ---- LISP::MULTIPLE-VALUE-CALL LISP::*MACROEXPAND-HOOK* LISP::PLUSP LISP::INTERNAL-TIME-UNITS-PER-SECOND LISP::LIST* LISP::*PRINT-ARRAY* LISP::FILE-WRITE-DATE LISP::LAMBDA + LISP::*PRINT-LINES* LISP::*PRINT-MISER-WIDTH* + LISP::*PRINT-RIGHT-MARGIN* LISP::*READ-EVAL* LISP::ED LISP::OPEN LISP::AREF LISP::RASSOC-IF LISP::LOGORC1 LISP::PROCLAIM LISP::CHAR-SUPER-BIT LISP::APPEND LISP::CONCATENATE LISP::WRITE-STRING LISP::MISMATCH *************** *** 1638,1643 **** --- 1667,1673 ---- LISP::AKCL LISP::FLOOR LISP::GBC LISP::GENSYM LISP::ARRAY-HAS-FILL-POINTER-P LISP::LOGIOR LISP::Y-OR-N-P LISP::CHAR-FONT LISP::PARSE-NAMESTRING LISP::ARRAY-RANK + LISP::WILD-PATHNAME-P LISP::PATHNAME-MATCH-P LISP::NINTH LISP::EVALHOOK LISP::WITH-INPUT-FROM-STRING LISP::INTEGER LISP::MAKE-SEQUENCE LISP::SET-EXCLUSIVE-OR LISP::CHAR< LISP::INLINE LISP::CDDADR LISP::REMOVE-IF-NOT *************** *** 1782,1788 **** LISP::DOUBLE-FLOAT-EPSILON LISP::DOUBLE-FLOAT-NEGATIVE-EPSILON LISP::BOOLE-IOR LISP::ASSERT LISP::ADJUSTABLE-ARRAY-P LISP::COPY-TREE LISP::CLEAR-OUTPUT LISP::CODE-CHAR ! LISP::STRING-CAPITALIZE LISP::/// LISP::WITH-OPEN-STREAM LISP::REST LISP::ACOS LISP::MACHINE-TYPE LISP::DENOMINATOR LISP::TRACE LISP::FLOATING-POINT-INEXACT LISP::*READ-BASE* LISP::CDR LISP::STRING-EQUAL LISP::GMP LISP::DELETE-FILE --- 1812,1821 ---- LISP::DOUBLE-FLOAT-EPSILON LISP::DOUBLE-FLOAT-NEGATIVE-EPSILON LISP::BOOLE-IOR LISP::ASSERT LISP::ADJUSTABLE-ARRAY-P LISP::COPY-TREE LISP::CLEAR-OUTPUT LISP::CODE-CHAR ! LISP::STRING-CAPITALIZE LISP::/// ! LISP::WITH-OPEN-STREAM LISP::WITH-STANDARD-IO-SYNTAX ! LISP::LOGICAL-PATHNAME-TRANSLATIONS ! LISP::SET-LOGICAL-PATHNAME-TRANSLATIONS LISP::REST LISP::ACOS LISP::MACHINE-TYPE LISP::DENOMINATOR LISP::TRACE LISP::FLOATING-POINT-INEXACT LISP::*READ-BASE* LISP::CDR LISP::STRING-EQUAL LISP::GMP LISP::DELETE-FILE *************** *** 1833,1838 **** --- 1866,1873 ---- LISP::MULTIPLE-VALUE-CALL LISP::*MACROEXPAND-HOOK* LISP::PLUSP LISP::INTERNAL-TIME-UNITS-PER-SECOND LISP::LIST* LISP::*PRINT-ARRAY* LISP::FILE-WRITE-DATE LISP::LAMBDA + LISP::*PRINT-LINES* LISP::*PRINT-MISER-WIDTH* + LISP::*PRINT-RIGHT-MARGIN* LISP::*READ-EVAL* LISP::ED LISP::OPEN LISP::AREF LISP::RASSOC-IF LISP::LOGORC1 LISP::PROCLAIM LISP::CHAR-SUPER-BIT LISP::APPEND LISP::CONCATENATE LISP::WRITE-STRING LISP::MISMATCH *************** *** 1945,1950 **** --- 1980,1986 ---- LISP::AKCL LISP::FLOOR LISP::GBC LISP::GENSYM LISP::ARRAY-HAS-FILL-POINTER-P LISP::LOGIOR LISP::Y-OR-N-P LISP::CHAR-FONT LISP::PARSE-NAMESTRING LISP::ARRAY-RANK + LISP::WILD-PATHNAME-P LISP::PATHNAME-MATCH-P LISP::NINTH LISP::EVALHOOK LISP::WITH-INPUT-FROM-STRING LISP::INTEGER LISP::MAKE-SEQUENCE LISP::SET-EXCLUSIVE-OR LISP::CHAR< LISP::INLINE LISP::CDDADR LISP::REMOVE-IF-NOT *************** *** 2088,2094 **** LISP::DOUBLE-FLOAT-EPSILON LISP::DOUBLE-FLOAT-NEGATIVE-EPSILON LISP::BOOLE-IOR LISP::ASSERT LISP::ADJUSTABLE-ARRAY-P LISP::COPY-TREE LISP::CLEAR-OUTPUT LISP::CODE-CHAR ! LISP::STRING-CAPITALIZE LISP::/// LISP::WITH-OPEN-STREAM LISP::REST LISP::ACOS LISP::MACHINE-TYPE LISP::DENOMINATOR LISP::TRACE LISP::FLOATING-POINT-INEXACT LISP::*READ-BASE* LISP::CDR LISP::STRING-EQUAL LISP::GMP LISP::DELETE-FILE --- 2124,2133 ---- LISP::DOUBLE-FLOAT-EPSILON LISP::DOUBLE-FLOAT-NEGATIVE-EPSILON LISP::BOOLE-IOR LISP::ASSERT LISP::ADJUSTABLE-ARRAY-P LISP::COPY-TREE LISP::CLEAR-OUTPUT LISP::CODE-CHAR ! LISP::STRING-CAPITALIZE LISP::/// ! LISP::WITH-OPEN-STREAM LISP::WITH-STANDARD-IO-SYNTAX ! LISP::LOGICAL-PATHNAME-TRANSLATIONS ! LISP::SET-LOGICAL-PATHNAME-TRANSLATIONS LISP::REST LISP::ACOS LISP::MACHINE-TYPE LISP::DENOMINATOR LISP::TRACE LISP::FLOATING-POINT-INEXACT LISP::*READ-BASE* LISP::CDR LISP::STRING-EQUAL LISP::GMP LISP::DELETE-FILE *************** *** 2141,2146 **** --- 2180,2187 ---- LISP::MULTIPLE-VALUE-CALL LISP::*MACROEXPAND-HOOK* LISP::PLUSP LISP::INTERNAL-TIME-UNITS-PER-SECOND LISP::LIST* LISP::*PRINT-ARRAY* LISP::FILE-WRITE-DATE LISP::LAMBDA + LISP::*PRINT-LINES* LISP::*PRINT-MISER-WIDTH* + LISP::*PRINT-RIGHT-MARGIN* LISP::*READ-EVAL* LISP::ED LISP::OPEN LISP::AREF LISP::RASSOC-IF LISP::LOGORC1 LISP::PROCLAIM LISP::CHAR-SUPER-BIT LISP::APPEND LISP::CONCATENATE LISP::WRITE-STRING LISP::MISMATCH *************** *** 2253,2258 **** --- 2294,2300 ---- LISP::AKCL LISP::FLOOR LISP::GBC LISP::GENSYM LISP::ARRAY-HAS-FILL-POINTER-P LISP::LOGIOR LISP::Y-OR-N-P LISP::CHAR-FONT LISP::PARSE-NAMESTRING LISP::ARRAY-RANK + LISP::WILD-PATHNAME-P LISP::PATHNAME-MATCH-P LISP::NINTH LISP::EVALHOOK LISP::WITH-INPUT-FROM-STRING LISP::INTEGER LISP::MAKE-SEQUENCE LISP::SET-EXCLUSIVE-OR LISP::CHAR< LISP::INLINE LISP::CDDADR LISP::REMOVE-IF-NOT *** ../gcl-cvs/./unixport/makefile Sat Mar 20 03:20:52 2004 --- ./unixport/makefile Fri May 21 20:41:43 2004 *************** saved_%:raw_% $(RSYM) init_%.lsp raw_%_m *** 114,120 **** $(LSPDIR)/gcl_auto_new.lsp cp init_$*.lsp foo ! echo " (in-package \"USER\")(system:save-system \"address@hidden")" >>foo $(PORTDIR)/raw_$*$(EXE) $(PORTDIR)/ -libdir $(GCLDIR)/ < foo $(RSYM): $(SPECIAL_RSYM) $(HDIR)/mdefs.h --- 114,120 ---- $(LSPDIR)/gcl_auto_new.lsp cp init_$*.lsp foo ! echo " (in-package \"USER\")(format t \"~%Saving System~%\")(system:save-system \"address@hidden")" >>foo $(PORTDIR)/raw_$*$(EXE) $(PORTDIR)/ -libdir $(GCLDIR)/ < foo $(RSYM): $(SPECIAL_RSYM) $(HDIR)/mdefs.h *************** clean: *** 178,181 **** gazonk*.lsp plt*h *_map .INTERMEDIATE: init_ansi_gcl.lsp.tmp init_gcl.lsp.tmp raw_gcl raw_ansi_gcl ! .PRECIOUS: init_gcl.lsp init_ansi_gcl.lsp \ No newline at end of file --- 178,181 ---- gazonk*.lsp plt*h *_map .INTERMEDIATE: init_ansi_gcl.lsp.tmp init_gcl.lsp.tmp raw_gcl raw_ansi_gcl ! .PRECIOUS: init_gcl.lsp init_ansi_gcl.lsp *** /dev/null Thu May 13 04:09:21 2004 --- ./ansi-tests/gclload0.lsp Wed May 19 14:15:44 2004 *************** *** 0 **** --- 1,15 ---- + ;;; Uncomment the next line to make MAKE-STRING and MAKE-SEQUENCE + ;;; tests require that a missing :initial-element argument defaults + ;;; to a single value, rather than leaving the string/sequence filled + ;;; with arbitrary legal garbage. + ;; (pushnew :ansi-tests-strict-initial-element *features*) + + #+(and clisp (or win32 cygwin)) ; w2k exits on (disassemble 'car) + (without-package-lock ("SYS") + (defun sys::disassemble-machine-code (a b c) + (format t "~&<~S ~S ~S>~%" a b c))) + + #+allegro (run-shell-command "rm -f *.fasl") + #+cmucl (run-program "rm -f *.x86f") + + (load "gclload1.lsp") *** /dev/null Thu May 13 04:09:21 2004 --- ./ansi-tests/gclload3.lsp Wed May 19 14:15:44 2004 *************** *** 0 **** --- 1,13 ---- + #+allegro + (progn + (rt:disable-note :nil-vectors-are-strings) + (rt:disable-note :standardized-package-nicknames) + (rt:disable-note :type-of/strict-builtins) + (rt:disable-note :assume-no-simple-streams) + (rt:disable-note :assume-no-gray-streams)) + + (in-package :cl-test) + (time (regression-test:do-tests)) + + #+allegro (cl-user::exit) + #+(or cmucl sbcl gcl armedbear) (cl-user::quit)