Coverage report: /home/runner/work/geb/geb/src/entry/entry.lisp

KindCoveredAll%
expression2789 30.3
branch24 50.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 (in-package :geb.entry)
2
 
3
 (defparameter +command-line-spec+
4
   '((("input" #\i)
5
      :type string :documentation "Input geb file location")
6
     (("entry-point" #\e)
7
      :type string :documentation "The function to run, should be fully qualified I.E. geb::my-main")
8
     (("stlc" #\l)
9
      :type boolean :optional t :documentation "Use the simply typed lambda calculus frontend")
10
     (("output" #\o)
11
      :type string :optional t :documentation "Save the output to a file rather than printing")
12
     (("version" #\v)
13
      :type boolean :optional t :documentation "Prints the current version of the compiler")
14
     (("vampir" #\p)
15
      :type string :optional t :documentation "Return a vamp-ir expression")
16
     (("help" #\h #\?)
17
      :type boolean :optional t :documentation "The current help message")))
18
 
19
 (defun entry ()
20
   (setf uiop:*command-line-arguments* (uiop:command-line-arguments))
21
   (command-line-arguments:handle-command-line
22
    +command-line-spec+
23
    #'argument-handlers
24
    :name "geb"))
25
 
26
 (defparameter *no-input-text*
27
   "Please provide an input file with -p or see the help command with -h")
28
 
29
 (defun argument-handlers (&key help stlc output input entry-point vampir version)
30
   (flet ((run (stream)
31
            (cond (help
32
                   (command-line-arguments:show-option-help +command-line-spec+
33
                                                            :sort-names t))
34
                  (version
35
                   (format stream (asdf:component-version (asdf:find-system :geb))))
36
                  ((null input)
37
                   (format stream *no-input-text*))
38
                  (t
39
                   (load input)
40
                   (compile-down :vampir vampir
41
                                 :stlc stlc
42
                                 :entry entry-point
43
                                 :stream stream)))))
44
     (if output
45
         (with-open-file (file output :direction :output
46
                                      :if-exists :overwrite
47
                                      :if-does-not-exist :create)
48
           (run file))
49
         (run *standard-output*))))
50
 
51
 ;; this code is very bad please abstract out many of the components
52
 (defun compile-down (&key vampir stlc entry (stream *standard-output*))
53
   (let* ((name        (read-from-string entry))
54
          (eval        (eval name))
55
          (vampir-name (renaming-scheme (intern (symbol-name name) 'keyword))))
56
     (cond ((and vampir stlc)
57
            (geb.vampir:extract (to-circuit eval vampir-name) stream))
58
           (stlc
59
            (format stream "~A" (to-cat nil eval)))
60
           (vampir
61
            (geb.vampir:extract (to-circuit eval vampir-name) stream))
62
           (t
63
            (format stream eval)))))
64
 
65
 ;; Very bad of me, copying alucard code, please move elsewhere as
66
 ;; well!!
67
 
68
 (-> renaming-scheme (symbol) keyword)
69
 (defun renaming-scheme (symb)
70
   "Renames certain names to be valid for vampir"
71
   ;; the n here mutates a once only list, so no mutation at all!
72
   ;; at least after the first substitute
73
   (intern
74
    (~>> symb symbol-name
75
         (substitute #\_ #\-)
76
         (nsubstitute #\V #\&)
77
         (string-trim "*")
78
         (nsubstitute #\V #\%))
79
    :keyword))