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:
marting 1999-09-15 18:20:55 +00:00
parent ef4cf7c9f7
commit 45d3aa911c
2 changed files with 59 additions and 12 deletions

View File

@ -772,7 +772,7 @@
(define cfile-header-boilerplate (define cfile-header-boilerplate
"/* This is an Scheme48/C interface file, "/* This is an Scheme48/C interface file,
** automatically generated by cig. ** automatically generated by a hacked version of cig 3.0.
*/ */
#include <stdio.h> #include <stdio.h>
@ -863,9 +863,36 @@
(lp (append c-names (define-foreign-process-form form oport)))))))))))) (lp (append c-names (define-foreign-process-form form oport))))))))))))
; Frank: end ; 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. (define (rindex str c ) ;removed optional argument
(process-define-foreign-file fname) (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) 0)
;;; This section defines the Scheme-side macro processor. ;;; This section defines the Scheme-side macro processor.
@ -908,6 +935,9 @@
(%lambda (rename 'lambda)) (%lambda (rename 'lambda))
; JMG: begin replaced external-lambda by import-lambda-definition ; JMG: begin replaced external-lambda by import-lambda-definition
(%import-lambda-definition (rename '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 ; JMG: end
(gensym (let ((gs (make-gensym "g" -1))) (gensym (let ((gs (make-gensym "g" -1)))
(lambda () (string->symbol (gs #f))))) (lambda () (string->symbol (gs #f)))))
@ -945,24 +975,38 @@
; get-external and external-call replaced: now external-lambda ; get-external and external-call replaced: now external-lambda
;JMG now import-lambda-definition ;JMG now import-lambda-definition
`(,%import-lambda-definition ,scheme-name ,args ,c-name)) `(,%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)) (let ((retarg1 (rename 'r1))
(retarg2 (rename 'r2)) (retarg2 (rename 'r2))
(%make-vector (rename 'make-vector))) (%make-vector (rename 'make-vector)))
`(,%define ,scheme-name `(,%define ,scheme-name
(,%import-lambda-definition ,%f ,args ,c-name) (,%let ((,%f (,%lookup-imported-binding ,c-name)))
;; (,%let ((,%f (,%external-lambda ,args ,c-name)))
(,%lambda ,args (,%lambda ,args
(,%let ((,retarg2 (,%make-vector ,carrier-veclen))) (,%let ((,retarg2 (,%make-vector ,carrier-veclen)))
,@(install-carriers retarg2 ret-infos2 ,@(install-carriers retarg2 ret-infos2
(rename 'vector-set!)) (rename 'vector-set!))
(,%let ((,retarg1 (,%f ,@c-args ,retarg2))) (,%let ((,retarg1 (,%call-imported-binding ,%f ,@c-args ,retarg2)))
(values ,@(make-values-args retarg1 retarg2 (values ,@(make-values-args retarg1 retarg2
ret-infos2 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 ; Frank: end
(define (install-carriers carrier-vec ret-infos2 %vector-set!) (define (install-carriers carrier-vec ret-infos2 %vector-set!)
;; Skip the major ret value if it doesn't require a carrier. ;; Skip the major ret value if it doesn't require a carrier.

View File

@ -12,7 +12,10 @@
#define AlienVal(x) (S48_STOB_REF((x),0)) #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_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); extern char *scheme2c_strcpy(s48_value sstr);