-
Notifications
You must be signed in to change notification settings - Fork 0
/
gclrc.lisp
128 lines (109 loc) · 4.82 KB
/
gclrc.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
;;;;**************************************************************************
;;;;FILE: .gclrc.lisp
;;;;LANGUAGE: Common-Lisp
;;;;SYSTEM: gcl
;;;;USER-INTERFACE: None
;;;;DESCRIPTION
;;;;
;;;; The gcl init file.
;;;;
;;;;AUTHORS
;;;; <PJB> Pascal Bourguignon
;;;;MODIFICATIONS
;;;; 2013-07-01 <PJB> Revised.
;;;; 2005-07-19 <PJB> Created.
;;;;BUGS
;;;;LEGAL
;;;; GPL
;;;;
;;;; Copyright Pascal Bourguignon 2005 - 2013
;;;; mailto:pjb@informatimago.com
;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU General Public License
;;;; as published by the Free Software Foundation; either version
;;;; 2 of the License, or (at your option) any later version.
;;;;
;;;; This program 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 General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public
;;----------------------------------------------------------------------
;; Setting environment -- gcl part --
;; ----------------------------------
(in-package "USER")
(RENAME-PACKAGE "LISP" "LISP" (list* "CL" "COMMON-LISP"
(copy-seq (PACKAGE-NICKNAMES "LISP"))))
(RENAME-PACKAGE "USER" "USER" (list* "CL-USER" "COMMON-LISP-USER"
(copy-seq (PACKAGE-NICKNAMES "USER"))))
(in-package "COMMON-LISP-USER")
#||
(defun post-process-logical-pathname-translations (host)
(flet ((pstring (x) (if (pathnamep x) (namestring x) (string x))))
(setf (logical-pathname-translations host)
(sort (remove-if
(lambda (p) (let ((p (pstring p)))
(and (< 5 (length p))
(string= "*.*.*" p :start2 (- (length p) 5)))))
(logical-pathname-translations host)
:key (function first))
(lambda (a b) (> (length (pstring (first a)))
(length (pstring (first b)))))))))
||#
;;----------------------------------------------------------------------
;; Setting environment -- COMMON-LISP part --
;; ------------------------------------------
(defun mixed-case-p (string)
"
RETURN: Whether the STRING contains both upper case characters
and lower case characters. If there are characters
that are both-case-p, then mixed-case-p returns true.
"
(and (some (function upper-case-p) string)
(some (function lower-case-p) string)))
(defvar *original-make-pathname* (function make-pathname))
(defun make-pathname (&rest arguments &key directory (case :local) &allow-other-keys)
(when directory
(ecase (first directory)
((:relative) (pop directory))
((:absolute) (pop directory) (push "" directory))))
(ecase case
((:local)
(apply *original-make-pathname* :allow-other-keys t arguments))
((:common)
(let ((arguments (mapcar (lambda (argument)
(flet ((convert (argument)
(if (stringp argument)
(if (mixed-case-p argument)
(error "~S is not in :COMMON case." argument)
(string-downcase argument))
argument)))
(typecase argument
(string (convert argument))
(list (mapcar (function convert) argument))
(t argument))))
(if directory
(list* :directory directory arguments)
arguments))))
(apply *original-make-pathname* :allow-other-keys t arguments)))))
(SETF *LOAD-VERBOSE* t)
(LOAD (MERGE-PATHNAMES
(MAKE-PATHNAME :DIRECTORY '(:RELATIVE "RC") :NAME "COMMON" :TYPE "LISP"
:CASE :COMMON)
(USER-HOMEDIR-PATHNAME)
NIL))
(IN-PACKAGE "COM.INFORMATIMAGO.PJB")
;; additional export at the end.
;;----------------------------------------------------------------------
;; Setting environment -- gcl specific --
;; --------------------------------------
(DEFUN QUIT () (EXT:QUIT))
(EXPORT 'QUIT)
;;----------------------------------------------------------------------
;;(format *trace-output* "~&.gclrc.lisp loaded~%")
;;----------------------------------------------------------------------
(IN-PACKAGE "COMMON-LISP-USER")
(USE-PACKAGE "COM.INFORMATIMAGO.PJB")
;;----------------------------------------------------------------------