config

Personal configuration.
git clone git://code.dwrz.net/config
Log | Files | Refs

ob-C.el (17684B)


      1 ;;; ob-C.el --- Babel Functions for C and Similar Languages -*- lexical-binding: t; -*-
      2 
      3 ;; Copyright (C) 2010-2024 Free Software Foundation, Inc.
      4 
      5 ;; Author: Eric Schulte
      6 ;;      Thierry Banel
      7 ;; Maintainer: Thierry Banel <tbanelwebmin@free.fr>
      8 ;; Keywords: literate programming, reproducible research
      9 ;; URL: https://orgmode.org
     10 
     11 ;; This file is part of GNU Emacs.
     12 
     13 ;; GNU Emacs is free software: you can redistribute it and/or modify
     14 ;; it under the terms of the GNU General Public License as published by
     15 ;; the Free Software Foundation, either version 3 of the License, or
     16 ;; (at your option) any later version.
     17 
     18 ;; GNU Emacs is distributed in the hope that it will be useful,
     19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
     20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     21 ;; GNU General Public License for more details.
     22 
     23 ;; You should have received a copy of the GNU General Public License
     24 ;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
     25 
     26 ;;; Commentary:
     27 
     28 ;; Org-Babel support for evaluating C, C++, D code.
     29 ;;
     30 ;; very limited implementation:
     31 ;; - currently only support :results output
     32 ;; - not much in the way of error feedback
     33 
     34 ;;; Code:
     35 
     36 (require 'org-macs)
     37 (org-assert-version)
     38 
     39 (require 'cc-mode)
     40 (require 'ob)
     41 (require 'org-macs)
     42 
     43 (declare-function org-entry-get "org" (pom property &optional inherit literal-nil))
     44 
     45 (defvar org-babel-tangle-lang-exts)
     46 (add-to-list 'org-babel-tangle-lang-exts '("C++" . "cpp"))
     47 (add-to-list 'org-babel-tangle-lang-exts '("D" . "d"))
     48 
     49 (defvar org-babel-default-header-args:C '())
     50 
     51 (defconst org-babel-header-args:C '((includes . :any)
     52 				    (defines . :any)
     53 				    (main    . :any)
     54 				    (flags   . :any)
     55 				    (cmdline . :any)
     56 				    (libs    . :any))
     57   "C/C++-specific header arguments.")
     58 
     59 (defconst org-babel-header-args:C++
     60   (append '((namespaces . :any))
     61 	  org-babel-header-args:C)
     62   "C++-specific header arguments.")
     63 
     64 (defcustom org-babel-C-compiler "gcc"
     65   "Command used to compile a C source code file into an executable.
     66 May be either a command in the path, like gcc
     67 or an absolute path name, like /usr/local/bin/gcc
     68 parameter may be used, like gcc -v"
     69   :group 'org-babel
     70   :version "24.3"
     71   :type 'string)
     72 
     73 (defcustom org-babel-C++-compiler "g++"
     74   "Command used to compile a C++ source code file into an executable.
     75 May be either a command in the path, like g++
     76 or an absolute path name, like /usr/local/bin/g++
     77 parameter may be used, like g++ -v"
     78   :group 'org-babel
     79   :version "24.3"
     80   :type 'string)
     81 
     82 (defcustom org-babel-D-compiler "rdmd"
     83   "Command used to compile and execute a D source code file.
     84 May be either a command in the path, like rdmd
     85 or an absolute path name, like /usr/local/bin/rdmd
     86 parameter may be used, like rdmd --chatty"
     87   :group 'org-babel
     88   :version "24.3"
     89   :type 'string)
     90 
     91 (defvar org-babel-c-variant nil
     92   "Internal variable used to hold which type of C (e.g. C or C++ or D)
     93 is currently being evaluated.")
     94 
     95 (defun org-babel-execute:cpp (body params)
     96   "Execute BODY according to its header arguments PARAMS.
     97 This function calls `org-babel-execute:C++'."
     98   (org-babel-execute:C++ body params))
     99 
    100 (defun org-babel-expand-body:cpp (body params)
    101   "Expand C++ BODY with org-babel according to its header arguments PARAMS."
    102   (org-babel-expand-body:C++ body params))
    103 
    104 (defun org-babel-execute:C++ (body params)
    105   "Execute C++ BODY with org-babel according to its header arguments PARAMS.
    106 This function is called by `org-babel-execute-src-block'."
    107   (let ((org-babel-c-variant 'cpp)) (org-babel-C-execute body params)))
    108 
    109 (defun org-babel-expand-body:C++ (body params)
    110   "Expand C++ BODY with org-babel according to its header arguments PARAMS."
    111   (let ((org-babel-c-variant 'cpp)) (org-babel-C-expand-C++ body params)))
    112 
    113 (defun org-babel-execute:D (body params)
    114   "Execute D BODY with org-babel according to its header arguments PARAMS.
    115 This function is called by `org-babel-execute-src-block'."
    116   (let ((org-babel-c-variant 'd)) (org-babel-C-execute body params)))
    117 
    118 (defun org-babel-expand-body:D (body params)
    119   "Expand D BODY with org-babel according to its header arguments PARAMS."
    120   (let ((org-babel-c-variant 'd)) (org-babel-C-expand-D body params)))
    121 
    122 (defun org-babel-execute:C (body params)
    123   "Execute a C BODY according to its header arguments PARAMS.
    124 This function is called by `org-babel-execute-src-block'."
    125   (let ((org-babel-c-variant 'c)) (org-babel-C-execute body params)))
    126 
    127 (defun org-babel-expand-body:C (body params)
    128   "Expand C BODY according to its header arguments PARAMS."
    129   (let ((org-babel-c-variant 'c)) (org-babel-C-expand-C body params)))
    130 
    131 (defun org-babel-C-execute (body params)
    132   "Execute C/C++/D BODY according to its header arguments PARAMS.
    133 This function should only be called by `org-babel-execute:C' or
    134 `org-babel-execute:C++' or `org-babel-execute:D'."
    135   (let* ((tmp-src-file (org-babel-temp-file
    136 			"C-src-"
    137 			(pcase org-babel-c-variant
    138 			  (`c ".c") (`cpp ".cpp") (`d ".d"))))
    139 	 (tmp-bin-file			;not used for D
    140 	  (org-babel-process-file-name
    141 	   (org-babel-temp-file "C-bin-" org-babel-exeext)))
    142 	 (cmdline (cdr (assq :cmdline params)))
    143 	 (cmdline (if cmdline (concat " " cmdline) ""))
    144 	 (flags (cdr (assq :flags params)))
    145 	 (flags (mapconcat 'identity
    146 			   (if (listp flags) flags (list flags)) " "))
    147 	 (libs (org-babel-read
    148 		(or (cdr (assq :libs params))
    149 		    (org-entry-get nil "libs" t))
    150 		nil))
    151 	 (libs (mapconcat #'identity
    152 			  (if (listp libs) libs (list libs))
    153 			  " "))
    154 	 (full-body
    155 	  (pcase org-babel-c-variant
    156 	    (`c (org-babel-C-expand-C body params))
    157 	    (`cpp (org-babel-C-expand-C++ body params))
    158 	    (`d (org-babel-C-expand-D body params)))))
    159     (with-temp-file tmp-src-file (insert full-body))
    160     (pcase org-babel-c-variant
    161       ((or `c `cpp)
    162        (org-babel-eval
    163 	(format "%s -o %s %s %s %s"
    164 		(pcase org-babel-c-variant
    165 		  (`c org-babel-C-compiler)
    166 		  (`cpp org-babel-C++-compiler))
    167 		tmp-bin-file
    168 		flags
    169 		(org-babel-process-file-name tmp-src-file)
    170 		libs)
    171 	""))
    172       (`d nil)) ;; no separate compilation for D
    173     (let ((results
    174 	   (org-babel-eval
    175 	    (pcase org-babel-c-variant
    176 	      ((or `c `cpp)
    177 	       (concat tmp-bin-file cmdline))
    178 	      (`d
    179 	       (format "%s %s %s %s"
    180 		       org-babel-D-compiler
    181 		       flags
    182 		       (org-babel-process-file-name tmp-src-file)
    183 		       cmdline)))
    184 	    "")))
    185       (when results
    186 	(setq results (org-remove-indentation results))
    187 	(org-babel-reassemble-table
    188 	 (org-babel-result-cond (cdr (assq :result-params params))
    189 	   results
    190 	   (let ((tmp-file (org-babel-temp-file "c-")))
    191 	     (with-temp-file tmp-file (insert results))
    192 	     (org-babel-import-elisp-from-file tmp-file)))
    193 	 (org-babel-pick-name
    194 	  (cdr (assq :colname-names params)) (cdr (assq :colnames params)))
    195 	 (org-babel-pick-name
    196 	  (cdr (assq :rowname-names params)) (cdr (assq :rownames params)))))
    197       )))
    198 
    199 (defun org-babel-C-expand-C++ (body params)
    200   "Expand C/C++ BODY with according to its header arguments PARAMS."
    201   (org-babel-C-expand-C body params))
    202 
    203 (defun org-babel-C-expand-C (body params)
    204   "Expand C/C++ BODY according to its header arguments PARAMS."
    205   (let ((vars (org-babel--get-vars params))
    206 	(colnames (cdr (assq :colname-names params)))
    207 	(main-p (not (string= (cdr (assq :main params)) "no")))
    208 	(includes (org-babel-read
    209 		   (cdr (assq :includes params))
    210 		   nil))
    211 	(defines (org-babel-read
    212 		  (cdr (assq :defines params))
    213 		  nil))
    214 	(namespaces (org-babel-read
    215 		     (cdr (assq :namespaces params))
    216 		     nil))
    217         (prologue (cdr (assq :prologue params)))
    218         (epilogue (cdr (assq :epilogue params))))
    219     (when (stringp includes)
    220       (setq includes (split-string includes)))
    221     (when (stringp namespaces)
    222       (setq namespaces (split-string namespaces)))
    223     (when (stringp defines)
    224       (let ((y nil)
    225 	    (result (list t)))
    226 	(dolist (x (split-string defines))
    227 	  (if (null y)
    228 	      (setq y x)
    229 	    (nconc result (list (concat y " " x)))
    230 	    (setq y nil)))
    231 	(setq defines (cdr result))))
    232     (setq body
    233           (concat
    234            (and prologue (concat prologue "\n"))
    235            body
    236            (and epilogue (concat "\n" epilogue "\n"))))
    237     (mapconcat 'identity
    238 	       (list
    239 		;; includes
    240 		(mapconcat
    241 		 (lambda (inc)
    242 		   ;; :includes '(<foo> <bar>) gives us a list of
    243 		   ;; symbols; convert those to strings.
    244 		   (when (symbolp inc) (setq inc (symbol-name inc)))
    245 		   (if (string-prefix-p "<" inc)
    246 		       (format "#include %s" inc)
    247 		     (format "#include \"%s\"" inc)))
    248 		 includes "\n")
    249 		;; defines
    250 		(mapconcat
    251 		 (lambda (inc) (format "#define %s" inc))
    252 		 (if (listp defines) defines (list defines)) "\n")
    253 		;; namespaces
    254 		(mapconcat
    255 		 (lambda (inc) (format "using namespace %s;" inc))
    256 		 namespaces
    257 		 "\n")
    258 		;; variables
    259 		(mapconcat 'org-babel-C-var-to-C vars "\n")
    260 		;; table sizes
    261 		(mapconcat 'org-babel-C-table-sizes-to-C vars "\n")
    262 		;; tables headers utility
    263 		(when colnames
    264 		  (org-babel-C-utility-header-to-C))
    265 		;; tables headers
    266 		(mapconcat (lambda (head)
    267                              (let* ((tblnm (car head))
    268                                     (tbl (cdr (car (let* ((el vars))
    269                                                      (while (not (or (equal tblnm (caar el)) (not el)))
    270                                                        (setq el (cdr el)))
    271                                                      el))))
    272                                     (type (org-babel-C-val-to-base-type tbl)))
    273                                (org-babel-C-header-to-C head type))) colnames "\n")
    274 		;; body
    275 		(if main-p
    276 		    (org-babel-C-ensure-main-wrap body)
    277 		  body) "\n") "\n")))
    278 
    279 (defun org-babel-C-expand-D (body params)
    280   "Expand D BODY according to its header arguments PARAMS."
    281   (let ((vars (org-babel--get-vars params))
    282 	(colnames (cdr (assq :colname-names params)))
    283 	(main-p (not (string= (cdr (assq :main params)) "no")))
    284 	(imports (or (cdr (assq :imports params))
    285 		     (org-babel-read (org-entry-get nil "imports" t)))))
    286     (when (stringp imports)
    287       (setq imports (split-string imports)))
    288     (setq imports (append imports '("std.stdio" "std.conv")))
    289     (mapconcat 'identity
    290 	       (list
    291 		"module mmm;"
    292 		;; imports
    293 		(mapconcat
    294 		 (lambda (inc) (format "import %s;" inc))
    295 		 imports "\n")
    296 		;; variables
    297 		(mapconcat 'org-babel-C-var-to-C vars "\n")
    298 		;; table sizes
    299 		(mapconcat 'org-babel-C-table-sizes-to-C vars "\n")
    300 		;; tables headers utility
    301 		(when colnames
    302 		  (org-babel-C-utility-header-to-C))
    303 		;; tables headers
    304 		(mapconcat (lambda (head)
    305                              (let* ((tblnm (car head))
    306                                     (tbl (cdr (car (let* ((el vars))
    307                                                      (while (not (or (equal tblnm (caar el)) (not el)))
    308                                                        (setq el (cdr el)))
    309                                                      el))))
    310                                     (type (org-babel-C-val-to-base-type tbl)))
    311                                (org-babel-C-header-to-C head type))) colnames "\n")
    312 		;; body
    313 		(if main-p
    314 		    (org-babel-C-ensure-main-wrap body)
    315 		  body) "\n") "\n")))
    316 
    317 (defun org-babel-C-ensure-main-wrap (body)
    318   "Wrap BODY in a \"main\" function call if none exists."
    319   (if (string-match "^[ \t]*[intvod]+[ \t\n\r]*main[ \t]*(.*)" body)
    320       body
    321     (format "int main() {\n%s\nreturn 0;\n}\n" body)))
    322 
    323 (defun org-babel-prep-session:C (_session _params)
    324   "Throw and error that sessions are not supported.
    325 This function does nothing as C is a compiled language with no support
    326 for sessions."
    327   (error "C is a compiled language -- no support for sessions"))
    328 
    329 (defun org-babel-load-session:C (_session _body _params)
    330   "Throw and error that sessions are not supported.
    331 This function does nothing as C is a compiled language with no support
    332 for sessions."
    333   (error "C is a compiled language -- no support for sessions"))
    334 
    335 ;; helper functions
    336 
    337 (defun org-babel-C-format-val (type val)
    338   "Handle the FORMAT part of TYPE with the data from VAL."
    339   (let ((format-data (cadr type)))
    340     (if (stringp format-data)
    341 	(cons "" (format format-data val))
    342       (funcall format-data val))))
    343 
    344 (defun org-babel-C-val-to-C-type (val)
    345   "Determine the type of VAL.
    346 Return a list (TYPE-NAME FORMAT).  TYPE-NAME should be the name of the type.
    347 FORMAT can be either a format string or a function which is called with VAL."
    348   (let* ((basetype (org-babel-C-val-to-base-type val))
    349 	 (type
    350 	  (pcase basetype
    351 	    (`integerp '("int" "%d"))
    352 	    (`floatp '("double" "%s")) ;; %f rounds, use %s to print the float literally
    353 	    (`stringp
    354 	     (list
    355 	      (if (eq org-babel-c-variant 'd) "string" "const char*")
    356 	      "\"%s\""))
    357             (_ (error "Unknown type %S" basetype)))))
    358     (cond
    359      ((integerp val) type) ;; an integer declared in the #+begin_src line
    360      ((floatp val) type) ;; a numeric declared in the #+begin_src line
    361      ((and (listp val) (listp (car val))) ;; a table
    362       `(,(car type)
    363 	(lambda (val)
    364 	  (cons
    365            (pcase org-babel-c-variant
    366              ((or `c `cpp) (format "[%d][%d]" (length val) (length (car val))))
    367              (`d           (format "[%d][%d]" (length (car val)) (length val))))
    368 	   (concat
    369 	    (if (eq org-babel-c-variant 'd) "[\n" "{\n")
    370 	    (mapconcat
    371 	     (lambda (v)
    372 	       (concat
    373 		(if (eq org-babel-c-variant 'd) " [" " {")
    374 		(mapconcat (lambda (w) (format ,(cadr type) w)) v ",")
    375 		(if (eq org-babel-c-variant 'd) "]" "}")))
    376 	     val
    377 	     ",\n")
    378 	    (if (eq org-babel-c-variant 'd) "\n]" "\n}"))))))
    379      ((or (listp val) (vectorp val)) ;; a list declared in the #+begin_src line
    380       `(,(car type)
    381 	(lambda (val)
    382 	  (cons
    383 	   (format "[%d]" (length val))
    384 	   (concat
    385 	    (if (eq org-babel-c-variant 'd) "[" "{")
    386 	    (mapconcat (lambda (v) (format ,(cadr type) v)) val ",")
    387 	    (if (eq org-babel-c-variant 'd) "]" "}"))))))
    388      (t ;; treat unknown types as string
    389       type))))
    390 
    391 (defun org-babel-C-val-to-base-type (val)
    392   "Determine the base type of VAL.
    393 The type is:
    394 - `integerp' if all base values are integers;
    395 - `floatp' if all base values are either floating points or integers;
    396 - `stringp' otherwise."
    397   (cond
    398    ((integerp val) 'integerp)
    399    ((floatp val) 'floatp)
    400    ((or (listp val) (vectorp val))
    401     (let ((type nil))
    402       (mapc (lambda (v)
    403 	      (pcase (org-babel-C-val-to-base-type v)
    404 		(`stringp (setq type 'stringp))
    405 		(`floatp
    406 		 (when (or (not type) (eq type 'integerp))
    407 		   (setq type 'floatp)))
    408 		(`integerp
    409 		 (unless type (setq type 'integerp)))))
    410 	    val)
    411       type))
    412    (t 'stringp)))
    413 
    414 (defun org-babel-C-var-to-C (pair)
    415   "Convert PAIR of (var . val) C variable assignment."
    416   ;; TODO list support
    417   (let ((var (car pair))
    418 	(val (cdr pair)))
    419     (when (symbolp val)
    420       (setq val (symbol-name val))
    421       (when (= (length val) 1)
    422 	(setq val (string-to-char val))))
    423     (let* ((type-data (org-babel-C-val-to-C-type val))
    424 	   (type (car type-data))
    425 	   (formatted (org-babel-C-format-val type-data val))
    426 	   (suffix (car formatted))
    427 	   (data (cdr formatted)))
    428       (pcase org-babel-c-variant
    429         ((or `c `cpp)
    430          (format "%s %s%s = %s;"
    431 	         type
    432 	         var
    433 	         suffix
    434 	         data))
    435         (`d
    436          (format "%s%s %s = %s;"
    437 	         type
    438 	         suffix
    439 	         var
    440 	         data))))))
    441 
    442 (defun org-babel-C-table-sizes-to-C (pair)
    443   "Create constants of table dimensions, if PAIR is a table."
    444   (when (listp (cdr pair))
    445     (cond
    446      ((listp (cadr pair)) ;; a table
    447       (concat
    448        (format "const int %s_rows = %d;" (car pair) (length (cdr pair)))
    449        "\n"
    450        (format "const int %s_cols = %d;" (car pair) (length (cadr pair)))))
    451      (t ;; a list declared in the #+begin_src line
    452       (format "const int %s_cols = %d;" (car pair) (length (cdr pair)))))))
    453 
    454 (defun org-babel-C-utility-header-to-C ()
    455   "Generate a utility function to convert a column name into a column number."
    456   (pcase org-babel-c-variant
    457     ((or `c `cpp)
    458      (concat
    459       "
    460 #ifndef _STRING_H
    461 #include <string.h>
    462 #endif
    463 int get_column_num (int nbcols, const char** header, const char* column)
    464 {
    465   int c;
    466   for (c=0; c<nbcols; c++)
    467     if (strcmp(header[c],column)==0)
    468       return c;
    469   return -1;
    470 }
    471 "))
    472     (`d
    473      "int get_column_num (string[] header, string column)
    474 {
    475   foreach (c, h; header)
    476     if (h==column)
    477       return to!int(c);
    478   return -1;
    479 }
    480 ")))
    481 
    482 (defun org-babel-C-header-to-C (head type)
    483   "Convert an elisp list of header table into a C or D vector
    484 specifying a variable with the name of the table."
    485   (unless noninteractive (message "%S" type))
    486   (let ((table (car head))
    487         (headers (cdr head))
    488         (typename (pcase type
    489                     (`integerp "int")
    490                     (`floatp "double")
    491                     (`stringp (pcase org-babel-c-variant
    492                                 ((or `c `cpp) "const char*")
    493                                 (`d "string"))))))
    494     (concat
    495      (pcase org-babel-c-variant
    496        ((or `c `cpp)
    497         (format "const char* %s_header[%d] = {%s};"
    498                 table
    499                 (length headers)
    500                 (mapconcat (lambda (h) (format "\"%s\"" h)) headers ",")))
    501        (`d
    502         (format "string[%d] %s_header = [%s];"
    503                 (length headers)
    504                 table
    505                 (mapconcat (lambda (h) (format "\"%s\"" h)) headers ","))))
    506      "\n"
    507      (pcase org-babel-c-variant
    508        ((or `c `cpp)
    509 	(format
    510 	 "%s %s_h (int row, const char* col) { return %s[row][get_column_num(%d,%s_header,col)]; }"
    511 	 typename table table (length headers) table))
    512        (`d
    513 	(format
    514 	 "%s %s_h (size_t row, string col) { return %s[row][get_column_num(%s_header,col)]; }"
    515          typename table table table))))))
    516 
    517 (provide 'ob-C)
    518 
    519 ;;; ob-C.el ends here