333 lines
14 KiB
Common Lisp
333 lines
14 KiB
Common Lisp
;;;-*- Mode: Lisp; Package: cl-user -*-
|
|
|
|
(in-package :cl-user)
|
|
|
|
;; Generate *********************************************************************************************
|
|
|
|
; PSTR(), PGM_P, and PROGRAM are unnecessary on ARM.
|
|
(defun process-text (stream string platform comments)
|
|
(when (or (eq platform :arm) (eq platform :esp) (eq platform :riscv))
|
|
(setq string (strip-pstr string))
|
|
(setq string (global-replace "PGM_P " "const char *" string))
|
|
(setq string (global-replace "PROGMEM " "" string)))
|
|
(write-no-comments stream string comments))
|
|
|
|
(defun write-no-comments (stream string comments)
|
|
(cond
|
|
(comments
|
|
(write-string string stream)
|
|
(terpri stream))
|
|
(t
|
|
(let ((start 0))
|
|
(loop
|
|
(let* ((com (search "/*" string :start2 start))
|
|
(ment (when com (search "*/" string :start2 com))))
|
|
(cond
|
|
((and com ment (char= (char string (+ com 2)) #\newline)) (write-string string stream :start start :end com) ; 32
|
|
(setq start (+ ment 3))) ; Swallow return too
|
|
(t (write-string string stream :start start)
|
|
(terpri stream)
|
|
(return)))))))))
|
|
|
|
(defun strip-pstr (string)
|
|
(let ((start 0) (result ""))
|
|
(loop
|
|
(let* ((pstr (search "PSTR(\"" string :start2 start))
|
|
(term (when pstr (search "\")" string :start2 (+ pstr 6)))))
|
|
(cond
|
|
((and pstr term)
|
|
(setq result (concatenate 'string result (subseq string start pstr) (subseq string (+ pstr 5) (+ term 1))))
|
|
(setq start (+ term 2)))
|
|
(t
|
|
(setq result (concatenate 'string result (subseq string start)))
|
|
(return result)))))))
|
|
|
|
(defun global-replace (target replace string)
|
|
(let ((start 0) (result "") (span (length target)))
|
|
(loop
|
|
(let ((pgmp (search target string :start2 start)))
|
|
(cond
|
|
(pgmp
|
|
(setq result (concatenate 'string result (subseq string start pgmp) replace))
|
|
(setq start (+ pgmp span)))
|
|
(t
|
|
(setq result (concatenate 'string result (subseq string start)))
|
|
(return result)))))))
|
|
|
|
(defun definition-p (string)
|
|
(cond
|
|
((null string) nil)
|
|
((stringp string)
|
|
(let* ((com (search "/*" string :start2 0))
|
|
(ment (when com (search "*/" string :start2 com))))
|
|
(not (and com ment (= com 1) (= ment (- (length string) 2))))))
|
|
(t t)))
|
|
|
|
(defun mappend (fn &rest lsts)
|
|
"maps elements in list and finally appends all resulted lists."
|
|
(apply #'append (apply #'mapcar fn lsts)))
|
|
|
|
;; (wildcards (if wildcard (reduce #'+ (map 'list #'(lambda (x) (1- (length x))) (cadar keywords))) 0))
|
|
|
|
#|
|
|
(defun do-keyword-enums (str keywords)
|
|
(let* ((wildcard (null (caar keywords)))
|
|
(only-wildcard (and wildcard (null (cdr keywords)))))
|
|
(dotimes (n (length keywords))
|
|
(destructuring-bind (cpu lists) (nth n keywords)
|
|
(let ((klist (mappend #'(lambda (x) (map 'list #'(lambda (y) (if (listp y) (car y) y)) (cdr x))) lists)))
|
|
(unless (and wildcard (zerop n)) (format str "#~[~:;el~]if defined(~a)~%" (if wildcard (1- n) n) cpu))
|
|
(format str "~{~a~%~}" (split-into-lines (format nil "~{K_~a,~^ ~}" klist))))))
|
|
(unless only-wildcard (format str "#endif~%"))))
|
|
|#
|
|
|
|
(defun do-keyword-progmems (str keywords i progmem)
|
|
(let* ((wildcard (null (caar keywords)))
|
|
(only-wildcard (and wildcard (null (cdr keywords))))
|
|
(j i))
|
|
(dotimes (n (length keywords))
|
|
(destructuring-bind (cpu lists) (nth n keywords)
|
|
(let ((klist (mappend #'(lambda (x) (cdr x)) lists)))
|
|
(when cpu
|
|
(setq j i)
|
|
(format str "#~[~:;el~]if defined(~a)~%" (if wildcard (1- n) n) cpu))
|
|
(dolist (k klist)
|
|
(format str "const char string~a[] ~a= \":~a\";~%" j progmem
|
|
(substitute #\- #\_ (string-downcase (if (consp k) (car k) k))))
|
|
(incf j)))
|
|
(unless cpu (setq i j))))
|
|
(if only-wildcard nil (format str "#endif~%"))))
|
|
|
|
(defun needs-&-prefix (a b)
|
|
(or
|
|
(and (eq a 'register) (listp b) (stringp (second b)) (char/= (char (second b) 0) #\())
|
|
(and (eq a 'register) (atom b))))
|
|
|
|
(defun docstring (definition enum string)
|
|
(cond
|
|
((null definition) nil)
|
|
((stringp definition)
|
|
(let* ((com (search "/*" definition :start2 0))
|
|
(ment (when com (search "*/" definition :start2 com))))
|
|
(when (and com ment) (subseq definition (+ com 3) (- ment 1)))))
|
|
((keywordp definition) nil)
|
|
((symbolp definition)
|
|
(let* ((definition (with-output-to-string (str) (funcall definition str enum string t)))
|
|
(com (search "/*" definition :start2 0))
|
|
(ment (when com (search "*/" definition :start2 com))))
|
|
(when (and com ment) (subseq definition (+ com 3) (- ment 1)))))
|
|
(t nil)))
|
|
|
|
(defun replace-linebreaks (string)
|
|
(let ((result "")
|
|
(start 0))
|
|
(loop
|
|
(let ((cr (position #\newline string :start start)))
|
|
(when (not cr) (return (concatenate 'string result (string-trim '(#\space) (subseq string start)))))
|
|
(setq result
|
|
(concatenate 'string result (string-trim '(#\space) (subseq string start cr)) "\\n\"" (string #\newline) "\""))
|
|
(setq start (+ 1 cr))))))
|
|
|
|
(defun do-keyword-table (str keywords i documentation)
|
|
(let* ((wildcard (null (caar keywords)))
|
|
(only-wildcard (and wildcard (null (cdr keywords))))
|
|
(docstring nil)
|
|
(j i))
|
|
(dotimes (n (length keywords))
|
|
(destructuring-bind (cpu lists) (nth n keywords)
|
|
(let ((klist (mappend #'(lambda (x) (mapcar #'(lambda (y) (cons (car x) y)) (cdr x))) lists)))
|
|
(when cpu
|
|
(setq j i)
|
|
(format str "#~[~:;el~]if defined(~a)~%" (if wildcard (1- n) n) cpu))
|
|
(dolist (k klist)
|
|
(destructuring-bind (a . b) k
|
|
(if documentation
|
|
(format str " { string~a, (fn_ptr_type)~:[~;&~]~a, ~a, ~:[NULL~;doc~a~] },~%"
|
|
j (needs-&-prefix a b) (if (listp b) (second b) b) (or a 0) docstring j)
|
|
(format str " { string~a, (fn_ptr_type)~:[~;&~]~a, ~a },~%"
|
|
j (needs-&-prefix a b) (if (listp b) (second b) b) (or a 0)))
|
|
(incf j))))
|
|
(unless cpu (setq i j))))
|
|
(if only-wildcard nil
|
|
(format str "#endif~%"))))
|
|
|
|
(defparameter *enums* '(NIL TEE NOTHING OPTIONAL FEATURES INITIALELEMENT ELEMENTTYPE TEST COLONA COLONB COLONC BIT AMPREST LAMBDA LET
|
|
LETSTAR CLOSURE PSTAR QUOTE CAR FIRST CDR REST NTH EQ CHAR DEFUN DEFVAR DEFCODE AREF STRINGFN FORMAT
|
|
PINMODE DIGITALWRITE ANALOGREAD REGISTER ANALOGREFERENCE))
|
|
|
|
(defun build (&optional (platform :avr) (comments nil) (documentation (find :doc *features*)))
|
|
(let* ((maxsymbol 0)
|
|
(definitions *definitions*)
|
|
(progmem (if (or (eq platform :arm) (eq platform :esp) (eq platform :riscv)) "" "PROGMEM "))
|
|
(keywords (eval (intern (format nil "*KEYWORDS-~a*" platform) :cl-user))))
|
|
(flet ((include (section str)
|
|
(let ((special (intern (format nil "*~a-~a*" section platform) :cl-user))
|
|
(default (intern (format nil "*~a*" section) :cl-user)))
|
|
(cond
|
|
((boundp special)
|
|
(let ((inc (eval special)))
|
|
(cond
|
|
((listp inc) (map nil #'(lambda (x) (process-text str x platform comments)) inc))
|
|
(t (process-text str inc platform comments)))))
|
|
((boundp default)
|
|
(let ((inc (eval default)))
|
|
(cond
|
|
((listp inc) (map nil #'(lambda (x) (process-text str x platform comments)) inc))
|
|
(t (process-text str inc platform comments)))))
|
|
(t nil)))))
|
|
;;
|
|
(with-open-file (str (capi:prompt-for-file "Output File" :operation :save :pathname "/Users/david/Desktop/") :direction :output)
|
|
;; Write preamble
|
|
; (include :header str)
|
|
(format str (eval (intern (format nil "*~a-~a*" :title platform) :cl-user)) *release* *date*)
|
|
(terpri str)
|
|
(include :header str)
|
|
(include :workspace str)
|
|
(include :macros str)
|
|
(include :constants str)
|
|
(include :typedefs str)
|
|
|
|
;; Collect enums we need to use in the C functions
|
|
(let (enumlist)
|
|
(dolist (section definitions)
|
|
(destructuring-bind (comment defs &optional prefix) section
|
|
(declare (ignore comment prefix))
|
|
(dolist (item defs)
|
|
(destructuring-bind (enum string min max definition) item
|
|
(declare (ignore string min max definition))
|
|
(when (member enum *enums*) (push enum enumlist))))))
|
|
|
|
;; Write enum declarations
|
|
(let ((enums (split-into-lines (format nil "~{~a, ~}" (reverse enumlist)) 12)))
|
|
(format str "~%enum builtins: builtin_t { ~{~a~%~} };~%" enums)))
|
|
|
|
;;
|
|
(include :global-variables str)
|
|
(include :error-handling str)
|
|
(include :setup-workspace str)
|
|
(include :make-objects str)
|
|
;; Write utilities
|
|
(include :feature-list str)
|
|
(include :garbage-collection str)
|
|
(include :compactimage str)
|
|
(include :make-filename str)
|
|
(include :saveimage str)
|
|
(include :tracing str)
|
|
(include :helper-functions str)
|
|
(include :association-lists str)
|
|
(include :array-utilities str)
|
|
(include :string-utilities str)
|
|
(include :closures str)
|
|
(include :in-place str)
|
|
(include :i2c-interface str)
|
|
(include :stream-interface str)
|
|
; (include :watchdog str)
|
|
(include :check-pins str)
|
|
(include :note str)
|
|
(include :sleep str)
|
|
(include :prettyprint str)
|
|
(include :assembler str)
|
|
#+interrupts
|
|
(include :interrupts str)
|
|
|
|
;; Write function definitions
|
|
(dolist (section definitions)
|
|
(destructuring-bind (comment defs &optional prefix) section
|
|
(declare (ignore prefix))
|
|
(when comment (format str "~%// ~a~%" comment))
|
|
(dolist (item defs)
|
|
(destructuring-bind (enum string min max definition) item
|
|
(declare (ignore min max))
|
|
(cond
|
|
((null (definition-p definition)) nil)
|
|
((stringp definition)
|
|
(process-text str definition platform comments))
|
|
((keywordp definition) nil)
|
|
((symbolp definition)
|
|
(funcall definition str enum string comments)
|
|
(format str "~%"))
|
|
(t nil))))))
|
|
|
|
;; Write symbol names
|
|
(format str "~%// Built-in symbol names~%")
|
|
(let ((i 0))
|
|
(dotimes (pass 2)
|
|
(dolist (section definitions)
|
|
(destructuring-bind (comment defs &optional prefix) section
|
|
(declare (ignore comment prefix))
|
|
(dolist (item defs)
|
|
(destructuring-bind (enum string min max definition) item
|
|
(declare (ignore definition min max))
|
|
(when (eq (plusp pass) (not (member enum *enums*)))
|
|
(let ((lower (string-downcase enum)))
|
|
(format str "const char string~a[] ~a= \"~a\";~%" i progmem (or string lower))
|
|
(setq maxsymbol (max maxsymbol (length (or string lower))))
|
|
(incf i))))))))
|
|
;; Do keywords
|
|
(do-keyword-progmems str keywords i progmem))
|
|
|
|
;; Write documentation strings
|
|
(when documentation
|
|
(format str "~%// Documentation strings~%")
|
|
(let ((i 0))
|
|
(dotimes (pass 2)
|
|
(dolist (section definitions)
|
|
(destructuring-bind (comment defs &optional prefix) section
|
|
(declare (ignore comment prefix))
|
|
(dolist (item defs)
|
|
(destructuring-bind (enum string min max definition) item
|
|
(declare (ignore min max))
|
|
(when (eq (plusp pass) (not (member enum *enums*)))
|
|
(let ((docstring (docstring definition enum string)))
|
|
(when docstring
|
|
(format str "const char doc~a[] ~a= \"~a\";~%" i progmem (replace-linebreaks docstring)))
|
|
(incf i))))))))))
|
|
|
|
;; Write table
|
|
(format str "~%// Built-in symbol lookup table~%")
|
|
(flet ((minmax (prefix min max)
|
|
(let ((pre (cond
|
|
((string= prefix "fn") 2)
|
|
((string= prefix "sp") 3)
|
|
((string= prefix "tf") 1)
|
|
(t 0))))
|
|
(+ (ash pre 6) (ash min 3) (min max 7)))))
|
|
(let ((i 0))
|
|
(format str "const tbl_entry_t lookup_table[] ~a= {~%" progmem)
|
|
(dotimes (pass 2)
|
|
(dolist (section definitions)
|
|
(destructuring-bind (comment defs &optional (prefix "fn")) section
|
|
(declare (ignore comment))
|
|
(dolist (item defs)
|
|
(destructuring-bind (enum string min max definition) item
|
|
(when (eq (plusp pass) (not (member enum *enums*)))
|
|
(let ((docstring (docstring definition enum string))
|
|
(lower (cond
|
|
((consp definition) (string-downcase (car definition)))
|
|
((keywordp definition) definition)
|
|
(t (string-downcase enum)))))
|
|
(if documentation
|
|
(format str " { string~a, ~:[NULL~2*~;~a_~a~], 0~3,'0o, ~:[NULL~;doc~a~] },~%"
|
|
i (definition-p definition) prefix lower (minmax prefix min max) docstring i)
|
|
(format str " { string~a, ~:[NULL~2*~;~a_~a~], 0~3,'0o },~%"
|
|
i (definition-p definition) prefix lower (minmax prefix min max)))
|
|
(incf i))))))))
|
|
; Do keywords
|
|
(do-keyword-table str keywords i documentation)
|
|
(format str "};~%")))
|
|
|
|
;; Write rest
|
|
(include :table str)
|
|
(include :eval str)
|
|
(include :print-functions str)
|
|
(include :read-functions str)
|
|
(when (eq platform :badge) (write-string *lisp-badge* str))
|
|
(include :setup1 str)
|
|
(format str (eval (intern (format nil "*~a*" :setup2) :cl-user)) *release*)
|
|
(terpri str)
|
|
(include :repl str)
|
|
(include :loop str)
|
|
maxsymbol))))
|
|
|
|
|
|
|