Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
cmucl
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Package Registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Carl Shapiro
cmucl
Commits
7205f924
Commit
7205f924
authored
30 years ago
by
ram
Browse files
Options
Downloads
Patches
Plain Diff
Merge solaris patches.
parent
08b750d4
No related branches found
No related tags found
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
code/foreign.lisp
+103
-3
103 additions, 3 deletions
code/foreign.lisp
with
103 additions
and
3 deletions
code/foreign.lisp
+
103
−
3
View file @
7205f924
...
@@ -7,7 +7,7 @@
...
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
;;;
(
ext:file-comment
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/foreign.lisp,v 1.1
6
1994/10/
01 00:38:19
ram Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/foreign.lisp,v 1.1
7
1994/10/
19 23:49:54
ram Exp $"
)
;;;
;;;
;;; **********************************************************************
;;; **********************************************************************
;;;
;;;
...
@@ -53,7 +53,7 @@
...
@@ -53,7 +53,7 @@
(
t
(
t
(
incf
code
))))))))
(
incf
code
))))))))
#+
sparc
#+
(
and
sparc
(
not
svr4
))
(
alien:def-alien-type
exec
(
alien:def-alien-type
exec
(
alien:struct
nil
(
alien:struct
nil
(
magic
c-call:unsigned-long
)
(
magic
c-call:unsigned-long
)
...
@@ -65,6 +65,7 @@
...
@@ -65,6 +65,7 @@
(
trsize
c-call:unsigned-long
)
(
trsize
c-call:unsigned-long
)
(
drsize
c-call:unsigned-long
)))
(
drsize
c-call:unsigned-long
)))
#-
svr4
(
defun
allocate-space-in-foreign-segment
(
bytes
)
(
defun
allocate-space-in-foreign-segment
(
bytes
)
(
let*
((
pagesize-1
(
1-
(
get-page-size
)))
(
let*
((
pagesize-1
(
1-
(
get-page-size
)))
(
memory-needed
(
logandc2
(
+
bytes
pagesize-1
)
pagesize-1
))
(
memory-needed
(
logandc2
(
+
bytes
pagesize-1
)
pagesize-1
))
...
@@ -76,7 +77,7 @@
...
@@ -76,7 +77,7 @@
(
allocate-system-memory-at
addr
memory-needed
)
(
allocate-system-memory-at
addr
memory-needed
)
addr
))
addr
))
#+
sparc
#+
(
and
sparc
(
not
svr4
))
(
defun
load-object-file
(
name
)
(
defun
load-object-file
(
name
)
(
format
t
";;; Loading object file...~%"
)
(
format
t
";;; Loading object file...~%"
)
(
multiple-value-bind
(
fd
errno
)
(
unix:unix-open
name
unix:o_rdonly
0
)
(
multiple-value-bind
(
fd
errno
)
(
unix:unix-open
name
unix:o_rdonly
0
)
...
@@ -271,6 +272,7 @@
...
@@ -271,6 +272,7 @@
))
))
(
unix:unix-close
fd
))))
(
unix:unix-close
fd
))))
#-
solaris
(
defun
parse-symbol-table
(
name
)
(
defun
parse-symbol-table
(
name
)
(
format
t
";;; Parsing symbol table...~%"
)
(
format
t
";;; Parsing symbol table...~%"
)
(
let
((
symbol-table
(
make-hash-table
:test
#'
equal
)))
(
let
((
symbol-table
(
make-hash-table
:test
#'
equal
)))
...
@@ -288,6 +290,7 @@
...
@@ -288,6 +290,7 @@
(
setf
(
gethash
symbol
symbol-table
)
address
)))))
(
setf
(
gethash
symbol
symbol-table
)
address
)))))
(
setf
lisp::*foreign-symbols*
symbol-table
)))
(
setf
lisp::*foreign-symbols*
symbol-table
)))
#-
solaris
(
defun
load-foreign
(
files
&key
(
defun
load-foreign
(
files
&key
(
libraries
'
(
"-lc"
))
(
libraries
'
(
"-lc"
))
(
base-file
(
base-file
...
@@ -341,3 +344,100 @@
...
@@ -341,3 +344,100 @@
(
when
old-file
(
when
old-file
(
unix:unix-unlink
old-file
)))))
(
unix:unix-unlink
old-file
)))))
(
format
t
";;; Done.~%"
))
(
format
t
";;; Done.~%"
))
(
export
'
(
alternate-get-global-address
))
#-
solaris
(
defun
alternate-get-global-address
(
symbol
)
0
)
#+
solaris
(
progn
(
defconstant
rtld-lazy
1
)
(
defconstant
rtld-now
2
)
(
defconstant
rtld-global
#o400
)
(
defvar
*global-table*
NIL
)
(
alien:def-alien-routine
dlopen
system-area-pointer
(
str
c-call:c-string
)
(
i
c-call:int
))
(
alien:def-alien-routine
dlsym
system-area-pointer
(
lib
system-area-pointer
)
(
str
c-call:c-string
))
(
alien:def-alien-routine
dlclose
void
(
lib
system-area-pointer
))
(
alien:def-alien-routine
dlerror
c-call:c-string
)
(
defun
load-object-file
(
file
)
; rtld global: so it can find all the symbols previously loaded
; rtld now: that way dlopen will fail if not all symbols are defined.
(
let
((
sap
(
dlopen
file
(
logior
rtld-now
rtld-global
))))
(
if
(
zerop
(
sap-int
sap
))
(
error
"Can't open object ~S: ~S"
file
(
dlerror
))
(
pushnew
sap
*global-table*
))))
(
defun
alternate-get-global-address
(
symbol
)
(
unless
*global-table*
;; Prevent recursive call when dlopen isn't defined.
(
setq
*global-table*
(
int-sap
0
))
;; Load standard object
(
setq
*global-table*
(
list
(
dlopen
nil
rtld-lazy
)))
(
if
(
zerop
(
system:sap-int
(
car
*global-table*
)))
(
error
"Can't open global symbol table: ~S"
(
dlerror
))))
;; find the symbol in any of the loaded obbjects,
;; search in reverse order of loading, later loadings
;; take precedence
(
let
((
result
0
))
(
do
((
table
*global-table*
(
cdr
table
)))
((
or
(
null
(
car
table
))
(
not
(
zerop
result
))))
(
setq
result
(
sap-int
(
dlsym
(
car
table
)
symbol
))))
(
values
result
)))
(
defun
load-foreign
(
files
&key
(
libraries
'
(
"-lc"
))
(
base-file
nil
)
(
env
ext:*environment-list*
))
"Load-foreign loads a list of C object files into a running Lisp. The files
argument should be a single file or a list of files. The files may be
specified as namestrings or as pathnames. The libraries argument should be a
list of library files as would be specified to ld. They will be searched in
the order given. The default is just \"-lc\", i.e., the C library. The
base-file argument is used to specify a file to use as the starting place for
defined symbols. The default is the C start up code for Lisp. The env
argument is the Unix environment variable definitions for the invocation of
the linker. The default is the environment passed to Lisp."
;; Note: dlopen remembers the name of an object, when dlopenin
;; the same name twice, the old objects is reused.
(
declare
(
ignore
base-file
))
(
let
((
output-file
(
pick-temporary-file-name
(
concatenate
'string
"/tmp/~D~S"
(
string
(
gensym
)))))
(
error-output
(
make-string-output-stream
)))
(
format
t
";;; Running /usr/ccs/bin/ld...~%"
)
(
force-output
)
(
let
((
proc
(
ext:run-program
"/usr/ccs/bin/ld"
(
list*
"-G"
"-o"
output-file
(
append
(
mapcar
#'
(
lambda
(
name
)
(
unix-namestring
name
nil
))
(
if
(
atom
files
)
(
list
files
)
files
))
libraries
))
:env
env
:input
nil
:output
error-output
:error
:output
)))
(
unless
proc
(
error
"Could not run /usr/ccs/bin/ld"
))
(
unless
(
zerop
(
ext:process-exit-code
proc
))
(
system:serve-all-events
0
)
(
error
"/usr/ccs/bin/ld failed:~%~A"
(
get-output-stream-string
error-output
)))
(
load-object-file
output-file
)
(
unix:unix-unlink
output-file
)
))
(
format
t
";;; Done.~%"
))
)
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment