Coverage report: /home/ellis/comp/core/lib/syn/gen/c/sym.lisp

KindCoveredAll%
expression2169 1.2
branch026 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; sym.lisp --- GEN/C Symbols
2
 
3
 ;; 
4
 
5
 ;;; Code:
6
 (in-package :syn/gen/c/sym)
7
 
8
 ;;standard functions/macros
9
 (defmacro when (test &body forms)
10
   `(if ,test
11
            ,(cl:if (cadr forms)
12
                            `(progn ,@forms)
13
                            (car forms))))
14
 
15
 ;;; new cons with (t ...) and without "else {}"
16
 (defmacro cond (&rest clauses)
17
   (let ((head (first clauses)))
18
     (lisp
19
      (when head
20
        (if (eql (first head) t)
21
            (cons 'progn (cdr head))
22
            `(if ,(first head)
23
                 ,(when (cdr head)
24
                        (cons 'progn (cdr head)))
25
                 ,(when (cdr clauses)
26
                        `(cond ,@(cdr clauses)))))))))
27
 
28
 (defmacro 1+ (number)
29
   `(+ ,number 1))
30
 
31
 (defmacro 1- (number)
32
   `(- ,number 1))
33
 
34
 (defmacro cpp (&rest args)
35
   `(make-instance 'comment :comment ,(format nil "~{~a~^ ~}" args) :chars "#"))
36
 
37
 (defmacro pragma (&rest args)
38
   `(cpp "pragma" ,@args))
39
 
40
 ;; Code proposed by plops on issue #17
41
 ;; https://github.com/kiselgra/c-mera/issues/17
42
 (defun replace-newline-with-backslash-newline (string)
43
   ;; this is from common lisp cookbook i got it from here:
44
   ;; http://stackoverflow.com/questions/4366668/str-replace-in-lisp
45
   ;; i modified it to only search for newlines
46
   (lisp
47
    (let ((part #\Newline)
48
          (replacement "\\
49
 "))
50
      (with-output-to-string (out)
51
        (loop
52
          for old-pos = 0 then (+ pos 1)
53
          for pos = (position part string
54
                              :start old-pos
55
                              :test #'char=)
56
          do (write-string string out
57
                           :start old-pos
58
                           :end (or pos (cl:length string)))
59
          when pos do (write-string replacement out)
60
            while pos)))))
61
 
62
 (defmacro codestring (&body body)
63
   `(make-instance 'comment 
64
      :comment
65
      (format nil "\"~a\""
66
              (replace-newline-with-backslash-newline
67
               (with-output-to-string (*standard-output*)
68
                 (simple-print (progn ,@body)))))
69
      :chars ""))
70
 
71
 (defun symbol-append (&rest symbols)
72
   "Generate a symbol by combining the names of a number of symbols."
73
   (lisp
74
    (intern (apply #'concatenate 'string
75
                   (mapcar #'symbol-name symbols)))))
76
 
77
 (defun extract-parameter-names-from-lambda-list (args)
78
   "Find the names of all parameters in a DEFMACRO-sytle (i.e. nested) lambda list."
79
   (lisp
80
    (let* ((special 0)
81
           (plain (loop
82
                    for arg in args
83
                    for i from 1
84
                    until (member arg lambda-list-keywords)
85
                    if (listp arg) append (extract-parameter-names-from-lambda-list arg)
86
                      else collect arg
87
                    finally (setf special i))))
88
      (append plain
89
              (loop for arg in (common-lisp:subseq args special)
90
                    if (listp arg) collect (first arg)
91
                      else if (not (member arg lambda-list-keywords)) collect arg)))))
92
 
93
 (defun get-declaration-name (item)
94
   (let ((id (cl:if
95
              (let ((symbol (first (last (butlast item)))))
96
                (cl:and (symbolp symbol)
97
                        (equal (symbol-name symbol) "=")))
98
              (first (last item 3))
99
              (first (last item)))))
100
     (cl:if (cl:and (listp id)
101
                    (let ((first (first id)))
102
                       (cl:or (eql first 'aref)
103
                           (eql first 'array)
104
                           (eql first 'fpointer)
105
                           (eql first 'funcall))))
106
            (first (last (std:flatten (second id))))
107
            (first (std:flatten id)))))
108
 
109
 ;;; still useful
110
 (defmacro use-variables (&rest variables)
111
   `(progn
112
      ,@(loop for i in variables collect
113
          `(defparameter ,i ',i))
114
      (values)))
115
 
116
 (defmacro use-functions (&rest functions)
117
   `(progn
118
      ,@(loop for i in functions collect
119
          `(defmacro ,i (&rest body) `(funcall ,',i ,@body)))))
120
 
121
 ;;; shorthands
122
 (defmacro fn (&body body)
123
   `(function ,@body))