Add PRAMGA EXTERN for declaring extern function signatures

src/parser.lisp

@@ -435,10 +435,6 @@ If the parser does not match, then it should return NIL.")
       ((:STUB)
        (parse-stub tok-lines))
 
-      ;; EXTERN DECLARATION
-      ((:EXTERN)
-       (parse-extern tok-lines))
-
       ;; CALL INSTRUCTION
       ((:CALL)
        (parse-call tok-lines))
@@ -447,6 +443,10 @@ If the parser does not match, then it should return NIL.")
       ((:PRAGMA)
        (parse-pragma tok-lines))
 
+      ;; EXTERN DECLARATION
+      ((:EXTERN)
+       (parse-extern tok-lines))
+
       ;; Measurement
       ((:MEASURE)
        (parse-measurement tok-lines))
@@ -904,23 +904,29 @@ FORMAL objects) which shadow memory names.")
 
 (defun parse-pragma (tok-lines)
   "Parse a PRAGMA out of the lines of tokens TOK-LINES."
-  (match-line ((op :PRAGMA) (word-tok :NAME) &rest word-toks) tok-lines
-    (multiple-value-bind (words non-words)
-        (take-until (lambda (tok) (not (member (token-type tok) '(:NAME :INTEGER)))) (cons word-tok word-toks))
-      (setf words (mapcar #'token-payload words))
-
-      (cond
-        ((null non-words)
-         (make-pragma words))
+  (match-line ((op :PRAGMA) word &rest word-toks) tok-lines
+    (let ((first-payload
+            (case (token-type word)
+              (:EXTERN "EXTERN")        
+              (:NAME (token-payload word))
+              (otherwise
+               (quil-parse-error "Expected PRAGMA expected :NAME or :EXTERN token.")))))
+
+      (multiple-value-bind (words non-words)
+          (take-until (lambda (tok) (not (member (token-type tok) '(:NAME :INTEGER)))) word-toks)
+        (setf words (cons first-payload (mapcar #'token-payload words)))
+        (cond
+          ((null non-words)
+           (make-pragma words))
 
-        ((endp (cdr non-words))
-         (let ((last-tok (first non-words)))
-           (unless (eql ':STRING (token-type last-tok))
-             (disappointing-token-error last-tok "a terminating string"))
-           (make-pragma words (token-payload last-tok))))
+          ((endp (cdr non-words))
+           (let ((last-tok (first non-words)))
+             (unless (eql ':STRING (token-type last-tok))
+               (disappointing-token-error last-tok "a terminating string"))
+             (make-pragma words (token-payload last-tok))))
 
-        (t
-         (quil-parse-error "Unexpected tokens near the end of a PRAGMA."))))))
+          (t
+           (quil-parse-error "Unexpected tokens near the end of a PRAGMA.")))))))
 
 (defun parse-include (tok-lines)
   "Parse an INCLUDE out of the lines of tokens TOK-LINES."

src/pragmas.lisp

@@ -151,6 +151,94 @@ Expected syntax: PRAGMA NON_VOLATILE identifier")
   (:display-string
    (princ-to-string (cl-quil::memory-name-region-name memory-name))))
 
+
+(defun tokenize-extern-signature (input)
+  (let ((pos 0)) 
+    (labels ((peek () (if (< pos (length input)) (elt input pos) nil))
+             (next () (prog1 (peek) (incf pos)))
+             (skip-whitespace ()
+               (loop :for c := (peek)
+                     :while (and c (eq #\Space c))
+                     :do (incf pos)))
+             (next-token ()
+               (skip-whitespace)
+               (a:if-let (next-char (next))
+                 (case next-char
+                   (#\( :LEFT-PAREN)
+                   (#\) :RIGHT-PAREN)
+                   (#\: :COLON)
+                   (#\, :COMMA)
+                   (#\[ :LEFT-BRACKET)
+                   (#\] :RIGHT-BRACKET)
+                   (otherwise
+                    (let ((token 
+                            (with-output-to-string (token)
+                              (princ next-char token)
+                              (loop :for c := (next)
+                                    :while c
+                                    :until (find c "[]():, ")
+                                    :do (princ c token)
+                                    :finally (when c (decf pos))))))
+                      (cond ((equal "mut" token)
+                             :MUT)
+                            ((every (a:conjoin (complement #'alpha-char-p) #'alphanumericp) token)
+                             (values :INT (parse-integer token)))
+                            (t
+                             (values :WORD token))))))
+                 nil)))
+      #'next-token)))
+
+(yacc:define-parser *extern-signature-grammar*
+  (:start-symbol signature)
+  (:terminals (:LEFT-PAREN :RIGHT-PAREN
+               :LEFT-BRACKET :RIGHT-BRACKET
+               :COMMA :COLON :MUT :INT :WORD))
+
+  (signature
+   (:WORD :LEFT-PAREN paramlist :RIGHT-PAREN
+          (lambda (&rest args) (third args)))
+   (:LEFT-PAREN paramlist :RIGHT-PAREN
+                (lambda (&rest args) (second args))))
+
+  (paramlist
+   (param :COMMA paramlist
+          (lambda (p i0 ps) (declare (ignore i0))
+            (cons p ps)))
+   (param (lambda (p) (list p))))
+
+  (param
+   (:WORD :COLON :MUT type
+          (lambda (var i0 mut type) (cons var (list :mut type))))
+   (:WORD :COLON type
+          (lambda (var i0 type) (cons var type))))
+
+  (type
+   (:WORD)
+   (:WORD :LEFT-BRACKET :INT :RIGHT-BRACKET
+          (lambda (word rb size lb)
+            (declare (ignore rb lb))
+            (format nil "~a[~a]" word size)))))
+
+(define-pragma "EXTERN" pragma-extern-signature
+  (:documentation "PRAGMA declaring the function signature of an extern.
+
+Expected syntax: PRAGMA EXTERN extern-name \"TYPE? \( (var : mut? TYPE)+ \)")
+  (:global t)
+  (:slots extern-name arity mut-arg-positions)
+  (:words name)
+  (:freeform-string function-signature-string)
+  (:initialization
+   (let ((parsed (yacc:parse-with-lexer
+                  (tokenize-extern-signature function-signature-string)
+                  *extern-signature-grammar*)))
+     (setf extern-name name)
+     (setf arity (length parsed))
+     (setf mut-arg-positions (loop :for rec :in parsed
+                                   :for pos :from 0
+                                   :when (eq :mut (second rec))
+                                     :collect pos)))))
+
+
 (defun parsed-program-has-pragma-p (parsed-program &optional (pragma-type 'pragma))
   "Return T if PARSED-PROGRAM's executable code contains any pragma. Optionally use PRAGMA-TYPE to restrict to a particular pragma type."
   (some (a:rcurry #'typep pragma-type)