;;; -*- Mode: Scheme -*-

;;;; C Stub Generator for Scheme
;;;; Unix System Calls -- Syntax

;;; Copyright (c) 2009, Taylor R. Campbell
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;; * Redistributions of source code must retain the above copyright
;;;   notice, this list of conditions and the following disclaimer.
;;;
;;; * Redistributions in binary form must reproduce the above copyright
;;;   notice, this list of conditions and the following disclaimer in
;;;   the documentation and/or other materials provided with the
;;;   distribution.
;;;
;;; * Neither the names of the authors nor the names of contributors
;;;   may be used to endorse or promote products derived from this
;;;   software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

;;; This notation is very much suboptimal.

(define-syntax define-unix-syscall
  (syntax-rules ()
    ((DEFINE-UNIX-SYSCALL . stuff)
     (DEFINE-C . stuff))))

(define-syntax define-unix-syscall-procedure
  (syntax-rules ()
    ((DEFINE-UNIX-SYSCALL-PROCEDURE . stuff)
     (DEFINE-C-PROCEDURE . stuff))))

(define-syntax c-unix-syscall-failure
  (syntax-rules (C->SCHEME C-UNIX-SYSCALL-FAILURE)
    ((C-UNIX-SYSCALL-FAILURE
      C->SCHEME continuation
      (C-UNIX-SYSCALL-FAILURE syscall error-code retry-command))
     (SIMPLE-EXPRESSION continuation
                        C-EXPRESSION/UNIX-SYSCALL-FAILURE
                        syscall error-code retry-command))
    ((C-UNIX-SYSCALL-FAILURE C->SCHEME continuation ?USE)
     (SYNTACTIC-ERROR "Invalid C expression conversion:" ?USE))))

(define-syntactic-invoker c-expression/unix-syscall-failure)

(define-syntax define-unix-void-syscall
  (syntax-rules (C-DECLARE C-BEGIN)
    ((DEFINE-UNIX-VOID-SYSCALL (name parameter ...)
       (C-DECLARE declaration ...)
       (C-BEGIN command ...)
       syscall
       result
       wrapper)
     (PROCESS-PARAMETERS
      (DEFINE-UNIX-VOID-SYSCALL/PARAMETERS
        name
        (declaration ...)
        (command ...)
        syscall
        result
        wrapper)
      (parameter ...)))

    ((DEFINE-UNIX-VOID-SYSCALL (name parameter ...)
       (C-DECLARE declaration ...)
       (C-BEGIN command ...)
       syscall
       result)
     (DEFINE-UNIX-VOID-SYSCALL (name parameter ...)
       (C-DECLARE declaration ...)
       (C-BEGIN command ...)
       syscall
       result
       #F))

    ((DEFINE-UNIX-VOID-SYSCALL (name parameter ...)
       (C-DECLARE declaration ...)
       (C-BEGIN command ...)
       syscall)
     (DEFINE-UNIX-VOID-SYSCALL (name parameter ...)
       (C-DECLARE declaration ...)
       (C-BEGIN command ...)
       syscall
       (C-UNSPECIFIC)))

    ((DEFINE-UNIX-VOID-SYSCALL (name parameters ...)
       (C-DECLARE declaration ...)
       syscall rest ...)
     (DEFINE-UNIX-VOID-SYSCALL (name parameters ...)
       (C-DECLARE declaration ...)
       (C-BEGIN)
       syscall rest ...))

    ((DEFINE-UNIX-VOID-SYSCALL (name parameters ...)
       (C-BEGIN command ...)
       syscall rest ...)
     (DEFINE-UNIX-VOID-SYSCALL (name parameters ...)
       (C-DECLARE)
       (C-BEGIN command ...)
       syscall rest ...))

    ((DEFINE-UNIX-VOID-SYSCALL (name parameters ...)
       syscall rest ...)
     (DEFINE-UNIX-VOID-SYSCALL (name parameters ...)
       (C-DECLARE)
       (C-BEGIN)
       syscall rest ...))))

(define-syntax define-unix-void-syscall/parameters
  (syntax-rules ()
    ((DEFINE-UNIX-VOID-SYSCALL/PARAMETERS parameters name declarations commands
       (syscall argument ...)
       result
       wrapper)
     (C-COMMAND/UNIX-VOID-SYSCALL
      (DEFINE-UNIX-VOID-SYSCALL/CONTINUE
        name parameters declarations result wrapper)
      commands
      syscall
      (argument ...)))
    ((DEFINE-UNIX-VOID-SYSCALL/PARAMETERS
       ((scheme-name (scheme-expression c-parameter) ...) ...)
       name declarations commands syscall result wrapper)
     (C-COMMAND/UNIX-VOID-SYSCALL
      (DEFINE-UNIX-VOID-SYSCALL/CONTINUE
        name
        ((scheme-name (scheme-expression c-parameter) ...) ...)
        declarations
        result
        wrapper)
      commands syscall (scheme-name ...)))))

(define-syntactic-invoker c-command/unix-void-syscall)

(define-syntax define-unix-void-syscall/continue
  (syntax-rules ()
    ((DEFINE-UNIX-VOID-SYSCALL/CONTINUE command name parameters declarations
       result wrapper)
     (PROCESS-RESULT
      (DEFINE-UNIX-VOID-SYSCALL/FINISH name parameters declarations)
      (C-BEGIN command result)
      wrapper))))

(define-syntax define-unix-void-syscall/finish
  (syntax-rules ()
    ((DEFINE-UNIX-VOID-SYSCALL/FINISH result wrapper
       name parameters declarations)
     (DEFINE-C-PROCEDURE name parameters declarations result wrapper))))

(define-syntax define-unix-uint-syscall
  (syntax-rules (=>)
    ((DEFINE-UNIX-UINT-SYSCALL (name parameter ...)
       (=> result-type)
       syscall
       wrapper)
     (DEFINE-UNIX-UINT-SYSCALL* (name parameter ...)
       (C-DECLARE)
       (C-BEGIN)
       (=> result-type)
       syscall
       wrapper))

    ((DEFINE-UNIX-UINT-SYSCALL (name parameter ...) (=> result-type) syscall)
     (DEFINE-UNIX-UINT-SYSCALL (name parameter ...) (=> result-type) syscall
       #F))

    ((DEFINE-UNIX-UINT-SYSCALL (name parameter ...) syscall wrapper)
     (DEFINE-UNIX-UINT-SYSCALL (name parameter ...)
       (=> "int")
       syscall
       wrapper))

    ((DEFINE-UNIX-UINT-SYSCALL (name parameter ...) syscall)
     (DEFINE-UNIX-UINT-SYSCALL (name parameter ...) syscall #F))))

(define-syntax define-unix-uint-syscall*
  (syntax-rules (C-DECLARE C-BEGIN =>)
    ((DEFINE-UNIX-UINT-SYSCALL* (name parameter ...)
       (C-DECLARE declaration ...)
       (C-BEGIN command ...)
       (=> result-type result-name)
       syscall
       result
       wrapper)
     (PROCESS-PARAMETERS
      (DEFINE-UNIX-UINT-SYSCALL/PARAMETERS
        name
        (declaration ...)
        (command ...)
        result-type
        syscall
        (result-name . result)
        wrapper)
      (parameter ...)))

    ((DEFINE-UNIX-UINT-SYSCALL* (name parameter ...)
       (C-DECLARE declaration ...)
       (C-BEGIN command ...)
       (=> result-type result-name)
       syscall
       result)
     (PROCESS-PARAMETERS
      (DEFINE-UNIX-UINT-SYSCALL/PARAMETERS
        name
        (declaration ...)
        (command ...)
        result-type
        syscall
        (result-name . result)
        #F)
      (parameter ...)))

    ((DEFINE-UNIX-UINT-SYSCALL* (name parameter ...)
       (C-DECLARE declaration ...)
       (C-BEGIN command ...)
       (=> result-type)
       syscall
       wrapper)
     (PROCESS-PARAMETERS
      (DEFINE-UNIX-UINT-SYSCALL/PARAMETERS
        name
        (declaration ...)
        (command ...)
        result-type
        syscall
        #F
        wrapper)
      (parameter ...)))))

;;; Here we decide what parameters to pass to the system call.

(define-syntax define-unix-uint-syscall/parameters
  (syntax-rules ()
    ((DEFINE-UNIX-UINT-SYSCALL/PARAMETERS parameters name declarations commands
       result-type
       (syscall argument ...)
       #F
       wrapper)
     (C-EXPRESSION/UNIX-UINT-SYSCALL
      (DEFINE-UNIX-UINT-SYSCALL/CONTINUE wrapper
        name parameters declarations)
      commands result-type syscall (argument ...)))

    ((DEFINE-UNIX-UINT-SYSCALL/PARAMETERS parameters name declarations commands
       result-type
       (syscall argument ...)
       (result-name . result)
       wrapper)
     (C-FORMAT:DECLARE
      (DEFINE-UNIX-UINT-SYSCALL/DECLARATION
        name parameters declarations commands
        result-name result-type syscall (argument ...)
        result wrapper)
      result-type result-name))

    ((DEFINE-UNIX-UINT-SYSCALL/PARAMETERS
       ((scheme-name (expression c-parameter) ...) ...)
       name declarations commands
       result-type
       syscall
       #F
       wrapper)
     (C-EXPRESSION/UNIX-UINT-SYSCALL
      (DEFINE-UNIX-UINT-SYSCALL/CONTINUE wrapper
        name ((scheme-name (expression c-parameter) ...) ...) declarations)
      commands result-type syscall (scheme-name ...)))

    ((DEFINE-UNIX-UINT-SYSCALL/PARAMETERS
       ((scheme-name (expression c-parameter) ...) ...)
       name declarations commands
       result-type
       syscall
       (result-name . result)
       wrapper)
     (C-FORMAT:DECLARE
      (DEFINE-UNIX-UINT-SYSCALL/DECLARATION
        name ((scheme-name (expression c-parameter) ...) ...)
        declarations commands
        result-name result-type syscall (scheme-name ...)
        result wrapper)
      result-type result-name))))

(define-syntactic-invoker c-expression/unix-uint-syscall)
(define-syntactic-invoker c-format:declare)

(define-syntax define-unix-uint-syscall/declaration
  (syntax-rules ()
    ((DEFINE-UNIX-UINT-SYSCALL/DECLARATION declaration
       name parameters declarations commands
       result-name result-type syscall arguments
       result wrapper)
     (C-COMMAND/UNIX-UINT-SYSCALL
      (DEFINE-UNIX-UINT-SYSCALL/COMMAND
        name parameters (declaration . declarations) result wrapper)
      commands result-type result-name syscall arguments))))

(define-syntactic-invoker c-command/unix-uint-syscall)

(define-syntax define-unix-uint-syscall/command
  (syntax-rules ()
    ((DEFINE-UNIX-UINT-SYSCALL/COMMAND command
       name parameters declarations result wrapper)
     (PROCESS-RESULT
      (DEFINE-UNIX-UINT-SYSCALL/CONTINUE name parameters declarations)
      (C-BEGIN command result)
      wrapper))))

(define-syntax define-unix-uint-syscall/continue
  (syntax-rules ()
    ((DEFINE-UNIX-UINT-SYSCALL/CONTINUE result wrapper
       name parameters declarations)
     (DEFINE-UNIX-SYSCALL-PROCEDURE name parameters declarations result
       wrapper))))