cig standalone is now a shell-skript that calls the vm cigvm with the image standalone.image and takes the filename as an argument. s48_init_xx's name is generated from filename without directory
This commit is contained in:
parent
ef4cf7c9f7
commit
45d3aa911c
66
cig/cig.scm
66
cig/cig.scm
|
@ -772,7 +772,7 @@
|
|||
|
||||
(define cfile-header-boilerplate
|
||||
"/* This is an Scheme48/C interface file,
|
||||
** automatically generated by cig.
|
||||
** automatically generated by a hacked version of cig 3.0.
|
||||
*/
|
||||
|
||||
#include <stdio.h>
|
||||
|
@ -863,9 +863,36 @@
|
|||
(lp (append c-names (define-foreign-process-form form oport))))))))))))
|
||||
; Frank: end
|
||||
|
||||
; JMG: stolen from various places
|
||||
(define (file-name-nondirectory fname)
|
||||
(cond ((rindex fname #\/) =>
|
||||
(lambda (rslash)
|
||||
(if (last-non-slash fname)
|
||||
(substring fname (+ 1 rslash) (string-length fname))
|
||||
fname))) ; Posix strangeness: solid slashes are root.
|
||||
(else fname)))
|
||||
|
||||
(define (cig-standalone-toplevel fname) ; ignore your args.
|
||||
(process-define-foreign-file fname)
|
||||
(define (rindex str c ) ;removed optional argument
|
||||
(let* ((len (string-length str))
|
||||
(start len))
|
||||
(do ((i (- start 1) (- i 1)))
|
||||
((or (< i 0)
|
||||
(char=? c (string-ref str i)))
|
||||
(and (>= i 0) i)))))
|
||||
|
||||
(define (last-non-slash str)
|
||||
(let lp ((i (- (string-length str) 1)))
|
||||
(and (>= i 0)
|
||||
(if (char=? #\/ (string-ref str i))
|
||||
(lp (- i 1))
|
||||
i))))
|
||||
|
||||
(define (cig-standalone-toplevel fname) ; ignore your args no longer.
|
||||
(display "This is cig standalone\n")
|
||||
(display "processing ")
|
||||
(display fname)
|
||||
(newline)
|
||||
(process-define-foreign-file (car fname))
|
||||
0)
|
||||
|
||||
;;; This section defines the Scheme-side macro processor.
|
||||
|
@ -908,6 +935,9 @@
|
|||
(%lambda (rename 'lambda))
|
||||
; JMG: begin replaced external-lambda by import-lambda-definition
|
||||
(%import-lambda-definition (rename 'import-lambda-definition))
|
||||
(%lookup-imported-binding (rename 'lookup-imported-binding))
|
||||
(%call-imported-binding (rename 'call-imported-binding))
|
||||
(%let* (rename 'let*))
|
||||
; JMG: end
|
||||
(gensym (let ((gs (make-gensym "g" -1)))
|
||||
(lambda () (string->symbol (gs #f)))))
|
||||
|
@ -945,24 +975,38 @@
|
|||
; get-external and external-call replaced: now external-lambda
|
||||
;JMG now import-lambda-definition
|
||||
`(,%import-lambda-definition ,scheme-name ,args ,c-name))
|
||||
;; `(,%define ,scheme-name
|
||||
;; (,%let ((,%f (,%external-lambda ,args ,c-name)))
|
||||
;; (,%lambda ,args ,xcall))))
|
||||
|
||||
(let ((retarg1 (rename 'r1))
|
||||
(retarg2 (rename 'r2))
|
||||
(%make-vector (rename 'make-vector)))
|
||||
`(,%define ,scheme-name
|
||||
(,%import-lambda-definition ,%f ,args ,c-name)
|
||||
;; (,%let ((,%f (,%external-lambda ,args ,c-name)))
|
||||
(,%let ((,%f (,%lookup-imported-binding ,c-name)))
|
||||
(,%lambda ,args
|
||||
(,%let ((,retarg2 (,%make-vector ,carrier-veclen)))
|
||||
,@(install-carriers retarg2 ret-infos2
|
||||
(rename 'vector-set!))
|
||||
(,%let ((,retarg1 (,%f ,@c-args ,retarg2)))
|
||||
(,%let ((,retarg1 (,%call-imported-binding ,%f ,@c-args ,retarg2)))
|
||||
(values ,@(make-values-args retarg1 retarg2
|
||||
ret-infos2
|
||||
rename)))))))))))
|
||||
rename))))))))))))
|
||||
;; `(,%define ,scheme-name
|
||||
;; (,%let ((,%f (,%external-lambda ,args ,c-name)))
|
||||
;; (,%lambda ,args ,xcall))))
|
||||
|
||||
; (let ((retarg1 (rename 'r1))
|
||||
; (retarg2 (rename 'r2))
|
||||
; (%make-vector (rename 'make-vector)))
|
||||
; `(,%define
|
||||
; ,scheme-name
|
||||
; (,%let* ((temp (,%lookup-imported-binding ,c-name))
|
||||
; (,%f (,%lambda ,args (,%call-imported-binding temp ,args))))
|
||||
; (,%lambda ,args
|
||||
; (,%let ((,retarg2 (,%make-vector ,carrier-veclen)))
|
||||
; ,@(install-carriers retarg2 ret-infos2
|
||||
; (rename 'vector-set!))
|
||||
; (,%let ((,retarg1 (,%f ,@c-args ,retarg2)))
|
||||
; (values ,@(make-values-args retarg1 retarg2
|
||||
; ret-infos2
|
||||
; rename))))))))))))
|
||||
; Frank: end
|
||||
(define (install-carriers carrier-vec ret-infos2 %vector-set!)
|
||||
;; Skip the major ret value if it doesn't require a carrier.
|
||||
|
|
|
@ -12,7 +12,10 @@
|
|||
|
||||
#define AlienVal(x) (S48_STOB_REF((x),0))
|
||||
|
||||
// JMG: some hacks to leave to old sources untouched
|
||||
#define ENTER_BOOLEAN(x) (x ? S48_TRUE : S48_FALSE)
|
||||
#define ENTER_FIXNUM(x) (s48_enter_fixnum(x))
|
||||
#define SCHFALSE S48_FALSE
|
||||
|
||||
extern char *scheme2c_strcpy(s48_value sstr);
|
||||
|
||||
|
|
Loading…
Reference in New Issue