tmtt/chez-openbsd
Archived
1
0
Fork 0
Code Issues Pull requests Releases 1 Activity

feat: 9.5.9

Browse source
This commit is contained in:
tmtt 2022-07-29 15:12:07 +02:00
parent cb1753732b
commit 35f43a7909
1084 changed files with 558985 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

101
s/reloc.ss Normal file
View file

@ -0,0 +1,101 @@
;;; reloc.ss
;;; Copyright 1984-2017 Cisco Systems, Inc.
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;; http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.
(begin
(define $reloc
(lambda (type item-offset code-offset)
(make-reloc type item-offset code-offset
(or (> item-offset (constant reloc-item-offset-mask))
(> code-offset (constant reloc-code-offset-mask))))))
(define $make-relocation-table!
(let ()
(define link-code-object!
(foreign-procedure "(cs)link_code_object"
(scheme-object scheme-object)
void))
(define set-reloc!
(foreign-procedure "(cs)s_set_reloc"
(scheme-object scheme-object scheme-object)
scheme-object))
(define make-reloc-table
(foreign-procedure "(cs)s_make_reloc_table"
(scheme-object scheme-object)
scheme-object))
(lambda (p r* objs)
(make-reloc-table p (fold-left (lambda (m r) (fx+ m (if (reloc-long? r) 3 1))) 0 r*))
(let mkc1 ([r* r*] [n 0])
(if (null? r*)
(link-code-object! p objs)
(let ([r (car r*)] [r* (cdr r*)])
(if (reloc-long? r)
(begin
(set-reloc! p n
(logor
(bitwise-arithmetic-shift-left (reloc-type r) (constant reloc-type-offset))
(constant reloc-extended-format)))
(set-reloc! p (fx+ n 1) (reloc-item-offset r))
(set-reloc! p (fx+ n 2) (reloc-code-offset r))
(mkc1 r* (fx+ n 3)))
(begin
(set-reloc! p n
(logor
(bitwise-arithmetic-shift-left (reloc-type r) (constant reloc-type-offset))
(bitwise-arithmetic-shift-left (reloc-code-offset r) (constant reloc-code-offset-offset))
(bitwise-arithmetic-shift-left (reloc-item-offset r) (constant reloc-item-offset-offset))))
(mkc1 r* (fx+ n 1))))))))))
(let ()
(set! $make-cinst
(lambda (build-sinst vtable)
(critical-section
(let ([p ($make-code-object
(if (eq? (subset-mode) 'system) (constant code-flag-system) 0)
0
"cinst"
(* 2 (constant ptr-bytes))
#f
'())])
($make-relocation-table! p
(list ($reloc (constant reloc-abs) 0 (constant ptr-bytes))
($reloc (constant reloc-abs) (constant code-data-disp)
(constant code-data-disp)))
(list vtable (build-sinst p)))
p))))
(set! $make-vtable
(lambda (foreign-entries)
(let ([n (length foreign-entries)])
(let loop ([i n] [r '()] [offset (constant code-data-disp)])
(if (fx= i 0)
(critical-section
(let ([p ($make-code-object
(if (eq? (subset-mode) 'system) (constant code-flag-system) 0)
0
"vtable"
(* n (constant ptr-bytes))
#f
'())])
($make-relocation-table! p r foreign-entries)
p))
(loop (fx- i 1)
(cons ($reloc
(constant reloc-abs)
(constant code-data-disp)
offset)
r)
(constant ptr-bytes)))))))
)
)