... |
... |
@@ -9,321 +9,124 @@ |
9
|
9
|
(invoke-restart 'continue))))
|
10
|
10
|
(defconstant +ef-max+ 14))
|
11
|
11
|
|
12
|
|
-
|
13
|
|
-;; For issue #390. Initialize the new UNIX package with ERRNO stuff.
|
14
|
|
-;; Without this we need to disable package locks in code:exports.lisp
|
15
|
|
-;; when defining the UNIX package and that removes the ability to
|
16
|
|
-;; detect changes in the UNIX package.
|
17
|
|
-(in-package "LISP")
|
18
|
|
-(load "src/code/exports-errno")
|
19
|
|
-(ext:without-package-locks
|
20
|
|
- ;; Define macro to create the UNIX package that also shadow imports
|
21
|
|
- ;; the symbols from ERRNO and also exports them again. This is
|
22
|
|
- ;; needed so that we don't get a warning about UNIX shadowing all
|
23
|
|
- ;; the symbols from ERRNO and a warning that UNIX exports all the
|
24
|
|
- ;; symbols from ERRNO too.
|
25
|
|
- (defmacro define-unix-package (&body body)
|
26
|
|
- (let (errno-symbols)
|
27
|
|
- (do-external-symbols (sym "ERRNO")
|
28
|
|
- (push (symbol-name sym) errno-symbols))
|
29
|
|
- `(ext:without-package-locks
|
30
|
|
- (defpackage "UNIX"
|
31
|
|
- (:shadowing-import-from "ERRNO" ,@errno-symbols)
|
32
|
|
- (:export ,@errno-symbols)
|
33
|
|
- ,@body)))))
|
34
|
|
-
|
35
|
|
-(define-unix-package
|
36
|
|
- (:export "UNIX-CURRENT-DIRECTORY"
|
37
|
|
- "UNIX-OPEN"
|
38
|
|
- "UNIX-READ"
|
39
|
|
- "UNIX-WRITE"
|
40
|
|
- "UNIX-GETPAGESIZE"
|
41
|
|
- "UNIX-ERRNO"
|
42
|
|
- "UNIX-MAYBE-PREPEND-CURRENT-DIRECTORY"
|
43
|
|
- "UNIX-RESOLVE-LINKS"
|
44
|
|
- "UNIX-REALPATH"
|
45
|
|
- "UNIX-CLOSE"
|
46
|
|
- "UNIX-STAT"
|
47
|
|
- "UNIX-LSTAT"
|
48
|
|
- "UNIX-FSTAT"
|
49
|
|
- "UNIX-GETHOSTNAME"
|
50
|
|
- "UNIX-LSEEK"
|
51
|
|
- "UNIX-EXIT"
|
52
|
|
- "UNIX-CHDIR"
|
53
|
|
- "UNIX-ACCESS"
|
54
|
|
- "UNIX-DUP"
|
55
|
|
- "UNIX-CHMOD"
|
56
|
|
- "UNIX-READLINK"
|
57
|
|
- "UNIX-RENAME"
|
58
|
|
- "UNIX-SELECT"
|
59
|
|
- "UNIX-FAST-GETRUSAGE"
|
60
|
|
- "UNIX-GETRUSAGE"
|
61
|
|
- "UNIX-GETTIMEOFDAY"
|
62
|
|
- "UNIX-ISATTY"
|
63
|
|
- "UNIX-MKDIR"
|
64
|
|
- "UNIX-RMDIR"
|
65
|
|
- "UNIX-UNLINK"
|
66
|
|
- "TIMEZONE"
|
67
|
|
- "TIMEVAL"
|
68
|
|
- "SIZE-T"
|
69
|
|
- "OFF-T"
|
70
|
|
- "INO-T"
|
71
|
|
- "DEV-T"
|
72
|
|
- "TIME-T"
|
73
|
|
- "USER-INFO-NAME"
|
74
|
|
- "INT64-T"
|
75
|
|
- "MODE-T"
|
76
|
|
- "UNIX-FAST-SELECT"
|
77
|
|
- "UNIX-PIPE"
|
78
|
|
- "UNIX-GETPID"
|
79
|
|
- "UNIX-GETHOSTID"
|
80
|
|
- "UNIX-UID"
|
81
|
|
- "UNIX-GID"
|
82
|
|
- "GET-UNIX-ERROR-MSG"
|
83
|
|
- "WINSIZE"
|
84
|
|
- "TIMEVAL"
|
85
|
|
- "CLOSE-DIR"
|
86
|
|
- "OPEN-DIR"
|
87
|
|
- "READ-DIR"
|
88
|
|
-
|
89
|
|
- ;; filesys.lisp
|
90
|
|
- "UNIX-GETPWUID"
|
91
|
|
-
|
92
|
|
- ;; multi-proc.lisp
|
93
|
|
- "UNIX-SETITIMER"
|
94
|
|
-
|
95
|
|
- ;; run-program.lisp
|
96
|
|
- "UNIX-TTYNAME"
|
97
|
|
- "UNIX-IOCTL"
|
98
|
|
- "UNIX-OPENPTY"
|
99
|
|
-
|
100
|
|
- ;; alien-callback.lisp
|
101
|
|
- "UNIX-MPROTECT"
|
102
|
|
-
|
103
|
|
- ;; internet.lisp
|
104
|
|
- "UNIX-SOCKET"
|
105
|
|
- "UNIX-CONNECT"
|
106
|
|
- "UNIX-BIND"
|
107
|
|
- "UNIX-LISTEN"
|
108
|
|
- "UNIX-ACCEPT"
|
109
|
|
- "UNIX-GETSOCKOPT"
|
110
|
|
- "UNIX-SETSOCKOPT"
|
111
|
|
- "UNIX-GETPEERNAME"
|
112
|
|
- "UNIX-GETSOCKNAME"
|
113
|
|
- "UNIX-RECV"
|
114
|
|
- "UNIX-SEND"
|
115
|
|
- "UNIX-RECVFROM"
|
116
|
|
- "UNIX-SENDTO"
|
117
|
|
- "UNIX-SHUTDOWN"
|
118
|
|
- "UNIX-FCNTL"
|
119
|
|
-
|
120
|
|
- ;; serve-event.lisp
|
121
|
|
- "FD-SETSIZE"
|
122
|
|
- "FD-ISSET"
|
123
|
|
- "FD-CLR"
|
124
|
|
-
|
125
|
|
- ;; Simple streams
|
126
|
|
- "PROT_READ"
|
127
|
|
- "UNIX-MMAP"
|
128
|
|
- "UNIX-MUNMAP"
|
129
|
|
- "UNIX-MSYNC"
|
130
|
|
-
|
131
|
|
- ;; Motif
|
132
|
|
- "UNIX-GETUID"
|
133
|
|
-
|
134
|
|
- ;; Hemlock
|
135
|
|
- "UNIX-CFGETOSPEED"
|
136
|
|
- "TERMIOS"
|
137
|
|
- "UNIX-TCGETATTR"
|
138
|
|
- "UNIX-TCSETATTR"
|
139
|
|
- "UNIX-FCHMOD"
|
140
|
|
- "UNIX-CREAT"
|
141
|
|
- "UNIX-UTIMES"
|
142
|
|
-
|
143
|
|
- ;; Tests
|
144
|
|
- "UNIX-SYMLINK"
|
145
|
|
-
|
146
|
|
- ;; Other symbols from structures, etc.
|
147
|
|
- "C-CC" "C-CFLAG" "C-IFLAG" "C-ISPEED" "C-LFLAG" "C-OFLAG" "C-OSPEED"
|
148
|
|
- "CHECK" "D-NAME" "D-RECLEN"
|
149
|
|
- "F-GETFL" "F-GETOWN" "F-SETFL" "F-SETOWN" "FAPPEND"
|
150
|
|
- "FASYNC" "FD-SET" "FD-ZERO" "FNDELAY" "F_OK" "GID-T" "IT-INTERVAL"
|
151
|
|
- "IT-VALUE" "ITIMERVAL" "L_INCR" "L_SET" "L_XTND" "MAP_ANONYMOUS"
|
152
|
|
- "MAP_FIXED" "MAP_PRIVATE" "MAP_SHARED" "MS_ASYNC" "MS_INVALIDATE"
|
153
|
|
- "MS_SYNC" "O_APPEND" "O_CREAT" "O_EXCL" "O_NDELAY" "O_NONBLOCK"
|
154
|
|
- "O_RDONLY" "O_RDWR" "O_TRUNC" "O_WRONLY" "PROT_EXEC" "PROT_NONE"
|
155
|
|
- "PROT_WRITE" "RU-IDRSS" "RU-INBLOCK" "RU-ISRSS" "RU-IXRSS" "RU-MAJFLT"
|
156
|
|
- "RU-MAXRSS" "RU-MINFLT" "RU-MSGRCV" "RU-MSGSND" "RU-NIVCSW" "RU-NSIGNALS"
|
157
|
|
- "RU-NSWAP" "RU-NVCSW" "RU-OUBLOCK" "RU-STIME" "RU-UTIME"
|
158
|
|
- "RUSAGE_CHILDREN" "RUSAGE_SELF" "R_OK" "S-IFBLK" "S-IFCHR" "S-IFDIR"
|
159
|
|
- "S-IFLNK" "S-IFMT" "S-IFREG" "S-IFSOCK" "SIGABRT" "SIGALRM" "SIGBUS"
|
160
|
|
- "SIGCHLD" "SIGCONT" "SIGCONTEXT" "SIGFPE" "SIGHUP" "SIGILL" "SIGINT"
|
161
|
|
- "SIGIO" "SIGIOT" "SIGKILL" "SIGMASK" "SIGPIPE" "SIGPROF" "SIGQUIT"
|
162
|
|
- "SIGSEGV" "SIGSTOP" "SIGTERM" "SIGTRAP" "SIGTSTP" "SIGTTIN" "SIGTTOU"
|
163
|
|
- "SIGURG" "SIGUSR1" "SIGUSR2" "SIGVTALRM" "SIGWINCH" "SIGXCPU" "SIGXFSZ"
|
164
|
|
- "ST-ATIME" "ST-BLKSIZE" "ST-BLOCKS" "ST-CTIME" "ST-DEV" "ST-GID"
|
165
|
|
- "ST-MODE" "ST-MTIME" "ST-NLINK" "ST-RDEV" "ST-SIZE" "ST-UID" "STAT"
|
166
|
|
- "TCSADRAIN" "TCSAFLUSH" "TCSANOW" "TIOCGPGRP" "TIOCGWINSZ" "TIOCNOTTY"
|
167
|
|
- "TIOCSPGRP" "TIOCSWINSZ" "TTY-BRKINT" "TTY-ECHO" "TTY-ECHOCTL"
|
168
|
|
- "TTY-ECHOE" "TTY-ECHOK" "TTY-ECHOKE" "TTY-ECHONL" "TTY-ECHOPRT"
|
169
|
|
- "TTY-FLUSHO" "TTY-ICANON" "TTY-ICRNL" "TTY-IEXTEN" "TTY-IGNBRK"
|
170
|
|
- "TTY-IGNCR" "TTY-IGNPAR" "TTY-IMAXBEL" "TTY-INLCR" "TTY-INPCK" "TTY-ISIG"
|
171
|
|
- "TTY-ISTRIP" "TTY-IXANY" "TTY-IXOFF" "TTY-IXON" "TTY-NOFLSH" "TTY-ONLCR"
|
172
|
|
- "TTY-OPOST" "TTY-PARMRK" "TTY-PENDIN" "TTY-TOSTOP" "TV-SEC" "TV-USEC"
|
173
|
|
- "TZ-DSTTIME" "TZ-MINUTESWEST" "UID-T" "UNIX-FD" "UNIX-FILE-KIND"
|
174
|
|
- "UNIX-FILE-MODE" "UNIX-GETUID" "UNIX-KILL" "UNIX-KILLPG" "UNIX-PATHNAME"
|
175
|
|
- "UNIX-SIGBLOCK" "UNIX-SIGNAL-DESCRIPTION" "UNIX-SIGNAL-NAME"
|
176
|
|
- "UNIX-SIGNAL-NUMBER" "UNIX-SIGPAUSE" "UNIX-SIGSETMASK" "USER-INFO"
|
177
|
|
- "USER-INFO-DIR" "USER-INFO-GECOS" "USER-INFO-GID" "USER-INFO-PASSWORD"
|
178
|
|
- "USER-INFO-SHELL" "USER-INFO-UID" "VDSUSP" "VEOF" "VEOL" "VEOL2" "VERASE"
|
179
|
|
- "VINTR" "VKILL" "VMIN" "VQUIT" "VSTART" "VSTOP" "VSUSP" "VTIME"
|
180
|
|
- "WRITEOWN" "WS-COL" "WS-ROW" "WS-XPIXEL" "WS-YPIXEL" "W_OK" "X_OK"
|
181
|
|
- "FIONREAD"
|
182
|
|
- "TERMINAL-SPEEDS"
|
183
|
|
- )
|
184
|
|
- (:export
|
185
|
|
- ;; For asdf
|
186
|
|
- "UNIX-GETENV"
|
187
|
|
- "UNIX-SETENV"
|
188
|
|
- "UNIX-PUTENV"
|
189
|
|
- "UNIX-UNSETENV"
|
190
|
|
- ;; For slime
|
191
|
|
- "UNIX-EXECVE"
|
192
|
|
- "UNIX-FORK")
|
193
|
|
- #-(or linux solaris)
|
194
|
|
- (:export "TCHARS"
|
195
|
|
- "LTCHARS"
|
196
|
|
- "D-NAMLEN"
|
197
|
|
-
|
198
|
|
- ;; run-program.lisp
|
199
|
|
- "SGTTYB"
|
200
|
|
-
|
201
|
|
- ;; Other symbols from structures, etc.
|
202
|
|
- "DIRECT" "ELOCAL" "EPROCLIM" "EVICEERR" "EVICEOP" "EXECGRP" "EXECOTH"
|
203
|
|
- "EXECOWN" "F-DUPFD" "F-GETFD" "F-SETFD" "FCREAT" "FEXCL"
|
204
|
|
- "FTRUNC" "READGRP" "READOTH" "READOWN" "S-IEXEC" "S-IREAD" "S-ISGID"
|
205
|
|
- "S-ISUID" "S-ISVTX" "S-IWRITE" "SAVETEXT" "SETGIDEXEC" "SETUIDEXEC"
|
206
|
|
- "SG-ERASE" "SG-FLAGS" "SG-ISPEED" "SG-KILL" "SG-OSPEED" "SIGEMT" "SIGSYS"
|
207
|
|
- "T-BRKC" "T-DSUSPC" "T-EOFC" "T-FLUSHC" "T-INTRC" "T-LNEXTC" "T-QUITC"
|
208
|
|
- "T-RPRNTC" "T-STARTC" "T-STOPC" "T-SUSPC" "T-WERASC" "TCIFLUSH"
|
209
|
|
- "TCIOFLUSH" "TCOFLUSH" "TIOCFLUSH" "TIOCGETC"
|
210
|
|
- "TIOCGETP" "TIOCGLTC" "TIOCSETC" "TIOCSETP" "TIOCSLTC" "TTY-CBREAK"
|
211
|
|
- "TTY-CLOCAL" "TTY-CREAD" "TTY-CRMOD" "TTY-CS5" "TTY-CS6" "TTY-CS7"
|
212
|
|
- "TTY-CS8" "TTY-CSIZE" "TTY-CSTOPB" "TTY-HUPCL" "TTY-LCASE" "TTY-PARENB"
|
213
|
|
- "TTY-PARODD" "TTY-RAW" "TTY-TANDEM" "WRITEGRP" "WRITEOTH"
|
214
|
|
- )
|
215
|
|
- #+linux
|
216
|
|
- (:export "TCHARS"
|
217
|
|
- "LTCHARS"
|
218
|
|
- "D-NAMLEN"
|
219
|
|
-
|
220
|
|
- ;; run-program.lisp
|
221
|
|
- "SGTTYB"
|
222
|
|
-
|
223
|
|
- ;; Other symbols
|
224
|
|
- "BLKCNT-T" "D-INO" "D-OFF"
|
225
|
|
- "O_NOCTTY" "SIGSTKFLT"
|
226
|
|
- "SG-FLAGS"
|
227
|
|
- "TIOCGETP"
|
228
|
|
- "TIOCSETP"
|
229
|
|
- "TTY-IUCLC"
|
230
|
|
- "TTY-OCRNL" "TTY-OFDEL" "TTY-OFILL" "TTY-OLCUC" "TTY-ONLRET" "TTY-ONOCR"
|
231
|
|
- "TTY-XCASE" "UNIX-DUP2" "UNIX-GETITIMER" "UNIX-PID"
|
232
|
|
- "UTSNAME"
|
233
|
|
- )
|
234
|
|
- #+solaris
|
235
|
|
- (:export "D-INO"
|
236
|
|
- "D-OFF"
|
237
|
|
- "DIRECT"
|
238
|
|
- "EXECGRP"
|
239
|
|
- "EXECOTH"
|
240
|
|
- "EXECOWN"
|
241
|
|
-
|
242
|
|
- "F-DUPFD"
|
243
|
|
- "F-GETFD"
|
244
|
|
- "F-SETFD"
|
245
|
|
- "FCREAT"
|
246
|
|
- "FEXCL"
|
247
|
|
- "FTRUNC"
|
248
|
|
- "LTCHARS"
|
249
|
|
- "O_NOCTTY"
|
250
|
|
- "RCV1EN"
|
251
|
|
- "READGRP"
|
252
|
|
- "READOTH"
|
253
|
|
- "READOWN"
|
254
|
|
- "S-IEXEC"
|
255
|
|
- "S-IREAD"
|
256
|
|
- "S-ISGID"
|
257
|
|
- "S-ISUID"
|
258
|
|
- "S-ISVTX"
|
259
|
|
- "S-IWRITE"
|
260
|
|
- "SAVETEXT"
|
261
|
|
- "SETGIDEXEC"
|
262
|
|
- "SETUIDEXEC"
|
263
|
|
- "SG-ERASE"
|
264
|
|
- "SG-FLAGS"
|
265
|
|
- "SG-ISPEED"
|
266
|
|
- "SG-KILL"
|
267
|
|
- "SG-OSPEED"
|
268
|
|
- "SGTTYB"
|
269
|
|
- "SIGEMT"
|
270
|
|
- "SIGSYS"
|
271
|
|
- "SIGWAITING"
|
272
|
|
- "T-BRKC"
|
273
|
|
- "T-DSUSPC"
|
274
|
|
- "T-EOFC"
|
275
|
|
- "T-FLUSHC"
|
276
|
|
- "T-INTRC"
|
277
|
|
- "T-LNEXTC"
|
278
|
|
- "T-QUITC"
|
279
|
|
- "T-RPRNTC"
|
280
|
|
- "T-STARTC"
|
281
|
|
- "T-STOPC"
|
282
|
|
- "T-SUSPC"
|
283
|
|
- "T-WERASC"
|
284
|
|
- "TCHARS"
|
285
|
|
- "TCIFLUSH"
|
286
|
|
- "TCIOFLUSH"
|
287
|
|
- "TCOFLUSH"
|
288
|
|
- "TIOCFLUSH"
|
289
|
|
- "TIOCGETC"
|
290
|
|
- "TIOCGETP"
|
291
|
|
- "TIOCGLTC"
|
292
|
|
- "TIOCSETC"
|
293
|
|
- "TIOCSETP"
|
294
|
|
- "TIOCSLTC"
|
295
|
|
- "TTY-CBAUD"
|
296
|
|
- "TTY-CBREAK"
|
297
|
|
- "TTY-CLOCAL"
|
298
|
|
- "TTY-CREAD"
|
299
|
|
- "TTY-CRMOD"
|
300
|
|
- "TTY-CS5"
|
301
|
|
- "TTY-CS6"
|
302
|
|
- "TTY-CS7"
|
303
|
|
- "TTY-CS8"
|
304
|
|
- "TTY-CSIZE"
|
305
|
|
- "TTY-CSTOPB"
|
306
|
|
- "TTY-DEFECHO"
|
307
|
|
- "TTY-HUPCL"
|
308
|
|
- "TTY-IUCLC"
|
309
|
|
- "TTY-LCASE"
|
310
|
|
- "TTY-LOBLK"
|
311
|
|
- "TTY-OCRNL"
|
312
|
|
- "TTY-OFDEL"
|
313
|
|
- "TTY-OFILL"
|
314
|
|
- "TTY-OLCUC"
|
315
|
|
- "TTY-ONLRET"
|
316
|
|
- "TTY-ONOCR"
|
317
|
|
- "TTY-PARENB"
|
318
|
|
- "TTY-PARODD"
|
319
|
|
- "TTY-RAW"
|
320
|
|
- "TTY-TANDEM"
|
321
|
|
- "TTY-XCASE"
|
322
|
|
- "UNIX-TIMES"
|
323
|
|
- "UNIX-DUP2"
|
324
|
|
- "UTSNAME"
|
325
|
|
- "WRITEGRP"
|
326
|
|
- "WRITEOTH"
|
327
|
|
- "XMT1EN"
|
328
|
|
- )
|
329
|
|
- ) |
|
12
|
+;;; Bootstrap for adding %local-nicknames to package structure.
|
|
13
|
+(in-package :lisp)
|
|
14
|
+
|
|
15
|
+(intern "PACKAGE-LOCAL-NICKNAMES" "LISP")
|
|
16
|
+(intern "ADD-PACKAGE-LOCAL-NICKNAME" "LISP")
|
|
17
|
+(intern "REMOVE-PACKAGE-LOCAL-NICKNAME" "LISP")
|
|
18
|
+(intern "PACKAGE-LOCALLY-NICKNAMED-BY-LIST" "LISP")
|
|
19
|
+
|
|
20
|
+;; Make sure we don't accidentally load fasls from somewhere.
|
|
21
|
+(setf (ext:search-list "target:")
|
|
22
|
+ '("src/"))
|
|
23
|
+
|
|
24
|
+;; Ensure all packages have been set up, since package definition is broken
|
|
25
|
+;; once this file has been loaded:
|
|
26
|
+(load "target:code/exports-errno" :if-does-not-exist nil)
|
|
27
|
+(load "target:code/exports")
|
|
28
|
+
|
|
29
|
+(setf *enable-package-locked-errors* nil)
|
|
30
|
+
|
|
31
|
+;;;
|
|
32
|
+;;; Like DEFSTRUCT, but silently clobber old definitions.
|
|
33
|
+;;;
|
|
34
|
+(defmacro defstruct! (name &rest stuff)
|
|
35
|
+ `(handler-bind ((error (lambda (c)
|
|
36
|
+ (declare (ignore c))
|
|
37
|
+ (invoke-restart 'kernel::clobber-it))))
|
|
38
|
+ (defstruct ,name ,@stuff)))
|
|
39
|
+
|
|
40
|
+
|
|
41
|
+(defstruct! (package
|
|
42
|
+ (:constructor internal-make-package)
|
|
43
|
+ (:predicate packagep)
|
|
44
|
+ (:print-function %print-package)
|
|
45
|
+ (:make-load-form-fun
|
|
46
|
+ (lambda (package)
|
|
47
|
+ (values `(package-or-lose ',(package-name package))
|
|
48
|
+ nil))))
|
|
49
|
+ (tables (list nil)) ; A list of all the hashtables for inherited symbols.
|
|
50
|
+ (%name nil :type (or simple-string null))
|
|
51
|
+ (%nicknames () :type list)
|
|
52
|
+ (%use-list () :type list)
|
|
53
|
+ (%used-by-list () :type list)
|
|
54
|
+ (internal-symbols (required-argument) :type package-hashtable)
|
|
55
|
+ (external-symbols (required-argument) :type package-hashtable)
|
|
56
|
+ (%shadowing-symbols () :type list)
|
|
57
|
+ (lock nil :type boolean)
|
|
58
|
+ (definition-lock nil :type boolean)
|
|
59
|
+ (%local-nicknames () :type list)
|
|
60
|
+ (doc-string nil :type (or simple-string null)))
|
|
61
|
+
|
|
62
|
+;; Need to define this with the extra arg because compiling pcl uses
|
|
63
|
+;; defpackage and we need this defined. This isn't the actual
|
|
64
|
+;; implementation; we just added the extra arg.
|
|
65
|
+(defun %defpackage (name nicknames size shadows shadowing-imports
|
|
66
|
+ use imports interns exports doc-string &optional local-nicknames)
|
|
67
|
+ (declare (type simple-base-string name)
|
|
68
|
+ (type list nicknames local-nicknames shadows shadowing-imports
|
|
69
|
+ imports interns exports)
|
|
70
|
+ (type (or list (member :default)) use)
|
|
71
|
+ (type (or simple-base-string null) doc-string))
|
|
72
|
+ (let ((package (or (find-package name)
|
|
73
|
+ (progn
|
|
74
|
+ (when (eq use :default)
|
|
75
|
+ (setf use *default-package-use-list*))
|
|
76
|
+ (make-package name
|
|
77
|
+ :use nil
|
|
78
|
+ :internal-symbols (or size 10)
|
|
79
|
+ :external-symbols (length exports))))))
|
|
80
|
+ (unless (string= (the string (package-name package)) name)
|
|
81
|
+ (error 'simple-package-error
|
|
82
|
+ :package name
|
|
83
|
+ :format-control (intl:gettext "~A is a nick-name for the package ~A")
|
|
84
|
+ :format-arguments (list name (package-name name))))
|
|
85
|
+ (enter-new-nicknames package nicknames)
|
|
86
|
+ ;; Shadows and Shadowing-imports.
|
|
87
|
+ (let ((old-shadows (package-%shadowing-symbols package)))
|
|
88
|
+ (shadow shadows package)
|
|
89
|
+ (dolist (sym-name shadows)
|
|
90
|
+ (setf old-shadows (remove (find-symbol sym-name package) old-shadows)))
|
|
91
|
+ (dolist (simports-from shadowing-imports)
|
|
92
|
+ (let ((other-package (package-or-lose (car simports-from))))
|
|
93
|
+ (dolist (sym-name (cdr simports-from))
|
|
94
|
+ (let ((sym (find-or-make-symbol sym-name other-package)))
|
|
95
|
+ (shadowing-import sym package)
|
|
96
|
+ (setf old-shadows (remove sym old-shadows))))))
|
|
97
|
+ (when old-shadows
|
|
98
|
+ (warn (intl:gettext "~A also shadows the following symbols:~% ~S")
|
|
99
|
+ name old-shadows)))
|
|
100
|
+ ;; Use
|
|
101
|
+ (unless (eq use :default)
|
|
102
|
+ (let ((old-use-list (package-use-list package))
|
|
103
|
+ (new-use-list (mapcar #'package-or-lose use)))
|
|
104
|
+ (use-package (set-difference new-use-list old-use-list) package)
|
|
105
|
+ (let ((laterize (set-difference old-use-list new-use-list)))
|
|
106
|
+ (when laterize
|
|
107
|
+ (unuse-package laterize package)
|
|
108
|
+ (warn (intl:gettext "~A previously used the following packages:~% ~S")
|
|
109
|
+ name
|
|
110
|
+ laterize)))))
|
|
111
|
+ ;; Import and Intern.
|
|
112
|
+ (dolist (sym-name interns)
|
|
113
|
+ (intern sym-name package))
|
|
114
|
+ (dolist (imports-from imports)
|
|
115
|
+ (let ((other-package (package-or-lose (car imports-from))))
|
|
116
|
+ (dolist (sym-name (cdr imports-from))
|
|
117
|
+ (import (list (find-or-make-symbol sym-name other-package))
|
|
118
|
+ package))))
|
|
119
|
+ ;; Exports.
|
|
120
|
+ (let ((old-exports nil)
|
|
121
|
+ (exports (mapcar #'(lambda (sym-name) (intern sym-name package))
|
|
122
|
+ exports)))
|
|
123
|
+ (do-external-symbols (sym package)
|
|
124
|
+ (push sym old-exports))
|
|
125
|
+ (export exports package)
|
|
126
|
+ (let ((diff (set-difference old-exports exports)))
|
|
127
|
+ (when diff
|
|
128
|
+ (warn (intl:gettext "~A also exports the following symbols:~% ~S")
|
|
129
|
+ name diff))))
|
|
130
|
+ ;; Documentation
|
|
131
|
+ (setf (package-doc-string package) doc-string)
|
|
132
|
+ package)) |