diff --git a/cig/cig.scm b/cig/cig.scm index 7ef900c..4465552 100644 --- a/cig/cig.scm +++ b/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 @@ -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)) + (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. diff --git a/cig/libcig.h b/cig/libcig.h index 7fa4f90..1558a30 100644 --- a/cig/libcig.h +++ b/cig/libcig.h @@ -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);