~ chicken-core (chicken-5) /chicken-ffi-syntax.scm
Trap1;;;; chicken-ffi-syntax.scm2;3; Copyright (c) 2008-2022, The CHICKEN Team4; Copyright (c) 2000-2007, Felix L. Winkelmann5; All rights reserved.6;7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following8; conditions are met:9;10; Redistributions of source code must retain the above copyright notice, this list of conditions and the following11; disclaimer.12; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following13; disclaimer in the documentation and/or other materials provided with the distribution.14; Neither the name of the author nor the names of its contributors may be used to endorse or promote15; products derived from this software without specific prior written permission.16;17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE25; POSSIBILITY OF SUCH DAMAGE.262728(declare29 (unit chicken-ffi-syntax)30 (uses data-structures extras internal)31 (disable-interrupts)32 (fixnum))3334#+(not debugbuild)35(declare36 (no-bound-checks)37 (no-procedure-checks))3839(import scheme40 chicken.base41 chicken.format42 chicken.internal43 chicken.platform44 chicken.syntax45 chicken.string)4647(include "common-declarations.scm")48(include "mini-srfi-1.scm")4950(define ##sys#chicken-ffi-macro-environment51 (let ((me0 (##sys#macro-environment)))5253;; IMPORTANT: These macros directly call fully qualified names from54;; the "chicken.compiler.c-backend" and "chicken.compiler.support"55;; modules. These are unbound in the interpreter, so check first:56(define (compiler-only-er-transformer transformer)57 (##sys#er-transformer58 (lambda (form r c)59 (if (feature? 'compiling)60 (transformer form r c)61 (syntax-error62 (car form) "The FFI is not supported in interpreted mode")))))6364(##sys#extend-macro-environment65 'define-external66 `((define . ,(alist-ref 'define me0)) ; Or just me0?67 (begin . ,(alist-ref 'begin me0))68 (lambda . ,(alist-ref 'lambda me0)))69 (compiler-only-er-transformer70 (lambda (form r c)71 (let* ((form (cdr form))72 (quals (and (pair? form) (string? (car form))))73 (var (and (not quals) (pair? form) (symbol? (car form)))) )74 (cond [var75 (##sys#check-syntax 'define-external form '(symbol _ . #(_ 0 1)))76 (let ([var (car form)])77 `(,(r 'begin)78 (##core#define-foreign-variable ,var ,(cadr form))79 (##core#define-external-variable ,var ,(cadr form) #t)80 ,@(if (pair? (cddr form))81 `((##core#set! ,var ,(caddr form)))82 '() ) ) ) ]83 [else84 (if quals85 (##sys#check-syntax 'define-external form '(string (symbol . #((_ symbol) 0)) _ . #(_ 1)))86 (##sys#check-syntax 'define-external form '((symbol . #((_ symbol) 0)) _ . #(_ 1))) )87 (let* ((head (if quals (cadr form) (car form)))88 (args (cdr head)) )89 `(,(r 'define) ,(car head)90 (##core#foreign-callback-wrapper91 (##core#quote ,(car head))92 ,(if quals (car form) "")93 (##core#quote ,(if quals (caddr form) (cadr form)))94 (##core#quote ,(map (lambda (a) (car a)) args))95 (,(r 'lambda)96 ,(map (lambda (a) (cadr a)) args)97 ,@(if quals (cdddr form) (cddr form)) ) ) ) ) ] ) ) ) ) )9899100101;;; External locations:102103(##sys#extend-macro-environment104 'location105 '()106 (compiler-only-er-transformer107 (lambda (x r c)108 (##sys#check-syntax 'location x '(location _))109 `(##core#location ,(cadr x)))))110111(##sys#extend-macro-environment112 'define-location113 `((begin . ,(alist-ref 'begin me0)))114 (compiler-only-er-transformer115 (lambda (form r c)116 (##sys#check-syntax 'define-location form '(_ variable _ . #(_ 0 1)))117 (let ((var (cadr form))118 (type (caddr form))119 (init (optional (cdddr form) #f))120 (name (r (gensym))))121 `(,(r 'begin)122 (##core#define-foreign-variable ,var ,type ,(symbol->string name))123 (##core#define-external-variable ,var ,type #f ,name)124 ,@(if (pair? init)125 `((##core#set! ,var ,(car init)))126 '() ) ) ) ) ) )127128(##sys#extend-macro-environment129 'let-location130 '()131 (compiler-only-er-transformer132 (lambda (form r c)133 (##sys#check-syntax 'let-location form '(_ #((variable _ . #(_ 0 1)) 0) . _))134 (let* ((bindings (cadr form))135 (body (cddr form))136 (aliases (map (lambda (_) (r (gensym))) bindings)))137 `(##core#let138 ,(append-map139 (lambda (b a)140 (if (pair? (cddr b))141 (list (cons a (cddr b)))142 '() ) )143 bindings aliases)144 ,(let loop ((bindings bindings) (aliases aliases))145 (if (null? bindings)146 `(##core#let () ,@body)147 (let ((b (car bindings))148 (a (car aliases))149 (rest (loop (cdr bindings) (cdr aliases))))150 (if (= 3 (length b))151 `(##core#let-location152 ,(car b)153 ,(cadr b)154 ,a155 ,rest)156 `(##core#let-location157 ,(car b)158 ,(cadr b)159 ,rest) ) ))))))))160161162;;; Embedding code directly:163164(##sys#extend-macro-environment165 'foreign-code166 `((declare . ,(alist-ref 'declare me0)))167 (compiler-only-er-transformer168 (lambda (form r c)169 (##sys#check-syntax 'foreign-code form '(_ . #(string 0)))170 (let ([tmp (gensym 'code_)])171 `(##core#begin172 (,(r 'declare)173 (foreign-declare174 ,(sprintf "static C_word ~A() { ~A\n; return C_SCHEME_UNDEFINED; }\n"175 tmp176 (string-intersperse (cdr form) "\n")) ) )177 (##core#inline ,tmp) ) ) ) ) )178179(##sys#extend-macro-environment180 'foreign-value181 '()182 (compiler-only-er-transformer183 (lambda (form r c)184 (##sys#check-syntax 'foreign-value form '(_ _ _))185 (let ((tmp (gensym "code_"))186 (code (cadr form)))187 `(##core#begin188 (##core#define-foreign-variable ,tmp189 ,(caddr form)190 ,(cond ((string? code) code)191 ((symbol? code) (symbol->string code))192 (else193 (syntax-error194 'foreign-value195 "bad argument type - not a string or symbol"196 code))))197 (##core#the ,(chicken.compiler.support#foreign-type->scrutiny-type198 (chicken.syntax#strip-syntax (caddr form))199 'result)200 #f ,tmp) ) ) ) ) )201202203;;; Include foreign code fragments204205(##sys#extend-macro-environment206 'foreign-declare207 '()208 (compiler-only-er-transformer209 (lambda (form r c)210 (##sys#check-syntax 'foreign-declare form '(_ . #(string 0)))211 `(##core#declare (foreign-declare ,@(cdr form))))))212213214;;; Aliases for internal forms215216(define (annotate-foreign-procedure e argtypes rtype)217 (let ((scrut-atypes (map (cut chicken.compiler.support#foreign-type->scrutiny-type <> 'arg)218 (chicken.syntax#strip-syntax argtypes)))219 (scrut-rtype (and rtype220 (chicken.compiler.support#foreign-type->scrutiny-type221 (chicken.syntax#strip-syntax rtype) 'result))))222 ;; Don't add type annotation if the scrutinizer can infer the same223 ;; or better.224 ;;225 ;; At least these cases should work:226 ;;227 ;; (-> <some-known-type>) => annotate228 ;; (-> *) => no annotation229 ;; (* ... -> *) => no annotation230 ;;231 (if (and (or (not rtype) (eq? scrut-rtype '*))232 (every (cut eq? '* <>) scrut-atypes))233 e234 `(##core#the235 (procedure ,scrut-atypes236 ,@(if rtype237 (list scrut-rtype)238 ;; Special case for C_values(...). Only239 ;; triggered by foreign-primitive.240 '*))241 #f242 ,e))))243244(##sys#extend-macro-environment245 'define-foreign-type246 '()247 (compiler-only-er-transformer248 (lambda (form r c)249 (##sys#check-syntax 'define-foreign-type form '(_ symbol _ . #(_ 0 2)))250 `(##core#define-foreign-type ,@(cdr form)))))251252(##sys#extend-macro-environment253 'define-foreign-variable254 '()255 (compiler-only-er-transformer256 (lambda (form r c)257 (##sys#check-syntax 'define-foreign-variable form '(_ symbol _ . #(string 0 1)))258 `(##core#define-foreign-variable ,@(cdr form)))))259260(##sys#extend-macro-environment261 'foreign-primitive262 '()263 (compiler-only-er-transformer264 (lambda (form r c)265 (##sys#check-syntax 'foreign-primitive form '(_ _ . _))266 (let* ((hasrtype (and (pair? (cddr form)) (not (string? (caddr form)))))267 (rtype (and hasrtype (cadr form)))268 (args (if hasrtype (caddr form) (cadr form)))269 (argtypes (map car args)))270 (annotate-foreign-procedure `(##core#foreign-primitive ,@(cdr form))271 argtypes272 rtype)))))273274(##sys#extend-macro-environment275 'foreign-lambda276 '()277 (compiler-only-er-transformer278 (lambda (form r c)279 (##sys#check-syntax 'foreign-lambda form '(_ _ _ . _))280 (annotate-foreign-procedure `(##core#foreign-lambda ,@(cdr form))281 (cdddr form)282 (cadr form)))))283284(##sys#extend-macro-environment285 'foreign-lambda*286 '()287 (compiler-only-er-transformer288 (lambda (form r c)289 (##sys#check-syntax 'foreign-lambda* form '(_ _ _ _ . _))290 (annotate-foreign-procedure `(##core#foreign-lambda* ,@(cdr form))291 (map car (caddr form))292 (cadr form)))))293294(##sys#extend-macro-environment295 'foreign-safe-lambda296 '()297 (compiler-only-er-transformer298 (lambda (form r c)299 (##sys#check-syntax 'foreign-safe-lambda form '(_ _ _ . _))300 (annotate-foreign-procedure `(##core#foreign-safe-lambda ,@(cdr form))301 (cdddr form)302 (cadr form)))))303304(##sys#extend-macro-environment305 'foreign-safe-lambda*306 '()307 (compiler-only-er-transformer308 (lambda (form r c)309 (##sys#check-syntax 'foreign-safe-lambda* form '(_ _ _ _ . _))310 (annotate-foreign-procedure `(##core#foreign-safe-lambda* ,@(cdr form))311 (map car (caddr form))312 (cadr form)))))313314(##sys#extend-macro-environment315 'foreign-type-size316 '()317 (compiler-only-er-transformer318 (lambda (form r c)319 (##sys#check-syntax 'foreign-type-size form '(_ _))320 (let* ((t (chicken.syntax#strip-syntax (cadr form)))321 (tmp (gensym "code_"))322 (decl323 (if (string? t)324 t325 ;; TODO: Backend should be configurable326 (chicken.compiler.c-backend#foreign-type-declaration t ""))))327 `(##core#begin328 (##core#define-foreign-variable ,tmp size_t ,(string-append "sizeof(" decl ")"))329 (##core#the fixnum #f ,tmp))))))330331332(macro-subset me0)))