Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
cmucl
cmucl
Commits
82b634ce
Commit
82b634ce
authored
Jul 31, 1993
by
ram
Browse files
Add COMPILE-FILE-PATHNAME function.
parent
21bdedc6
Changes
1
Hide whitespace changes
Inline
Side-by-side
compiler/main.lisp
View file @
82b634ce
...
...
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.9
0
1993/07/
25 21:25:43
ram Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/main.lisp,v 1.9
1
1993/07/
31 02:10:21
ram Exp $"
)
;;;
;;; **********************************************************************
;;;
...
...
@@ -23,7 +23,8 @@
*byte-compile-top-level*
))
(
in-package
"LISP"
)
(
export
'
(
*compile-verbose*
*compile-print*
*compile-file-pathname*
*compile-file-truename*
))
*compile-file-truename*
compile-file-pathname
))
(
in-package
"C"
)
(
proclaim
'
(
special
*constants*
*free-variables*
*compile-component*
...
...
@@ -100,10 +101,10 @@
"The default for the :PROGRESS argument to COMPILE-FILE."
)
(
defvar
*compile-file-pathname*
nil
"The defaulted pathname of the file currently being compile
r
, or NIL if not
"The defaulted pathname of the file currently being compile
d
, or NIL if not
compiling."
)
(
defvar
*compile-file-truename*
nil
"The TRUENAME of the file currently being compile
r
, or NIL if not
"The TRUENAME of the file currently being compile
d
, or NIL if not
compiling."
)
(
declaim
(
type
(
or
pathname
null
)
*compile-file-pathname*
...
...
@@ -1877,3 +1878,24 @@
(
setf
(
fdefinition
name
)
(
coerce
(
get-lambda-to-compile
def
)
'function
))))
name
)
;;; COMPILE-FILE-PATHNAME -- Public
;;;
(
defun
compile-file-pathname
(
file-path
&key
(
output-file
t
)
byte-compile
&allow-other-keys
)
"Return a pathname describing what file COMPILE-FILE would write to given
these arguments."
(
declare
(
values
(
or
null
pathname
)))
(
let
((
pathname
(
pathname
file-path
)))
(
cond
((
not
(
eq
output-file
t
))
(
when
output-file
(
translate-logical-pathname
(
pathname
output-file
))))
((
and
(
logical-pathname-p
pathname
)
(
not
(
eq
byte-compile
t
)))
(
make-pathname
:type
"FASL"
:defaults
pathname
:case
:common
))
(
t
(
make-pathname
:defaults
(
translate-logical-pathname
pathname
)
:type
(
if
(
eq
byte-compile
t
)
(
backend-byte-fasl-file-type
*backend*
)
(
backend-fasl-file-type
*backend*
)))))))
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment