From 40236913922e0395780cd7d90354546ecaf279f9 Mon Sep 17 00:00:00 2001 From: Bdale Garbee Date: Mon, 11 Dec 2017 22:15:46 -0700 Subject: update Releasing with changes discovered in 1.8.3 release process --- Releasing | 2 ++ 1 file changed, 2 insertions(+) diff --git a/Releasing b/Releasing index b8f8b75f..9a295f03 100644 --- a/Releasing +++ b/Releasing @@ -108,6 +108,7 @@ These are Bdale's notes on how to do a release. src/telegps-v2.0/{*.elf,*.ihx} \ src/telemega-v1.0/{*.elf,*.ihx} \ src/telemega-v2.0/{*.elf,*.ihx} \ + src/telemega-v3.0/{*.elf,*.ihx} \ src/telemetrum-v2.0/{*.elf,*.ihx} \ src/telemini-v3.0/{*.elf,*.ihx} \ ~/altusmetrumllc/Binaries/ @@ -122,6 +123,7 @@ These are Bdale's notes on how to do a release. src/telegps-v2.0/flash-loader/*.elf \ src/telemega-v1.0/flash-loader/*.elf \ src/telemega-v2.0/flash-loader/*.elf \ + src/telemega-v3.0/flash-loader/*.elf \ src/telemetrum-v2.0/flash-loader/*.elf \ src/telemini-v3.0/flash-loader/{*.elf,*.bin} \ ~/altusmetrumllc/Binaries/loaders/ -- cgit v1.2.3 From 5cf77306257517a3d1ec8cea85fca34f576a8f22 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 11 Dec 2017 22:36:00 -0800 Subject: doc: Don't 'publish' release notes, don't build pdf release notes All we use the release notes for is to include into the main AltOS page. Also remove the docinfo for these files so that information isn't duplicated for each set of release notes. Signed-off-by: Keith Packard --- doc/Makefile | 36 +++++++++++++++++++++--------------- doc/release-notes-0.7.1-docinfo.xml | 29 ----------------------------- doc/release-notes-0.8-docinfo.xml | 29 ----------------------------- doc/release-notes-0.9-docinfo.xml | 29 ----------------------------- doc/release-notes-0.9.2-docinfo.xml | 29 ----------------------------- doc/release-notes-1.0.1-docinfo.xml | 29 ----------------------------- doc/release-notes-1.1-docinfo.xml | 29 ----------------------------- doc/release-notes-1.1.1-docinfo.xml | 29 ----------------------------- doc/release-notes-1.2-docinfo.xml | 29 ----------------------------- doc/release-notes-1.2.1-docinfo.xml | 29 ----------------------------- doc/release-notes-1.3-docinfo.xml | 29 ----------------------------- doc/release-notes-1.3.1-docinfo.xml | 29 ----------------------------- doc/release-notes-1.3.2-docinfo.xml | 29 ----------------------------- doc/release-notes-1.4-docinfo.xml | 29 ----------------------------- doc/release-notes-1.4.1-docinfo.xml | 29 ----------------------------- doc/release-notes-1.4.2-docinfo.xml | 29 ----------------------------- doc/release-notes-1.5-docinfo.xml | 29 ----------------------------- doc/release-notes-1.6-docinfo.xml | 29 ----------------------------- doc/release-notes-1.6.1-docinfo.xml | 29 ----------------------------- doc/release-notes-1.6.2-docinfo.xml | 29 ----------------------------- doc/release-notes-1.6.3-docinfo.xml | 29 ----------------------------- doc/release-notes-1.6.4-docinfo.xml | 29 ----------------------------- doc/release-notes-1.6.5-docinfo.xml | 29 ----------------------------- doc/release-notes-1.6.8-docinfo.xml | 29 ----------------------------- doc/release-notes-1.7-docinfo.xml | 29 ----------------------------- doc/release-notes-1.8-docinfo.xml | 29 ----------------------------- doc/release-notes-1.8.1-docinfo.xml | 29 ----------------------------- doc/release-notes-1.8.2-docinfo.xml | 29 ----------------------------- doc/release-notes-1.8.3-docinfo.xml | 29 ----------------------------- doc/release-notes-docinfo.xml | 28 ---------------------------- 30 files changed, 21 insertions(+), 855 deletions(-) delete mode 100644 doc/release-notes-0.7.1-docinfo.xml delete mode 100644 doc/release-notes-0.8-docinfo.xml delete mode 100644 doc/release-notes-0.9-docinfo.xml delete mode 100644 doc/release-notes-0.9.2-docinfo.xml delete mode 100644 doc/release-notes-1.0.1-docinfo.xml delete mode 100644 doc/release-notes-1.1-docinfo.xml delete mode 100644 doc/release-notes-1.1.1-docinfo.xml delete mode 100644 doc/release-notes-1.2-docinfo.xml delete mode 100644 doc/release-notes-1.2.1-docinfo.xml delete mode 100644 doc/release-notes-1.3-docinfo.xml delete mode 100644 doc/release-notes-1.3.1-docinfo.xml delete mode 100644 doc/release-notes-1.3.2-docinfo.xml delete mode 100644 doc/release-notes-1.4-docinfo.xml delete mode 100644 doc/release-notes-1.4.1-docinfo.xml delete mode 100644 doc/release-notes-1.4.2-docinfo.xml delete mode 100644 doc/release-notes-1.5-docinfo.xml delete mode 100644 doc/release-notes-1.6-docinfo.xml delete mode 100644 doc/release-notes-1.6.1-docinfo.xml delete mode 100644 doc/release-notes-1.6.2-docinfo.xml delete mode 100644 doc/release-notes-1.6.3-docinfo.xml delete mode 100644 doc/release-notes-1.6.4-docinfo.xml delete mode 100644 doc/release-notes-1.6.5-docinfo.xml delete mode 100644 doc/release-notes-1.6.8-docinfo.xml delete mode 100644 doc/release-notes-1.7-docinfo.xml delete mode 100644 doc/release-notes-1.8-docinfo.xml delete mode 100644 doc/release-notes-1.8.1-docinfo.xml delete mode 100644 doc/release-notes-1.8.2-docinfo.xml delete mode 100644 doc/release-notes-1.8.3-docinfo.xml delete mode 100644 doc/release-notes-docinfo.xml diff --git a/doc/Makefile b/doc/Makefile index feb1de8f..aa266e75 100644 --- a/doc/Makefile +++ b/doc/Makefile @@ -186,7 +186,6 @@ SVG=\ telemini-v3.svg \ easymega.svg -RELNOTES_PDF=$(RELNOTES_INC:.inc=.pdf) RELNOTES_HTML=$(RELNOTES_INC:.inc=.html) ONEFILE_TXT_FILES=\ @@ -196,10 +195,13 @@ ONEFILE_TXT_FILES=\ ONEFILE_RAW_FILES=$(ONEFILE_TXT_FILES:.txt=.raw) ONEFILE_PDF_FILES=$(ONEFILE_TXT_FILES:.txt=.pdf) +ONEFILE_HTML_FILES=$(ONEFILE_TXT_FILES:.txt=.html) AM_HTML=am.html -HTML=altusmetrum.html micropeak.html telegps.html easymini.html $(RELNOTES_HTML) $(ONEFILE_HTML_FILES) +PUBLISH_HTML=altusmetrum.html micropeak.html telegps.html easymini.html $(ONEFILE_HTML_FILES) + +HTML=$(PUBLISH_HTML) $(RELNOTES_HTML) HTML_REVHISTORY=\ altusmetrum-revhistory.html \ @@ -207,7 +209,7 @@ HTML_REVHISTORY=\ telegps-revhistory.html \ easymini-revhistory.html -PDF=altusmetrum.pdf micropeak.pdf telegps.pdf easymini.pdf $(RELNOTES_PDF) $(ONEFILE_PDF_FILES) \ +PDF=altusmetrum.pdf micropeak.pdf telegps.pdf easymini.pdf $(ONEFILE_PDF_FILES) \ $(OUTLINE_PDF_FILES) FOP_STYLE=am-fo.xsl @@ -235,6 +237,8 @@ TEMPLATES_XSL=$(TEMPLATES_TMPL:.tmpl=.xsl) PDF_CONFIG_FILES=$(FOP_STYLE) $(COMMON_STYLE) $(FOP_XCONF) $(TEMPLATES_XSL) HTML_CONFIG_FILES=$(HTML_STYLE) $(COMMON_STYLE) $(TEMPLATES_XSL) +PUBLISH_DOC=$(PUBLISH_HTML) $(HTML_REVHISTORY) $(PDF) $(IMAGES) $(STYLESHEET) + DOC=$(HTML) $(HTML_REVHISTORY) $(PDF) $(IMAGES) $(STYLESHEET) .SUFFIXES: .tmpl .xsl .inc .txt .raw .pdf .html @@ -245,12 +249,12 @@ DOC=$(HTML) $(HTML_REVHISTORY) $(PDF) $(IMAGES) $(STYLESHEET) .inc.raw: sed -e 's/^[ ]*//' -e 's/^\\//' $*.inc > $@ -.raw.pdf: +.raw.html: a2x --verbose -a docinfo -f pdf --xsltproc-opts "--stringparam toc.section.depth 2" --xsl-file $(FOP_STYLE) --fop --fop-opts="-c $(FOP_XCONF)" $*.raw a2x --verbose -a docinfo -f xhtml --xsltproc-opts "--stringparam toc.section.depth 2" --xsl-file $(HTML_STYLE) --stylesheet=$(STYLESHEET) $*.raw case $* in release-notes*) ./fix-html $*.html ;; esac -.pdf.html: +.html.pdf: @touch $@ .tmpl.xsl: @@ -278,19 +282,21 @@ telemini-v3-outline.pdf: telemini-v3-outline.txt telemini-v3.svg install: all -publish: $(DOC) $(FONTS) - cp $(DOC) /home/bdale/web/altusmetrum/AltOS/doc/ - mkdir -p /home/bdale/web/altusmetrum/AltOS/doc/fonts/ - cp $(FONTS) /home/bdale/web/altusmetrum/AltOS/doc/fonts/ - (cd /home/bdale/web/altusmetrum ; \ - git add /home/bdale/web/altusmetrum/AltOS/doc/* ; \ - git add /home/bdale/web/altusmetrum/AltOS/doc/fonts/* ; \ +WEB_ROOT=/home/bdale/web/ + +publish: $(PUBLISH_DOC) $(FONTS) + cp $(PUBLISH_DOC) $(WEB_ROOT)/altusmetrum/AltOS/doc/ + mkdir -p $(WEB_ROOT)/altusmetrum/AltOS/doc/fonts/ + cp $(FONTS) $(WEB_ROOT)/altusmetrum/AltOS/doc/fonts/ + (cd $(WEB_ROOT)/altusmetrum ; \ + git add $(WEB_ROOT)/altusmetrum/AltOS/doc/* ; \ + git add $(WEB_ROOT)/altusmetrum/AltOS/doc/fonts/* ; \ echo "update docs" | \ - git commit -F - /home/bdale/web/altusmetrum/AltOS/doc/* /home/bdale/web/altusmetrum/AltOS/doc/fonts/* ; \ + git commit -F - $(WEB_ROOT)/altusmetrum/AltOS/doc/* $(WEB_ROOT)/altusmetrum/AltOS/doc/fonts/* ; \ git push) -publish-keithp: am.html $(DOC) $(FONTS) - scp -p am.html $(DOC) keithp.com:~keithp/public_html/altos +publish-keithp: am.html $(PUBLISH_DOC) $(FONTS) + scp -p am.html $(PUBLISH_DOC) keithp.com:~keithp/public_html/altos scp -p $(FONTS) keithp.com:~keithp/public_html/altos/fonts clean: diff --git a/doc/release-notes-0.7.1-docinfo.xml b/doc/release-notes-0.7.1-docinfo.xml deleted file mode 100644 index 9657f2a6..00000000 --- a/doc/release-notes-0.7.1-docinfo.xml +++ /dev/null @@ -1,29 +0,0 @@ - - Bdale - Garbee - bdale@gag.com - - - Keith - Packard - keithp@keithp.com - -29 September 2010 - - 2010 - Bdale Garbee and Keith Packard - - - - - - - - - This document is released under the terms of the - - Creative Commons ShareAlike 3.0 - - license. - - diff --git a/doc/release-notes-0.8-docinfo.xml b/doc/release-notes-0.8-docinfo.xml deleted file mode 100644 index d593da31..00000000 --- a/doc/release-notes-0.8-docinfo.xml +++ /dev/null @@ -1,29 +0,0 @@ - - Bdale - Garbee - bdale@gag.com - - - Keith - Packard - keithp@keithp.com - -24 November 2010 - - 2010 - Bdale Garbee and Keith Packard - - - - - - - - - This document is released under the terms of the - - Creative Commons ShareAlike 3.0 - - license. - - diff --git a/doc/release-notes-0.9-docinfo.xml b/doc/release-notes-0.9-docinfo.xml deleted file mode 100644 index 605472f2..00000000 --- a/doc/release-notes-0.9-docinfo.xml +++ /dev/null @@ -1,29 +0,0 @@ - - Bdale - Garbee - bdale@gag.com - - - Keith - Packard - keithp@keithp.com - -18 January 2011 - - 2011 - Bdale Garbee and Keith Packard - - - - - - - - - This document is released under the terms of the - - Creative Commons ShareAlike 3.0 - - license. - - diff --git a/doc/release-notes-0.9.2-docinfo.xml b/doc/release-notes-0.9.2-docinfo.xml deleted file mode 100644 index 40e53634..00000000 --- a/doc/release-notes-0.9.2-docinfo.xml +++ /dev/null @@ -1,29 +0,0 @@ - - Bdale - Garbee - bdale@gag.com - - - Keith - Packard - keithp@keithp.com - -19 March 2011 - - 2011 - Bdale Garbee and Keith Packard - - - - - - - - - This document is released under the terms of the - - Creative Commons ShareAlike 3.0 - - license. - - diff --git a/doc/release-notes-1.0.1-docinfo.xml b/doc/release-notes-1.0.1-docinfo.xml deleted file mode 100644 index 23972104..00000000 --- a/doc/release-notes-1.0.1-docinfo.xml +++ /dev/null @@ -1,29 +0,0 @@ - - Bdale - Garbee - bdale@gag.com - - - Keith - Packard - keithp@keithp.com - -24 August 2011 - - 2011 - Bdale Garbee and Keith Packard - - - - - - - - - This document is released under the terms of the - - Creative Commons ShareAlike 3.0 - - license. - - diff --git a/doc/release-notes-1.1-docinfo.xml b/doc/release-notes-1.1-docinfo.xml deleted file mode 100644 index 93273918..00000000 --- a/doc/release-notes-1.1-docinfo.xml +++ /dev/null @@ -1,29 +0,0 @@ - - Bdale - Garbee - bdale@gag.com - - - Keith - Packard - keithp@keithp.com - -13 September 2012 - - 2013 - Bdale Garbee and Keith Packard - - - - - - - - - This document is released under the terms of the - - Creative Commons ShareAlike 3.0 - - license. - - diff --git a/doc/release-notes-1.1.1-docinfo.xml b/doc/release-notes-1.1.1-docinfo.xml deleted file mode 100644 index 41ea12da..00000000 --- a/doc/release-notes-1.1.1-docinfo.xml +++ /dev/null @@ -1,29 +0,0 @@ - - Bdale - Garbee - bdale@gag.com - - - Keith - Packard - keithp@keithp.com - -16 September 2012 - - 2012 - Bdale Garbee and Keith Packard - - - - - - - - - This document is released under the terms of the - - Creative Commons ShareAlike 3.0 - - license. - - diff --git a/doc/release-notes-1.2-docinfo.xml b/doc/release-notes-1.2-docinfo.xml deleted file mode 100644 index ba2c9d56..00000000 --- a/doc/release-notes-1.2-docinfo.xml +++ /dev/null @@ -1,29 +0,0 @@ - - Bdale - Garbee - bdale@gag.com - - - Keith - Packard - keithp@keithp.com - -18 April 2013 - - 2013 - Bdale Garbee and Keith Packard - - - - - - - - - This document is released under the terms of the - - Creative Commons ShareAlike 3.0 - - license. - - diff --git a/doc/release-notes-1.2.1-docinfo.xml b/doc/release-notes-1.2.1-docinfo.xml deleted file mode 100644 index d0f08b9c..00000000 --- a/doc/release-notes-1.2.1-docinfo.xml +++ /dev/null @@ -1,29 +0,0 @@ - - Bdale - Garbee - bdale@gag.com - - - Keith - Packard - keithp@keithp.com - -21 May 2013 - - 2013 - Bdale Garbee and Keith Packard - - - - - - - - - This document is released under the terms of the - - Creative Commons ShareAlike 3.0 - - license. - - diff --git a/doc/release-notes-1.3-docinfo.xml b/doc/release-notes-1.3-docinfo.xml deleted file mode 100644 index aa569df4..00000000 --- a/doc/release-notes-1.3-docinfo.xml +++ /dev/null @@ -1,29 +0,0 @@ - - Bdale - Garbee - bdale@gag.com - - - Keith - Packard - keithp@keithp.com - -12 November 2013 - - 2013 - Bdale Garbee and Keith Packard - - - - - - - - - This document is released under the terms of the - - Creative Commons ShareAlike 3.0 - - license. - - diff --git a/doc/release-notes-1.3.1-docinfo.xml b/doc/release-notes-1.3.1-docinfo.xml deleted file mode 100644 index f67cf3b8..00000000 --- a/doc/release-notes-1.3.1-docinfo.xml +++ /dev/null @@ -1,29 +0,0 @@ - - Bdale - Garbee - bdale@gag.com - - - Keith - Packard - keithp@keithp.com - -21 January 2014 - - 2014 - Bdale Garbee and Keith Packard - - - - - - - - - This document is released under the terms of the - - Creative Commons ShareAlike 3.0 - - license. - - diff --git a/doc/release-notes-1.3.2-docinfo.xml b/doc/release-notes-1.3.2-docinfo.xml deleted file mode 100644 index 82b7677e..00000000 --- a/doc/release-notes-1.3.2-docinfo.xml +++ /dev/null @@ -1,29 +0,0 @@ - - Bdale - Garbee - bdale@gag.com - - - Keith - Packard - keithp@keithp.com - -24 January 2014 - - 2014 - Bdale Garbee and Keith Packard - - - - - - - - - This document is released under the terms of the - - Creative Commons ShareAlike 3.0 - - license. - - diff --git a/doc/release-notes-1.4-docinfo.xml b/doc/release-notes-1.4-docinfo.xml deleted file mode 100644 index 12a38ce5..00000000 --- a/doc/release-notes-1.4-docinfo.xml +++ /dev/null @@ -1,29 +0,0 @@ - - Bdale - Garbee - bdale@gag.com - - - Keith - Packard - keithp@keithp.com - -15 June 2014 - - 2014 - Bdale Garbee and Keith Packard - - - - - - - - - This document is released under the terms of the - - Creative Commons ShareAlike 3.0 - - license. - - diff --git a/doc/release-notes-1.4.1-docinfo.xml b/doc/release-notes-1.4.1-docinfo.xml deleted file mode 100644 index 6224b16e..00000000 --- a/doc/release-notes-1.4.1-docinfo.xml +++ /dev/null @@ -1,29 +0,0 @@ - - Bdale - Garbee - bdale@gag.com - - - Keith - Packard - keithp@keithp.com - -20 June 2014 - - 2014 - Bdale Garbee and Keith Packard - - - - - - - - - This document is released under the terms of the - - Creative Commons ShareAlike 3.0 - - license. - - diff --git a/doc/release-notes-1.4.2-docinfo.xml b/doc/release-notes-1.4.2-docinfo.xml deleted file mode 100644 index 8fd94324..00000000 --- a/doc/release-notes-1.4.2-docinfo.xml +++ /dev/null @@ -1,29 +0,0 @@ - - Bdale - Garbee - bdale@gag.com - - - Keith - Packard - keithp@keithp.com - -17 August 2014 - - 2014 - Bdale Garbee and Keith Packard - - - - - - - - - This document is released under the terms of the - - Creative Commons ShareAlike 3.0 - - license. - - diff --git a/doc/release-notes-1.5-docinfo.xml b/doc/release-notes-1.5-docinfo.xml deleted file mode 100644 index 0c0cace7..00000000 --- a/doc/release-notes-1.5-docinfo.xml +++ /dev/null @@ -1,29 +0,0 @@ - - Bdale - Garbee - bdale@gag.com - - - Keith - Packard - keithp@keithp.com - -6 September 2014 - - 2014 - Bdale Garbee and Keith Packard - - - - - - - - - This document is released under the terms of the - - Creative Commons ShareAlike 3.0 - - license. - - diff --git a/doc/release-notes-1.6-docinfo.xml b/doc/release-notes-1.6-docinfo.xml deleted file mode 100644 index 5ae58bb5..00000000 --- a/doc/release-notes-1.6-docinfo.xml +++ /dev/null @@ -1,29 +0,0 @@ - - Bdale - Garbee - bdale@gag.com - - - Keith - Packard - keithp@keithp.com - -8 January 2015 - - 2015 - Bdale Garbee and Keith Packard - - - - - - - - - This document is released under the terms of the - - Creative Commons ShareAlike 3.0 - - license. - - diff --git a/doc/release-notes-1.6.1-docinfo.xml b/doc/release-notes-1.6.1-docinfo.xml deleted file mode 100644 index dc0a2d67..00000000 --- a/doc/release-notes-1.6.1-docinfo.xml +++ /dev/null @@ -1,29 +0,0 @@ - - Bdale - Garbee - bdale@gag.com - - - Keith - Packard - keithp@keithp.com - -15 July 2015 - - 2015 - Bdale Garbee and Keith Packard - - - - - - - - - This document is released under the terms of the - - Creative Commons ShareAlike 3.0 - - license. - - diff --git a/doc/release-notes-1.6.2-docinfo.xml b/doc/release-notes-1.6.2-docinfo.xml deleted file mode 100644 index 78206e2a..00000000 --- a/doc/release-notes-1.6.2-docinfo.xml +++ /dev/null @@ -1,29 +0,0 @@ - - Bdale - Garbee - bdale@gag.com - - - Keith - Packard - keithp@keithp.com - -10 January 2016 - - 2016 - Bdale Garbee and Keith Packard - - - - - - - - - This document is released under the terms of the - - Creative Commons ShareAlike 3.0 - - license. - - diff --git a/doc/release-notes-1.6.3-docinfo.xml b/doc/release-notes-1.6.3-docinfo.xml deleted file mode 100644 index ce22ebcb..00000000 --- a/doc/release-notes-1.6.3-docinfo.xml +++ /dev/null @@ -1,29 +0,0 @@ - - Bdale - Garbee - bdale@gag.com - - - Keith - Packard - keithp@keithp.com - -6 May 2016 - - 2016 - Bdale Garbee and Keith Packard - - - - - - - - - This document is released under the terms of the - - Creative Commons ShareAlike 3.0 - - license. - - diff --git a/doc/release-notes-1.6.4-docinfo.xml b/doc/release-notes-1.6.4-docinfo.xml deleted file mode 100644 index 76af3557..00000000 --- a/doc/release-notes-1.6.4-docinfo.xml +++ /dev/null @@ -1,29 +0,0 @@ - - Bdale - Garbee - bdale@gag.com - - - Keith - Packard - keithp@keithp.com - -17 June 2016 - - 2016 - Bdale Garbee and Keith Packard - - - - - - - - - This document is released under the terms of the - - Creative Commons ShareAlike 3.0 - - license. - - diff --git a/doc/release-notes-1.6.5-docinfo.xml b/doc/release-notes-1.6.5-docinfo.xml deleted file mode 100644 index a07d6f0f..00000000 --- a/doc/release-notes-1.6.5-docinfo.xml +++ /dev/null @@ -1,29 +0,0 @@ - - Bdale - Garbee - bdale@gag.com - - - Keith - Packard - keithp@keithp.com - -4 July 2016 - - 2016 - Bdale Garbee and Keith Packard - - - - - - - - - This document is released under the terms of the - - Creative Commons ShareAlike 3.0 - - license. - - diff --git a/doc/release-notes-1.6.8-docinfo.xml b/doc/release-notes-1.6.8-docinfo.xml deleted file mode 100644 index 776c244c..00000000 --- a/doc/release-notes-1.6.8-docinfo.xml +++ /dev/null @@ -1,29 +0,0 @@ - - Bdale - Garbee - bdale@gag.com - - - Keith - Packard - keithp@keithp.com - -5 September 2016 - - 2016 - Bdale Garbee and Keith Packard - - - - - - - - - This document is released under the terms of the - - Creative Commons ShareAlike 3.0 - - license. - - diff --git a/doc/release-notes-1.7-docinfo.xml b/doc/release-notes-1.7-docinfo.xml deleted file mode 100644 index 61d77d92..00000000 --- a/doc/release-notes-1.7-docinfo.xml +++ /dev/null @@ -1,29 +0,0 @@ - - Bdale - Garbee - bdale@gag.com - - - Keith - Packard - keithp@keithp.com - -24 April 2017 - - 2017 - Bdale Garbee and Keith Packard - - - - - - - - - This document is released under the terms of the - - Creative Commons ShareAlike 3.0 - - license. - - diff --git a/doc/release-notes-1.8-docinfo.xml b/doc/release-notes-1.8-docinfo.xml deleted file mode 100644 index 3b40421a..00000000 --- a/doc/release-notes-1.8-docinfo.xml +++ /dev/null @@ -1,29 +0,0 @@ - - Bdale - Garbee - bdale@gag.com - - - Keith - Packard - keithp@keithp.com - -12 August 2017 - - 2017 - Bdale Garbee and Keith Packard - - - - - - - - - This document is released under the terms of the - - Creative Commons ShareAlike 3.0 - - license. - - diff --git a/doc/release-notes-1.8.1-docinfo.xml b/doc/release-notes-1.8.1-docinfo.xml deleted file mode 100644 index 29a4fe7a..00000000 --- a/doc/release-notes-1.8.1-docinfo.xml +++ /dev/null @@ -1,29 +0,0 @@ - - Bdale - Garbee - bdale@gag.com - - - Keith - Packard - keithp@keithp.com - -28 August 2017 - - 2017 - Bdale Garbee and Keith Packard - - - - - - - - - This document is released under the terms of the - - Creative Commons ShareAlike 3.0 - - license. - - diff --git a/doc/release-notes-1.8.2-docinfo.xml b/doc/release-notes-1.8.2-docinfo.xml deleted file mode 100644 index a5fbc6e2..00000000 --- a/doc/release-notes-1.8.2-docinfo.xml +++ /dev/null @@ -1,29 +0,0 @@ - - Bdale - Garbee - bdale@gag.com - - - Keith - Packard - keithp@keithp.com - -18 September 2017 - - 2017 - Bdale Garbee and Keith Packard - - - - - - - - - This document is released under the terms of the - - Creative Commons ShareAlike 3.0 - - license. - - diff --git a/doc/release-notes-1.8.3-docinfo.xml b/doc/release-notes-1.8.3-docinfo.xml deleted file mode 100644 index e0366586..00000000 --- a/doc/release-notes-1.8.3-docinfo.xml +++ /dev/null @@ -1,29 +0,0 @@ - - Bdale - Garbee - bdale@gag.com - - - Keith - Packard - keithp@keithp.com - -11 December 2017 - - 2017 - Bdale Garbee and Keith Packard - - - - - - - - - This document is released under the terms of the - - Creative Commons ShareAlike 3.0 - - license. - - diff --git a/doc/release-notes-docinfo.xml b/doc/release-notes-docinfo.xml deleted file mode 100644 index 4f842cde..00000000 --- a/doc/release-notes-docinfo.xml +++ /dev/null @@ -1,28 +0,0 @@ - - Bdale - Garbee - bdale@gag.com - - - Keith - Packard - keithp@keithp.com - - - 2015 - Bdale Garbee and Keith Packard - - - - - - - - - This document is released under the terms of the - - Creative Commons ShareAlike 3.0 - - license. - - -- cgit v1.2.3 From a15166c435f65cb36f487ec8e5a4ff558a7e0502 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 12 Dec 2017 15:15:41 -0800 Subject: altos/scheme: Add ao_scheme_vector.c Useful to include the code for implementing vectors Signed-off-by: Keith Packard --- src/scheme/ao_scheme_vector.c | 185 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 185 insertions(+) create mode 100644 src/scheme/ao_scheme_vector.c diff --git a/src/scheme/ao_scheme_vector.c b/src/scheme/ao_scheme_vector.c new file mode 100644 index 00000000..0114c5a9 --- /dev/null +++ b/src/scheme/ao_scheme_vector.c @@ -0,0 +1,185 @@ +/* + * Copyright © 2017 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +#ifdef AO_SCHEME_FEATURE_VECTOR + +static void vector_mark(void *addr) +{ + struct ao_scheme_vector *vector = addr; + unsigned int i; + + for (i = 0; i < vector->length; i++) { + ao_poly v = vector->vals[i]; + + ao_scheme_poly_mark(v, 1); + } +} + +static int vector_len_size(uint16_t length) +{ + return sizeof (struct ao_scheme_vector) + length * sizeof (ao_poly); +} + +static int vector_size(void *addr) +{ + struct ao_scheme_vector *vector = addr; + + return vector_len_size(vector->length); +} + +static void vector_move(void *addr) +{ + struct ao_scheme_vector *vector = addr; + unsigned int i; + + for (i = 0; i < vector->length; i++) + (void) ao_scheme_poly_move(&vector->vals[i], 1); +} + +const struct ao_scheme_type ao_scheme_vector_type = { + .mark = vector_mark, + .size = vector_size, + .move = vector_move, + .name = "vector", +}; + +struct ao_scheme_vector * +ao_scheme_vector_alloc(uint16_t length, ao_poly fill) +{ + struct ao_scheme_vector *vector; + unsigned int i; + + vector = ao_scheme_alloc(vector_len_size(length)); + if (!vector) + return NULL; + vector->type = AO_SCHEME_VECTOR; + vector->length = length; + for (i = 0; i < length; i++) + vector->vals[i] = fill; + return vector; +} + +void +ao_scheme_vector_write(ao_poly v) +{ + struct ao_scheme_vector *vector = ao_scheme_poly_vector(v); + unsigned int i; + + printf("#("); + for (i = 0; i < vector->length; i++) { + if (i != 0) + printf(" "); + if (vector->vals[i] == v) + printf ("..."); + else + ao_scheme_poly_write(vector->vals[i]); + } + printf(")"); +} + +void +ao_scheme_vector_display(ao_poly v) +{ + struct ao_scheme_vector *vector = ao_scheme_poly_vector(v); + unsigned int i; + + for (i = 0; i < vector->length; i++) { + if (vector->vals[i] == v) + printf("..."); + else + ao_scheme_poly_display(vector->vals[i]); + } +} + +static int32_t +ao_scheme_vector_offset(struct ao_scheme_vector *vector, ao_poly i) +{ + int32_t offset = ao_scheme_poly_integer(i); + + if (offset == AO_SCHEME_NOT_INTEGER) + ao_scheme_error(AO_SCHEME_INVALID, "vector index %v not integer", i); + if (offset < 0 || vector->length <= offset) { + ao_scheme_error(AO_SCHEME_INVALID, "vector index %v out of range (max %d)", + i, vector->length); + offset = AO_SCHEME_NOT_INTEGER; + } + return offset; +} + +ao_poly +ao_scheme_vector_get(ao_poly v, ao_poly i) +{ + struct ao_scheme_vector *vector = ao_scheme_poly_vector(v); + int32_t offset = ao_scheme_vector_offset(vector, i); + + if (offset == AO_SCHEME_NOT_INTEGER) + return AO_SCHEME_NIL; + return vector->vals[offset]; +} + +ao_poly +ao_scheme_vector_set(ao_poly v, ao_poly i, ao_poly p) +{ + struct ao_scheme_vector *vector = ao_scheme_poly_vector(v); + int32_t offset = ao_scheme_vector_offset(vector, i); + + if (offset == AO_SCHEME_NOT_INTEGER) + return AO_SCHEME_NIL; + return vector->vals[offset] = p; +} + +struct ao_scheme_vector * +ao_scheme_list_to_vector(struct ao_scheme_cons *cons) +{ + uint16_t length; + uint16_t i; + struct ao_scheme_vector *vector; + + length = (uint16_t) ao_scheme_cons_length (cons); + if (ao_scheme_exception) + return NULL; + + ao_scheme_cons_stash(0, cons); + vector = ao_scheme_vector_alloc(length, AO_SCHEME_NIL); + cons = ao_scheme_cons_fetch(0); + if (!vector) + return NULL; + i = 0; + while (cons) { + vector->vals[i++] = cons->car; + cons = ao_scheme_cons_cdr(cons); + } + return vector; +} + +struct ao_scheme_cons * +ao_scheme_vector_to_list(struct ao_scheme_vector *vector) +{ + unsigned int i; + uint16_t length = vector->length; + struct ao_scheme_cons *cons = NULL; + + for (i = length; i-- > 0;) { + ao_scheme_poly_stash(2, ao_scheme_vector_poly(vector)); + cons = ao_scheme_cons_cons(vector->vals[i], ao_scheme_cons_poly(cons)); + vector = ao_scheme_poly_vector(ao_scheme_poly_fetch(2)); + if (!cons) + return NULL; + } + return cons; +} + +#endif /* AO_SCHEME_FEATURE_VECTOR */ -- cgit v1.2.3 From d8c9024f3829dc3f241b16869f165f3ee01764f3 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 12 Dec 2017 15:25:51 -0800 Subject: altos/scheme: Support scheme subsetting via feature settings This provides for the creation of smaller versions of the interpreter, leaving out options like floating point numbers and vectors. Signed-off-by: Keith Packard --- src/scheme/Makefile | 15 +- src/scheme/ao_scheme.h | 86 ++++- src/scheme/ao_scheme_builtin.c | 47 ++- src/scheme/ao_scheme_builtin.txt | 165 +++++----- src/scheme/ao_scheme_const.scheme | 6 - src/scheme/ao_scheme_float.c | 3 + src/scheme/ao_scheme_int.c | 3 + src/scheme/ao_scheme_make_builtin | 116 ++++++- src/scheme/ao_scheme_make_const.c | 145 ++++++++- src/scheme/ao_scheme_mem.c | 6 + src/scheme/ao_scheme_poly.c | 33 +- src/scheme/ao_scheme_read.c | 68 +++- src/scheme/ao_scheme_read.h | 15 + src/scheme/test/.gitignore | 2 +- src/scheme/test/Makefile | 14 +- src/scheme/test/ao_scheme_os.h | 1 - src/scheme/test/ao_scheme_test.c | 2 + src/scheme/tiny-test/.gitignore | 1 + src/scheme/tiny-test/Makefile | 28 ++ src/scheme/tiny-test/ao_scheme_os.h | 72 +++++ src/scheme/tiny-test/ao_scheme_test.c | 141 ++++++++ src/scheme/tiny-test/ao_scheme_tiny_const.scheme | 389 +++++++++++++++++++++++ 22 files changed, 1178 insertions(+), 180 deletions(-) create mode 100644 src/scheme/tiny-test/.gitignore create mode 100644 src/scheme/tiny-test/Makefile create mode 100644 src/scheme/tiny-test/ao_scheme_os.h create mode 100644 src/scheme/tiny-test/ao_scheme_test.c create mode 100644 src/scheme/tiny-test/ao_scheme_tiny_const.scheme diff --git a/src/scheme/Makefile b/src/scheme/Makefile index dc36dde1..e600d5f7 100644 --- a/src/scheme/Makefile +++ b/src/scheme/Makefile @@ -1,12 +1,10 @@ -all: ao_scheme_builtin.h ao_scheme_const.h test/ao_scheme_test +all: ao_scheme_builtin.h make-const/ao_scheme_make_const test/ao-scheme tiny-test/ao-scheme-tiny clean: +cd make-const && make clean +cd test && make clean - rm -f ao_scheme_const.h ao_scheme_builtin.h - -ao_scheme_const.h: ao_scheme_const.scheme make-const/ao_scheme_make_const - make-const/ao_scheme_make_const -o $@ ao_scheme_const.scheme + +cd tiny-test && make clean + rm -f ao_scheme_builtin.h ao_scheme_builtin.h: ao_scheme_make_builtin ao_scheme_builtin.txt nickle ao_scheme_make_builtin ao_scheme_builtin.txt > $@ @@ -14,7 +12,10 @@ ao_scheme_builtin.h: ao_scheme_make_builtin ao_scheme_builtin.txt make-const/ao_scheme_make_const: FRC ao_scheme_builtin.h +cd make-const && make ao_scheme_make_const -test/ao_scheme_test: FRC ao_scheme_const.h ao_scheme_builtin.h - +cd test && make ao_scheme_test +test/ao-scheme: FRC ao_scheme_builtin.h make-const/ao_scheme_make_const + +cd test && make + +tiny-test/ao-scheme-tiny: FRC ao_scheme_builtin.h make-const/ao_scheme_make_const + +cd tiny-test && make FRC: diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index 2fa1ed60..db4417e5 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -23,6 +23,9 @@ #include #include +#define AO_SCHEME_BUILTIN_FEATURES +#include "ao_scheme_builtin.h" +#undef AO_SCHEME_BUILTIN_FEATURES #include #ifndef __BYTE_ORDER #include @@ -102,10 +105,25 @@ extern uint8_t ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribut #define AO_SCHEME_LAMBDA 8 #define AO_SCHEME_STACK 9 #define AO_SCHEME_BOOL 10 +#ifdef AO_SCHEME_FEATURE_BIGINT #define AO_SCHEME_BIGINT 11 -#define AO_SCHEME_FLOAT 12 +#define _AO_SCHEME_BIGINT AO_SCHEME_BIGINT +#else +#define _AO_SCHEME_BIGINT AO_SCHEME_BOOL +#endif +#ifdef AO_SCHEME_FEATURE_FLOAT +#define AO_SCHEME_FLOAT (_AO_SCHEME_BIGINT + 1) +#define _AO_SCHEME_FLOAT AO_SCHEME_FLOAT +#else +#define _AO_SCHEME_FLOAT _AO_SCHEME_BIGINT +#endif +#ifdef AO_SCHEME_FEATURE_VECTOR #define AO_SCHEME_VECTOR 13 -#define AO_SCHEME_NUM_TYPE 14 +#define _AO_SCHEME_VECTOR AO_SCHEME_VECTOR +#else +#define _AO_SCHEME_VECTOR _AO_SCHEME_FLOAT +#endif +#define AO_SCHEME_NUM_TYPE (_AO_SCHEME_VECTOR+1) /* Leave two bits for types to use as they please */ #define AO_SCHEME_OTHER_TYPE_MASK 0x3f @@ -182,25 +200,38 @@ struct ao_scheme_bool { uint16_t pad; }; -struct ao_scheme_bigint { - uint32_t value; -}; +#ifdef AO_SCHEME_FEATURE_FLOAT struct ao_scheme_float { uint8_t type; uint8_t pad1; uint16_t pad2; float value; }; +#endif +#ifdef AO_SCHEME_FEATURE_VECTOR struct ao_scheme_vector { uint8_t type; uint8_t pad1; uint16_t length; ao_poly vals[]; }; +#endif + +#define AO_SCHEME_MIN_INT (-(1 << (15 - AO_SCHEME_TYPE_SHIFT))) +#define AO_SCHEME_MAX_INT ((1 << (15 - AO_SCHEME_TYPE_SHIFT)) - 1) + +#ifdef AO_SCHEME_FEATURE_BIGINT +struct ao_scheme_bigint { + uint32_t value; +}; + +#define AO_SCHEME_MIN_BIGINT (-(1 << 24)) +#define AO_SCHEME_MAX_BIGINT ((1 << 24) - 1) #if __BYTE_ORDER == __LITTLE_ENDIAN + static inline uint32_t ao_scheme_int_bigint(int32_t i) { return AO_SCHEME_BIGINT | (i << 8); @@ -218,12 +249,9 @@ static inlint int32_t ao_scheme_bigint_int(uint32_t bi) { return (int32_t) (bi << 8) >> 8; } -#endif -#define AO_SCHEME_MIN_INT (-(1 << (15 - AO_SCHEME_TYPE_SHIFT))) -#define AO_SCHEME_MAX_INT ((1 << (15 - AO_SCHEME_TYPE_SHIFT)) - 1) -#define AO_SCHEME_MIN_BIGINT (-(1 << 24)) -#define AO_SCHEME_MAX_BIGINT ((1 << 24) - 1) +#endif /* __BYTE_ORDER */ +#endif /* AO_SCHEME_FEATURE_BIGINT */ #define AO_SCHEME_NOT_INTEGER 0x7fffffff @@ -433,6 +461,7 @@ ao_scheme_int_poly(int32_t i) return ((ao_poly) i << 2) | AO_SCHEME_INT; } +#ifdef AO_SCHEME_FEATURE_BIGINT static inline struct ao_scheme_bigint * ao_scheme_poly_bigint(ao_poly poly) { @@ -444,6 +473,7 @@ ao_scheme_bigint_poly(struct ao_scheme_bigint *bi) { return ao_scheme_poly(bi, AO_SCHEME_OTHER); } +#endif /* AO_SCHEME_FEATURE_BIGINT */ static inline char * ao_scheme_poly_string(ao_poly poly) @@ -493,6 +523,7 @@ ao_scheme_poly_bool(ao_poly poly) return ao_scheme_ref(poly); } +#ifdef AO_SCHEME_FEATURE_FLOAT static inline ao_poly ao_scheme_float_poly(struct ao_scheme_float *f) { @@ -507,7 +538,9 @@ ao_scheme_poly_float(ao_poly poly) float ao_scheme_poly_number(ao_poly p); +#endif +#ifdef AO_SCHEME_FEATURE_VECTOR static inline ao_poly ao_scheme_vector_poly(struct ao_scheme_vector *v) { @@ -519,6 +552,7 @@ ao_scheme_poly_vector(ao_poly poly) { return ao_scheme_ref(poly); } +#endif /* memory functions */ @@ -687,6 +721,7 @@ ao_scheme_atom_def(ao_poly atom, ao_poly val); void ao_scheme_int_write(ao_poly i); +#ifdef AO_SCHEME_FEATURE_BIGINT int32_t ao_scheme_poly_integer(ao_poly p); @@ -704,6 +739,19 @@ ao_scheme_bigint_write(ao_poly i); extern const struct ao_scheme_type ao_scheme_bigint_type; +#else + +#define ao_scheme_poly_integer ao_scheme_poly_int +#define ao_scheme_integer_poly ao_scheme_int_poly + +static inline int +ao_scheme_integer_typep(uint8_t t) +{ + return (t == AO_SCHEME_INT); +} + +#endif /* AO_SCHEME_FEATURE_BIGINT */ + /* vector */ void @@ -730,11 +778,14 @@ ao_scheme_vector_to_list(struct ao_scheme_vector *vector); extern const struct ao_scheme_type ao_scheme_vector_type; /* prim */ -void -ao_scheme_poly_write(ao_poly p); +void (*ao_scheme_poly_write_func(ao_poly p))(ao_poly p); +void (*ao_scheme_poly_display_func(ao_poly p))(ao_poly p); -void -ao_scheme_poly_display(ao_poly p); +static inline void +ao_scheme_poly_write(ao_poly p) { (*ao_scheme_poly_write_func(p))(p); } + +static inline void +ao_scheme_poly_display(ao_poly p) { (*ao_scheme_poly_display_func(p))(p); } int ao_scheme_poly_mark(ao_poly p, uint8_t note_cons); @@ -758,6 +809,7 @@ ao_poly ao_scheme_set_cond(struct ao_scheme_cons *cons); /* float */ +#ifdef AO_SCHEME_FEATURE_FLOAT extern const struct ao_scheme_type ao_scheme_float_type; void @@ -765,7 +817,9 @@ ao_scheme_float_write(ao_poly p); ao_poly ao_scheme_float_get(float value); +#endif +#ifdef AO_SCHEME_FEATURE_FLOAT static inline uint8_t ao_scheme_number_typep(uint8_t t) { @@ -774,6 +828,10 @@ ao_scheme_number_typep(uint8_t t) float ao_scheme_poly_number(ao_poly p); +#else +#define ao_scheme_number_typep ao_scheme_integer_typep +#define ao_scheme_poly_number ao_scheme_poly_integer +#endif /* builtin */ void diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index 1754e677..c0f636fa 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -325,15 +325,22 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) case builtin_minus: if (ao_scheme_integer_typep(ct)) ret = ao_scheme_integer_poly(-ao_scheme_poly_integer(ret)); +#ifdef AO_SCHEME_FEATURE_FLOAT else if (ct == AO_SCHEME_FLOAT) ret = ao_scheme_float_get(-ao_scheme_poly_number(ret)); +#endif break; case builtin_divide: - if (ao_scheme_integer_typep(ct) && ao_scheme_poly_integer(ret) == 1) - ; - else if (ao_scheme_number_typep(ct)) { - float v = ao_scheme_poly_number(ret); - ret = ao_scheme_float_get(1/v); + if (ao_scheme_integer_typep(ct) && ao_scheme_poly_integer(ret) == 1) { + } else { +#ifdef AO_SCHEME_FEATURE_FLOAT + if (ao_scheme_number_typep(ct)) { + float v = ao_scheme_poly_number(ret); + ret = ao_scheme_float_get(1/v); + } +#else + ret = ao_scheme_integer_poly(0); +#endif } break; default: @@ -344,30 +351,42 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) } else if (ao_scheme_integer_typep(rt) && ao_scheme_integer_typep(ct)) { int32_t r = ao_scheme_poly_integer(ret); int32_t c = ao_scheme_poly_integer(car); +#ifdef AO_SCHEME_FEATURE_FLOAT int64_t t; +#endif switch(op) { case builtin_plus: r += c; check_overflow: +#ifdef AO_SCHEME_FEATURE_FLOAT if (r < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < r) goto inexact; +#endif break; case builtin_minus: r -= c; goto check_overflow; break; case builtin_times: +#ifdef AO_SCHEME_FEATURE_FLOAT t = (int64_t) r * (int64_t) c; if (t < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < t) goto inexact; r = (int32_t) t; +#else + r = r * c; +#endif break; case builtin_divide: +#ifdef AO_SCHEME_FEATURE_FLOAT if (c != 0 && (r % c) == 0) r /= c; else goto inexact; +#else + r /= c; +#endif break; case builtin_quotient: if (c == 0) @@ -395,6 +414,7 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) ao_scheme_cons_stash(0, cons); ret = ao_scheme_integer_poly(r); cons = ao_scheme_cons_fetch(0); +#ifdef AO_SCHEME_FEATURE_FLOAT } else if (ao_scheme_number_typep(rt) && ao_scheme_number_typep(ct)) { float r, c; inexact: @@ -423,6 +443,7 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) ao_scheme_cons_stash(0, cons); ret = ao_scheme_float_get(r); cons = ao_scheme_cons_fetch(0); +#endif } else if (rt == AO_SCHEME_STRING && ct == AO_SCHEME_STRING && op == builtin_plus) { ao_scheme_cons_stash(0, cons); @@ -839,6 +860,7 @@ ao_scheme_do_pairp(struct ao_scheme_cons *cons) ao_poly ao_scheme_do_integerp(struct ao_scheme_cons *cons) { +#ifdef AO_SCHEME_FEATURE_BIGINT if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) return AO_SCHEME_NIL; switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) { @@ -848,21 +870,32 @@ ao_scheme_do_integerp(struct ao_scheme_cons *cons) default: return _ao_scheme_bool_false; } +#else + return ao_scheme_do_typep(AO_SCHEME_INT, cons); +#endif } ao_poly ao_scheme_do_numberp(struct ao_scheme_cons *cons) { +#if defined(AO_SCHEME_FEATURE_BIGINT) || defined(AO_SCHEME_FEATURE_FLOAT) if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) return AO_SCHEME_NIL; switch (ao_scheme_poly_type(ao_scheme_arg(cons, 0))) { case AO_SCHEME_INT: +#ifdef AO_SCHEME_FEATURE_BIGINT case AO_SCHEME_BIGINT: +#endif +#ifdef AO_SCHEME_FEATURE_FLOAT case AO_SCHEME_FLOAT: +#endif return _ao_scheme_bool_true; default: return _ao_scheme_bool_false; } +#else + return ao_scheme_do_integerp(cons); +#endif } ao_poly @@ -1017,6 +1050,8 @@ ao_scheme_do_jiffies_per_second(struct ao_scheme_cons *cons) return (ao_scheme_int_poly(AO_SCHEME_JIFFIES_PER_SECOND)); } +#ifdef AO_SCHEME_FEATURE_VECTOR + ao_poly ao_scheme_do_vector(struct ao_scheme_cons *cons) { @@ -1092,5 +1127,7 @@ ao_scheme_do_vectorp(struct ao_scheme_cons *cons) return ao_scheme_do_typep(AO_SCHEME_VECTOR, cons); } +#endif /* AO_SCHEME_FEATURE_VECTOR */ + #define AO_SCHEME_BUILTIN_FUNCS #include "ao_scheme_builtin.h" diff --git a/src/scheme/ao_scheme_builtin.txt b/src/scheme/ao_scheme_builtin.txt index 17f5ea0c..14f279a4 100644 --- a/src/scheme/ao_scheme_builtin.txt +++ b/src/scheme/ao_scheme_builtin.txt @@ -1,81 +1,84 @@ -f_lambda eval -f_lambda read -nlambda lambda -nlambda nlambda -nlambda macro -f_lambda car -f_lambda cdr -f_lambda cons -f_lambda last -f_lambda length -f_lambda list_copy list-copy -nlambda quote -atom quasiquote -atom unquote -atom unquote_splicing unquote-splicing -f_lambda set -macro setq set! -f_lambda def -nlambda cond -nlambda begin -nlambda while -f_lambda write -f_lambda display -f_lambda plus + string-append -f_lambda minus - -f_lambda times * -f_lambda divide / -f_lambda modulo modulo % -f_lambda remainder -f_lambda quotient -f_lambda equal = eq? eqv? -f_lambda less < string string>? -f_lambda less_equal <= string<=? -f_lambda greater_equal >= string>=? -f_lambda flush_output flush-output -f_lambda delay -f_lambda led -f_lambda save -f_lambda restore -f_lambda call_cc call-with-current-continuation call/cc -f_lambda collect -f_lambda nullp null? -f_lambda not -f_lambda listp list? -f_lambda pairp pair? -f_lambda integerp integer? exact? exact-integer? -f_lambda numberp number? real? -f_lambda booleanp boolean? -f_lambda set_car set-car! -f_lambda set_cdr set-cdr! -f_lambda symbolp symbol? -f_lambda list_to_string list->string -f_lambda string_to_list string->list -f_lambda symbol_to_string symbol->string -f_lambda string_to_symbol string->symbol -f_lambda stringp string? -f_lambda string_ref string-ref -f_lambda string_set string-set! -f_lambda string_copy string-copy -f_lambda string_length string-length -f_lambda procedurep procedure? -lambda apply -f_lambda read_char read-char -f_lambda write_char write-char -f_lambda exit -f_lambda current_jiffy current-jiffy -f_lambda current_second current-second -f_lambda jiffies_per_second jiffies-per-second -f_lambda finitep finite? -f_lambda infinitep infinite? -f_lambda inexactp inexact? -f_lambda sqrt -f_lambda vector_ref vector-ref -f_lambda vector_set vector-set! -f_lambda vector -f_lambda make_vector make-vector -f_lambda list_to_vector list->vector -f_lambda vector_to_list vector->list -f_lambda vector_length vector-length -f_lambda vectorp vector? +BIGINT feature bigint +all atom eof +all atom else +all f_lambda eval +all f_lambda read +all nlambda lambda +all nlambda nlambda +all nlambda macro +all f_lambda car +all f_lambda cdr +all f_lambda cons +all f_lambda last +all f_lambda length +all f_lambda list_copy list-copy +all nlambda quote +QUASI atom quasiquote +QUASI atom unquote +QUASI atom unquote_splicing unquote-splicing +all f_lambda set +all macro setq set! +all f_lambda def +all nlambda cond +all nlambda begin +all nlambda while +all f_lambda write +all f_lambda display +all f_lambda plus + string-append +all f_lambda minus - +all f_lambda times * +all f_lambda divide / +all f_lambda modulo modulo % +all f_lambda remainder +all f_lambda quotient +all f_lambda equal = eq? eqv? +all f_lambda less < string string>? +all f_lambda less_equal <= string<=? +all f_lambda greater_equal >= string>=? +all f_lambda flush_output flush-output +TIME f_lambda delay +GPIO f_lambda led +all f_lambda save +all f_lambda restore +all f_lambda call_cc call-with-current-continuation call/cc +all f_lambda collect +all f_lambda nullp null? +all f_lambda not +all f_lambda listp list? +all f_lambda pairp pair? +FLOAT f_lambda integerp integer? exact? exact-integer? +all f_lambda numberp number? real? +all f_lambda booleanp boolean? +all f_lambda set_car set-car! +all f_lambda set_cdr set-cdr! +all f_lambda symbolp symbol? +all f_lambda list_to_string list->string +all f_lambda string_to_list string->list +all f_lambda symbol_to_string symbol->string +all f_lambda string_to_symbol string->symbol +all f_lambda stringp string? +all f_lambda string_ref string-ref +all f_lambda string_set string-set! +all f_lambda string_copy string-copy +all f_lambda string_length string-length +all f_lambda procedurep procedure? +all lambda apply +all f_lambda read_char read-char +all f_lambda write_char write-char +all f_lambda exit +TIME f_lambda current_jiffy current-jiffy +TIME f_lambda current_second current-second +TIME f_lambda jiffies_per_second jiffies-per-second +FLOAT f_lambda finitep finite? +FLOAT f_lambda infinitep infinite? +FLOAT f_lambda inexactp inexact? +FLOAT f_lambda sqrt +VECTOR f_lambda vector_ref vector-ref +VECTOR f_lambda vector_set vector-set! +VECTOR f_lambda vector +VECTOR f_lambda make_vector make-vector +VECTOR f_lambda list_to_vector list->vector +VECTOR f_lambda vector_to_list vector->list +VECTOR f_lambda vector_length vector-length +VECTOR f_lambda vectorp vector? diff --git a/src/scheme/ao_scheme_const.scheme b/src/scheme/ao_scheme_const.scheme index ab6a309a..060fd955 100644 --- a/src/scheme/ao_scheme_const.scheme +++ b/src/scheme/ao_scheme_const.scheme @@ -805,9 +805,3 @@ ) (case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) - -;(define number->string (lambda (arg . opt) -; (let ((base (if (null? opt) 10 (car opt))) - ; -; - diff --git a/src/scheme/ao_scheme_float.c b/src/scheme/ao_scheme_float.c index 99249030..c026c6fb 100644 --- a/src/scheme/ao_scheme_float.c +++ b/src/scheme/ao_scheme_float.c @@ -15,6 +15,8 @@ #include "ao_scheme.h" #include +#ifdef AO_SCHEME_FEATURE_FLOAT + static void float_mark(void *addr) { (void) addr; @@ -150,3 +152,4 @@ ao_scheme_do_sqrt(struct ao_scheme_cons *cons) return ao_scheme_error(AO_SCHEME_INVALID, "%s: non-numeric", ao_scheme_poly_atom(_ao_scheme_atom_sqrt)->name); return ao_scheme_float_get(sqrtf(ao_scheme_poly_number(value))); } +#endif diff --git a/src/scheme/ao_scheme_int.c b/src/scheme/ao_scheme_int.c index 350a5d35..43d6b8e1 100644 --- a/src/scheme/ao_scheme_int.c +++ b/src/scheme/ao_scheme_int.c @@ -21,6 +21,8 @@ ao_scheme_int_write(ao_poly p) printf("%d", i); } +#ifdef AO_SCHEME_FEATURE_BIGINT + int32_t ao_scheme_poly_integer(ao_poly p) { @@ -77,3 +79,4 @@ ao_scheme_bigint_write(ao_poly p) printf("%d", ao_scheme_bigint_int(bi->value)); } +#endif /* AO_SCHEME_FEATURE_BIGINT */ diff --git a/src/scheme/ao_scheme_make_builtin b/src/scheme/ao_scheme_make_builtin index 8e9c2c0b..78f97789 100644 --- a/src/scheme/ao_scheme_make_builtin +++ b/src/scheme/ao_scheme_make_builtin @@ -1,6 +1,7 @@ #!/usr/bin/nickle typedef struct { + string feature; string type; string c_name; string[*] lisp_names; @@ -12,6 +13,7 @@ string[string] type_map = { "macro" => "MACRO", "f_lambda" => "F_LAMBDA", "atom" => "atom", + "feature" => "feature", }; string[*] @@ -19,9 +21,9 @@ make_lisp(string[*] tokens) { string[...] lisp = {}; - if (dim(tokens) < 3) + if (dim(tokens) < 4) return (string[1]) { tokens[dim(tokens) - 1] }; - return (string[dim(tokens)-2]) { [i] = tokens[i+2] }; + return (string[dim(tokens)-3]) { [i] = tokens[i+3] }; } builtin_t @@ -30,8 +32,9 @@ read_builtin(file f) { string[*] tokens = String::wordsplit(line, " \t"); return (builtin_t) { - .type = dim(tokens) > 0 ? type_map[tokens[0]] : "#", - .c_name = dim(tokens) > 1 ? tokens[1] : "#", + .feature = dim(tokens) > 0 ? tokens[0] : "#", + .type = dim(tokens) > 1 ? type_map[tokens[1]] : "#", + .c_name = dim(tokens) > 2 ? tokens[2] : "#", .lisp_names = make_lisp(tokens), }; } @@ -49,16 +52,37 @@ read_builtins(file f) { return builtins; } +void +dump_ifdef(builtin_t builtin) +{ + if (builtin.feature != "all") + printf("#ifdef AO_SCHEME_FEATURE_%s\n", builtin.feature); +} + +void +dump_endif(builtin_t builtin) +{ + if (builtin.feature != "all") + printf("#endif /* AO_SCHEME_FEATURE_%s */\n", builtin.feature); +} + bool is_atom(builtin_t b) = b.type == "atom"; +bool is_func(builtin_t b) = b.type != "atom" && b.type != "feature"; + +bool is_feature(builtin_t b) = b.type == "feature"; + void dump_ids(builtin_t[*] builtins) { printf("#ifdef AO_SCHEME_BUILTIN_ID\n"); printf("#undef AO_SCHEME_BUILTIN_ID\n"); printf("enum ao_scheme_builtin_id {\n"); for (int i = 0; i < dim(builtins); i++) - if (!is_atom(builtins[i])) + if (is_func(builtins[i])) { + dump_ifdef(builtins[i]); printf("\tbuiltin_%s,\n", builtins[i].c_name); + dump_endif(builtins[i]); + } printf("\t_builtin_last\n"); printf("};\n"); printf("#endif /* AO_SCHEME_BUILTIN_ID */\n"); @@ -71,9 +95,12 @@ dump_casename(builtin_t[*] builtins) { printf("static char *ao_scheme_builtin_name(enum ao_scheme_builtin_id b) {\n"); printf("\tswitch(b) {\n"); for (int i = 0; i < dim(builtins); i++) - if (!is_atom(builtins[i])) + if (is_func(builtins[i])) { + dump_ifdef(builtins[i]); printf("\tcase builtin_%s: return ao_scheme_poly_atom(_atom(\"%s\"))->name;\n", builtins[i].c_name, builtins[i].lisp_names[0]); + dump_endif(builtins[i]); + } printf("\tdefault: return \"???\";\n"); printf("\t}\n"); printf("}\n"); @@ -97,11 +124,13 @@ dump_arrayname(builtin_t[*] builtins) { printf("#undef AO_SCHEME_BUILTIN_ARRAYNAME\n"); printf("static const ao_poly builtin_names[] = {\n"); for (int i = 0; i < dim(builtins); i++) { - if (!is_atom(builtins[i])) { + if (is_func(builtins[i])) { + dump_ifdef(builtins[i]); printf("\t[builtin_%s] = _ao_scheme_atom_", builtins[i].c_name); cify_lisp(builtins[i].lisp_names[0]); printf(",\n"); + dump_endif(builtins[i]); } } printf("};\n"); @@ -114,10 +143,13 @@ dump_funcs(builtin_t[*] builtins) { printf("#undef AO_SCHEME_BUILTIN_FUNCS\n"); printf("const ao_scheme_func_t ao_scheme_builtins[] = {\n"); for (int i = 0; i < dim(builtins); i++) { - if (!is_atom(builtins[i])) + if (is_func(builtins[i])) { + dump_ifdef(builtins[i]); printf("\t[builtin_%s] = ao_scheme_do_%s,\n", builtins[i].c_name, builtins[i].c_name); + dump_endif(builtins[i]); + } } printf("};\n"); printf("#endif /* AO_SCHEME_BUILTIN_FUNCS */\n"); @@ -128,10 +160,12 @@ dump_decls(builtin_t[*] builtins) { printf("#ifdef AO_SCHEME_BUILTIN_DECLS\n"); printf("#undef AO_SCHEME_BUILTIN_DECLS\n"); for (int i = 0; i < dim(builtins); i++) { - if (!is_atom(builtins[i])) { + if (is_func(builtins[i])) { + dump_ifdef(builtins[i]); printf("ao_poly\n"); printf("ao_scheme_do_%s(struct ao_scheme_cons *cons);\n", builtins[i].c_name); + dump_endif(builtins[i]); } } printf("#endif /* AO_SCHEME_BUILTIN_DECLS */\n"); @@ -143,13 +177,16 @@ dump_consts(builtin_t[*] builtins) { printf("#undef AO_SCHEME_BUILTIN_CONSTS\n"); printf("struct builtin_func funcs[] = {\n"); for (int i = 0; i < dim(builtins); i++) { - if (!is_atom(builtins[i])) { + if (is_func(builtins[i])) { + dump_ifdef(builtins[i]); for (int j = 0; j < dim(builtins[i].lisp_names); j++) { - printf ("\t{ .name = \"%s\", .args = AO_SCHEME_FUNC_%s, .func = builtin_%s },\n", + printf ("\t{ .feature = \"%s\", .name = \"%s\", .args = AO_SCHEME_FUNC_%s, .func = builtin_%s },\n", + builtins[i].feature, builtins[i].lisp_names[j], builtins[i].type, builtins[i].c_name); } + dump_endif(builtins[i]); } } printf("};\n"); @@ -161,15 +198,60 @@ dump_atoms(builtin_t[*] builtins) { printf("#ifdef AO_SCHEME_BUILTIN_ATOMS\n"); printf("#undef AO_SCHEME_BUILTIN_ATOMS\n"); for (int i = 0; i < dim(builtins); i++) { - for (int j = 0; j < dim(builtins[i].lisp_names); j++) { - printf("#define _ao_scheme_atom_"); - cify_lisp(builtins[i].lisp_names[j]); - printf(" _atom(\"%s\")\n", builtins[i].lisp_names[j]); + if (!is_feature(builtins[i])) { + for (int j = 0; j < dim(builtins[i].lisp_names); j++) { + printf("#define _ao_scheme_atom_"); + cify_lisp(builtins[i].lisp_names[j]); + printf(" _atom(\"%s\")\n", builtins[i].lisp_names[j]); + } } } printf("#endif /* AO_SCHEME_BUILTIN_ATOMS */\n"); } +void +dump_atom_names(builtin_t[*] builtins) { + printf("#ifdef AO_SCHEME_BUILTIN_ATOM_NAMES\n"); + printf("#undef AO_SCHEME_BUILTIN_ATOM_NAMES\n"); + printf("static struct builtin_atom atoms[] = {\n"); + for (int i = 0; i < dim(builtins); i++) { + if (is_atom(builtins[i])) { + for (int j = 0; j < dim(builtins[i].lisp_names); j++) { + printf("\t{ .feature = \"%s\", .name = \"%s\" },\n", + builtins[i].feature, + builtins[i].lisp_names[j]); + } + } + } + printf("};\n"); + printf("#endif /* AO_SCHEME_BUILTIN_ATOM_NAMES */\n"); +} + +bool +has_feature(string[*] features, string feature) +{ + for (int i = 0; i < dim(features); i++) + if (features[i] == feature) + return true; + return false; +} + +void +dump_features(builtin_t[*] builtins) { + string[...] features = {}; + printf("#ifdef AO_SCHEME_BUILTIN_FEATURES\n"); + for (int i = 0; i < dim(builtins); i++) { + if (builtins[i].feature != "all") { + string feature = builtins[i].feature; + if (!has_feature(features, feature)) { + features[dim(features)] = feature; + printf("#define AO_SCHEME_FEATURE_%s\n", feature); + } + } + } + printf("#endif /* AO_SCHEME_BUILTIN_FEATURES */\n"); +} + void main() { if (dim(argv) < 2) { File::fprintf(stderr, "usage: %s \n", argv[0]); @@ -177,6 +259,8 @@ void main() { } twixt(file f = File::open(argv[1], "r"); File::close(f)) { builtin_t[*] builtins = read_builtins(f); + + printf("/* %d builtins */\n", dim(builtins)); dump_ids(builtins); dump_casename(builtins); dump_arrayname(builtins); @@ -184,6 +268,8 @@ void main() { dump_decls(builtins); dump_consts(builtins); dump_atoms(builtins); + dump_atom_names(builtins); + dump_features(builtins); } } diff --git a/src/scheme/ao_scheme_make_const.c b/src/scheme/ao_scheme_make_const.c index cf42ec52..6bd552f5 100644 --- a/src/scheme/ao_scheme_make_const.c +++ b/src/scheme/ao_scheme_make_const.c @@ -17,6 +17,7 @@ #include #include #include +#include static struct ao_scheme_builtin * ao_scheme_make_builtin(enum ao_scheme_builtin_id func, int args) { @@ -29,15 +30,25 @@ ao_scheme_make_builtin(enum ao_scheme_builtin_id func, int args) { } struct builtin_func { + char *feature; char *name; int args; enum ao_scheme_builtin_id func; }; +struct builtin_atom { + char *feature; + char *name; +}; + #define AO_SCHEME_BUILTIN_CONSTS +#define AO_SCHEME_BUILTIN_ATOM_NAMES + #include "ao_scheme_builtin.h" -#define N_FUNC (sizeof funcs / sizeof funcs[0]) +#define N_FUNC (sizeof funcs / sizeof funcs[0]) + +#define N_ATOM (sizeof atoms / sizeof atoms[0]) struct ao_scheme_frame *globals; @@ -228,6 +239,36 @@ ao_has_macro(ao_poly p) return p; } +static struct ao_scheme_builtin * +ao_scheme_get_builtin(ao_poly p) +{ + if (ao_scheme_poly_type(p) == AO_SCHEME_BUILTIN) + return ao_scheme_poly_builtin(p); + return NULL; +} + +struct seen_builtin { + struct seen_builtin *next; + struct ao_scheme_builtin *builtin; +}; + +static struct seen_builtin *seen_builtins; + +static int +ao_scheme_seen_builtin(struct ao_scheme_builtin *b) +{ + struct seen_builtin *s; + + for (s = seen_builtins; s; s = s->next) + if (s->builtin == b) + return 1; + s = malloc (sizeof (struct seen_builtin)); + s->builtin = b; + s->next = seen_builtins; + seen_builtins = s; + return 0; +} + int ao_scheme_read_eval_abort(void) { @@ -248,6 +289,47 @@ ao_scheme_read_eval_abort(void) static FILE *in; static FILE *out; +struct feature { + struct feature *next; + char name[]; +}; + +static struct feature *enable; +static struct feature *disable; + +void +ao_scheme_add_feature(struct feature **list, char *name) +{ + struct feature *feature = malloc (sizeof (struct feature) + strlen(name) + 1); + strcpy(feature->name, name); + feature->next = *list; + *list = feature; +} + +bool +ao_scheme_has_feature(struct feature *list, char *name) +{ + while (list) { + if (!strcmp(list->name, name)) + return true; + list = list->next; + } + return false; +} + +void +ao_scheme_add_features(struct feature **list, char *names) +{ + char *saveptr = NULL; + char *name; + + while ((name = strtok_r(names, ",", &saveptr)) != NULL) { + names = NULL; + if (!ao_scheme_has_feature(*list, name)) + ao_scheme_add_feature(list, name); + } +} + int ao_scheme_getc(void) { @@ -256,19 +338,21 @@ ao_scheme_getc(void) static const struct option options[] = { { .name = "out", .has_arg = 1, .val = 'o' }, + { .name = "disable", .has_arg = 1, .val = 'd' }, + { .name = "enable", .has_arg = 1, .val = 'e' }, { 0, 0, 0, 0 } }; static void usage(char *program) { - fprintf(stderr, "usage: %s [--out=] [input]\n", program); + fprintf(stderr, "usage: %s [--out=] [--disable={feature,...}] [--enable={feature,...} [input]\n", program); exit(1); } int main(int argc, char **argv) { - int f, o; + int f, o, an; ao_poly val; struct ao_scheme_atom *a; struct ao_scheme_builtin *b; @@ -276,15 +360,23 @@ main(int argc, char **argv) char *out_name = NULL; int c; enum ao_scheme_builtin_id prev_func; + enum ao_scheme_builtin_id target_func; + enum ao_scheme_builtin_id func_map[_builtin_last]; in = stdin; out = stdout; - while ((c = getopt_long(argc, argv, "o:", options, NULL)) != -1) { + while ((c = getopt_long(argc, argv, "o:d:e:", options, NULL)) != -1) { switch (c) { case 'o': out_name = optarg; break; + case 'd': + ao_scheme_add_features(&disable, optarg); + break; + case 'e': + ao_scheme_add_features(&enable, optarg); + break; default: usage(argv[0]); break; @@ -298,21 +390,34 @@ main(int argc, char **argv) ao_scheme_bool_get(1); prev_func = _builtin_last; + target_func = 0; for (f = 0; f < (int) N_FUNC; f++) { - if (funcs[f].func != prev_func) - b = ao_scheme_make_builtin(funcs[f].func, funcs[f].args); - a = ao_scheme_atom_intern(funcs[f].name); - ao_scheme_atom_def(ao_scheme_atom_poly(a), - ao_scheme_builtin_poly(b)); + if (ao_scheme_has_feature(enable, funcs[f].feature) || !ao_scheme_has_feature(disable, funcs[f].feature)) { + if (funcs[f].func != prev_func) { + prev_func = funcs[f].func; + b = ao_scheme_make_builtin(prev_func, funcs[f].args); + + /* Target may have only a subset of + * the enum values; record what those + * values will be here. This obviously + * depends on the functions in the + * array being in the same order as + * the enumeration; which + * ao_scheme_make_builtin ensures. + */ + func_map[prev_func] = target_func++; + } + a = ao_scheme_atom_intern(funcs[f].name); + ao_scheme_atom_def(ao_scheme_atom_poly(a), + ao_scheme_builtin_poly(b)); + } } - /* end of file value */ - a = ao_scheme_atom_intern("eof"); - ao_scheme_atom_def(ao_scheme_atom_poly(a), - ao_scheme_atom_poly(a)); - - /* 'else' */ - a = ao_scheme_atom_intern("else"); + /* atoms */ + for (an = 0; an < (int) N_ATOM; an++) { + if (ao_scheme_has_feature(enable, atoms[an].feature) || !ao_scheme_has_feature(disable, atoms[an].feature)) + a = ao_scheme_atom_intern((char *) atoms[an].name); + } if (argv[optind]){ in = fopen(argv[optind], "r"); @@ -331,6 +436,7 @@ main(int argc, char **argv) for (f = 0; f < ao_scheme_frame_global->num; f++) { struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(ao_scheme_frame_global->vals); + val = ao_has_macro(vals->vals[f].val); if (val != AO_SCHEME_NIL) { printf("error: function %s contains unresolved macro: ", @@ -339,6 +445,13 @@ main(int argc, char **argv) printf("\n"); exit(1); } + + /* Remap builtin enum values to match target set */ + b = ao_scheme_get_builtin(vals->vals[f].val); + if (b != NULL) { + if (!ao_scheme_seen_builtin(b)) + b->func = func_map[b->func]; + } } if (out_name) { diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c index 45d4de98..292d0f9d 100644 --- a/src/scheme/ao_scheme_mem.c +++ b/src/scheme/ao_scheme_mem.c @@ -465,9 +465,15 @@ static const struct ao_scheme_type * const ao_scheme_types[AO_SCHEME_NUM_TYPE] = [AO_SCHEME_LAMBDA] = &ao_scheme_lambda_type, [AO_SCHEME_STACK] = &ao_scheme_stack_type, [AO_SCHEME_BOOL] = &ao_scheme_bool_type, +#ifdef AO_SCHEME_FEATURE_BIGINT [AO_SCHEME_BIGINT] = &ao_scheme_bigint_type, +#endif +#ifdef AO_SCHEME_FEATURE_FLOAT [AO_SCHEME_FLOAT] = &ao_scheme_float_type, +#endif +#ifdef AO_SCHEME_FEATURE_VECTOR [AO_SCHEME_VECTOR] = &ao_scheme_vector_type, +#endif }; static int diff --git a/src/scheme/ao_scheme_poly.c b/src/scheme/ao_scheme_poly.c index 553585db..0bb427b9 100644 --- a/src/scheme/ao_scheme_poly.c +++ b/src/scheme/ao_scheme_poly.c @@ -60,18 +60,33 @@ static const struct ao_scheme_funcs ao_scheme_funcs[AO_SCHEME_NUM_TYPE] = { .write = ao_scheme_bool_write, .display = ao_scheme_bool_write, }, +#ifdef AO_SCHEME_FEATURE_BIGINT [AO_SCHEME_BIGINT] = { .write = ao_scheme_bigint_write, .display = ao_scheme_bigint_write, }, +#endif +#ifdef AO_SCHEME_FEATURE_FLOAT [AO_SCHEME_FLOAT] = { .write = ao_scheme_float_write, .display = ao_scheme_float_write, }, +#endif +#ifdef AO_SCHEME_FEATURE_VECTOR [AO_SCHEME_VECTOR] = { .write = ao_scheme_vector_write, .display = ao_scheme_vector_display }, +#endif +}; + +static void ao_scheme_invalid_write(ao_poly p) { + printf("??? 0x%04x ???", p); +} + +static const struct ao_scheme_funcs ao_scheme_invalid_funcs = { + .write = ao_scheme_invalid_write, + .display = ao_scheme_invalid_write, }; static const struct ao_scheme_funcs * @@ -81,25 +96,17 @@ funcs(ao_poly p) if (type < AO_SCHEME_NUM_TYPE) return &ao_scheme_funcs[type]; - return NULL; + return &ao_scheme_invalid_funcs; } -void -ao_scheme_poly_write(ao_poly p) +void (*ao_scheme_poly_write_func(ao_poly p))(ao_poly p) { - const struct ao_scheme_funcs *f = funcs(p); - - if (f && f->write) - f->write(p); + return funcs(p)->write; } -void -ao_scheme_poly_display(ao_poly p) +void (*ao_scheme_poly_display_func(ao_poly p))(ao_poly p) { - const struct ao_scheme_funcs *f = funcs(p); - - if (f && f->display) - f->display(p); + return funcs(p)->display; } void * diff --git a/src/scheme/ao_scheme_read.c b/src/scheme/ao_scheme_read.c index 9ed54b9f..dce480ab 100644 --- a/src/scheme/ao_scheme_read.c +++ b/src/scheme/ao_scheme_read.c @@ -62,7 +62,7 @@ static const uint16_t lex_classes[128] = { PRINTABLE|SPECIAL, /* ) */ PRINTABLE, /* * */ PRINTABLE|SIGN, /* + */ - PRINTABLE|SPECIAL, /* , */ + PRINTABLE|SPECIAL_QUASI, /* , */ PRINTABLE|SIGN, /* - */ PRINTABLE|DOTC|FLOATC, /* . */ PRINTABLE, /* / */ @@ -114,7 +114,7 @@ static const uint16_t lex_classes[128] = { PRINTABLE, /* ] */ PRINTABLE, /* ^ */ PRINTABLE, /* _ */ - PRINTABLE|SPECIAL, /* ` */ + PRINTABLE|SPECIAL_QUASI, /* ` */ PRINTABLE, /* a */ PRINTABLE, /* b */ PRINTABLE, /* c */ @@ -244,12 +244,13 @@ lex_quoted(void) } } +#ifndef AO_SCHEME_TOKEN_MAX #define AO_SCHEME_TOKEN_MAX 128 +#endif static char token_string[AO_SCHEME_TOKEN_MAX]; static int32_t token_int; static int token_len; -static float token_float; static inline void add_token(int c) { if (c && token_len < AO_SCHEME_TOKEN_MAX - 1) @@ -265,6 +266,9 @@ static inline void end_token(void) { token_string[token_len] = '\0'; } +#ifdef AO_SCHEME_FEATURE_FLOAT +static float token_float; + struct namedfloat { const char *name; float value; @@ -278,6 +282,7 @@ static const struct namedfloat namedfloats[] = { }; #define NUM_NAMED_FLOATS (sizeof namedfloats / sizeof namedfloats[0]) +#endif static int _lex(void) @@ -315,6 +320,7 @@ _lex(void) return QUOTE; case '.': return DOT; +#ifdef AO_SCHEME_FEATURE_QUASI case '`': return QUASIQUOTE; case ',': @@ -327,6 +333,7 @@ _lex(void) lex_unget(c); return UNQUOTE; } +#endif } } if (lex_class & POUND) { @@ -340,8 +347,10 @@ _lex(void) add_token(c); end_token(); return BOOL; +#ifdef AO_SCHEME_FEATURE_VECTOR case '(': return OPEN_VECTOR; +#endif case '\\': for (;;) { int alphabetic; @@ -393,23 +402,23 @@ _lex(void) } } if (lex_class & PRINTABLE) { - int isfloat; - int hasdigit; - int isneg; - int isint; - int epos; - - isfloat = 1; - isint = 1; - hasdigit = 0; +#ifdef AO_SCHEME_FEATURE_FLOAT + int isfloat = 1; + int epos = 0; +#endif + int hasdigit = 0; + int isneg = 0; + int isint = 1; + token_int = 0; - isneg = 0; - epos = 0; for (;;) { if (!(lex_class & NUMBER)) { isint = 0; +#ifdef AO_SCHEME_FEATURE_FLOAT isfloat = 0; +#endif } else { +#ifdef AO_SCHEME_FEATURE_FLOAT if (!(lex_class & INTEGER)) isint = 0; if (token_len != epos && @@ -418,8 +427,10 @@ _lex(void) isint = 0; isfloat = 0; } +#endif if (c == '-') isneg = 1; +#ifdef AO_SCHEME_FEATURE_FLOAT if (c == '.' && epos != 0) isfloat = 0; if (c == 'e' || c == 'E') { @@ -428,6 +439,7 @@ _lex(void) else epos = token_len + 1; } +#endif if (lex_class & DIGIT) { hasdigit = 1; if (isint) @@ -436,8 +448,14 @@ _lex(void) } add_token (c); c = lexc (); - if ((lex_class & (NOTNAME)) && (c != '.' || !isfloat)) { + if ((lex_class & (NOTNAME)) +#ifdef AO_SCHEME_FEATURE_FLOAT + && (c != '.' || !isfloat) +#endif + ) { +#ifdef AO_SCHEME_FEATURE_FLOAT unsigned int u; +#endif // if (lex_class & ENDOFFILE) // clearerr (f); lex_unget(c); @@ -447,6 +465,7 @@ _lex(void) token_int = -token_int; return NUM; } +#ifdef AO_SCHEME_FEATURE_FLOAT if (isfloat && hasdigit) { token_float = strtof(token_string, NULL); return FLOAT; @@ -456,6 +475,7 @@ _lex(void) token_float = namedfloats[u].value; return FLOAT; } +#endif return NAME; } } @@ -525,6 +545,12 @@ pop_read_stack(void) return read_state; } +#ifdef AO_SCHEME_FEATURE_VECTOR +#define is_open(t) ((t) == OPEN || (t) == OPEN_VECTOR) +#else +#define is_open(t) ((t) == OPEN) +#endif + ao_poly ao_scheme_read(void) { @@ -538,9 +564,11 @@ ao_scheme_read(void) ao_scheme_read_cons = ao_scheme_read_cons_tail = ao_scheme_read_stack = 0; for (;;) { parse_token = lex(); - while (parse_token == OPEN || parse_token == OPEN_VECTOR) { + while (is_open(parse_token)) { +#ifdef AO_SCHEME_FEATURE_VECTOR if (parse_token == OPEN_VECTOR) read_state |= READ_SAW_VECTOR; +#endif if (!push_read_stack(read_state)) return AO_SCHEME_NIL; ao_scheme_read_list++; @@ -565,9 +593,11 @@ ao_scheme_read(void) case NUM: v = ao_scheme_integer_poly(token_int); break; +#ifdef AO_SCHEME_FEATURE_FLOAT case FLOAT: v = ao_scheme_float_get(token_float); break; +#endif case BOOL: if (token_string[0] == 't') v = _ao_scheme_bool_true; @@ -582,9 +612,11 @@ ao_scheme_read(void) v = AO_SCHEME_NIL; break; case QUOTE: +#ifdef AO_SCHEME_FEATURE_QUASI case QUASIQUOTE: case UNQUOTE: case UNQUOTE_SPLICING: +#endif if (!push_read_stack(read_state)) return AO_SCHEME_NIL; ao_scheme_read_list++; @@ -593,6 +625,7 @@ ao_scheme_read(void) case QUOTE: v = _ao_scheme_atom_quote; break; +#ifdef AO_SCHEME_FEATURE_QUASI case QUASIQUOTE: v = _ao_scheme_atom_quasiquote; break; @@ -602,6 +635,7 @@ ao_scheme_read(void) case UNQUOTE_SPLICING: v = _ao_scheme_atom_unquote2dsplicing; break; +#endif } break; case CLOSE: @@ -612,8 +646,10 @@ ao_scheme_read(void) v = ao_scheme_cons_poly(ao_scheme_read_cons); --ao_scheme_read_list; read_state = pop_read_stack(); +#ifdef AO_SCHEME_FEATURE_VECTOR if (read_state & READ_SAW_VECTOR) v = ao_scheme_vector_poly(ao_scheme_list_to_vector(ao_scheme_poly_cons(v))); +#endif break; case DOT: if (!ao_scheme_read_list) { diff --git a/src/scheme/ao_scheme_read.h b/src/scheme/ao_scheme_read.h index e10a7d05..1aa11a3a 100644 --- a/src/scheme/ao_scheme_read.h +++ b/src/scheme/ao_scheme_read.h @@ -24,15 +24,21 @@ # define OPEN 2 # define CLOSE 3 # define QUOTE 4 +#ifdef AO_SCHEME_FEATURE_QUASI # define QUASIQUOTE 5 # define UNQUOTE 6 # define UNQUOTE_SPLICING 7 +#endif # define STRING 8 # define NUM 9 +#ifdef AO_SCHEME_FEATURE_FLOAT # define FLOAT 10 +#endif # define DOT 11 # define BOOL 12 +#ifdef AO_SCHEME_FEATURE_VECTOR # define OPEN_VECTOR 13 +#endif /* * character classes @@ -40,11 +46,20 @@ # define PRINTABLE 0x0001 /* \t \n ' ' - ~ */ # define SPECIAL 0x0002 /* ( [ { ) ] } ' ` , */ +#ifdef AO_SCHEME_FEATURE_QUASI +# define SPECIAL_QUASI SPECIAL +#else +# define SPECIAL_QUASI 0 +#endif # define DOTC 0x0004 /* . */ # define WHITE 0x0008 /* ' ' \t \n */ # define DIGIT 0x0010 /* [0-9] */ # define SIGN 0x0020 /* +- */ +#ifdef AO_SCHEME_FEATURE_FLOAT # define FLOATC 0x0040 /* . e E */ +#else +# define FLOATC 0 +#endif # define ENDOFFILE 0x0080 /* end of file */ # define COMMENT 0x0100 /* ; */ # define IGNORE 0x0200 /* \0 - ' ' */ diff --git a/src/scheme/test/.gitignore b/src/scheme/test/.gitignore index 3cdae594..3622bc1d 100644 --- a/src/scheme/test/.gitignore +++ b/src/scheme/test/.gitignore @@ -1 +1 @@ -ao_scheme_test +ao-scheme diff --git a/src/scheme/test/Makefile b/src/scheme/test/Makefile index c48add1f..d1bc4239 100644 --- a/src/scheme/test/Makefile +++ b/src/scheme/test/Makefile @@ -5,18 +5,22 @@ vpath %.c .. vpath %.h .. SRCS=$(SCHEME_SRCS) ao_scheme_test.c +HDRS=$(SCHEME_HDRS) ao_scheme_const.h OBJS=$(SRCS:.c=.o) CFLAGS=-O2 -g -Wall -Wextra -I. -I.. -ao_scheme_test: $(OBJS) +ao-scheme: $(OBJS) cc $(CFLAGS) -o $@ $(OBJS) -lm -$(OBJS): $(SCHEME_HDRS) +$(OBJS): $(HDRS) + +ao_scheme_const.h: ../make-const/ao_scheme_make_const ../ao_scheme_const.scheme + ../make-const/ao_scheme_make_const -o $@ ../ao_scheme_const.scheme clean:: - rm -f $(OBJS) ao_scheme_test + rm -f $(OBJS) ao-scheme ao_scheme_const.h -install: ao_scheme_test - cp ao_scheme_test $$HOME/bin/ao-scheme +install: ao-scheme + cp $^ $$HOME/bin diff --git a/src/scheme/test/ao_scheme_os.h b/src/scheme/test/ao_scheme_os.h index ea363fb3..958f68be 100644 --- a/src/scheme/test/ao_scheme_os.h +++ b/src/scheme/test/ao_scheme_os.h @@ -24,7 +24,6 @@ #define AO_SCHEME_POOL_TOTAL 32768 #define AO_SCHEME_SAVE 1 -#define DBG_MEM_STATS 1 extern int ao_scheme_getc(void); diff --git a/src/scheme/test/ao_scheme_test.c b/src/scheme/test/ao_scheme_test.c index 0c77d8d5..45068369 100644 --- a/src/scheme/test/ao_scheme_test.c +++ b/src/scheme/test/ao_scheme_test.c @@ -107,6 +107,7 @@ main (int argc, char **argv) } ao_scheme_read_eval_print(); +#ifdef DBG_MEM_STATS printf ("collects: full: %lu incremental %lu\n", ao_scheme_collects[AO_SCHEME_COLLECT_FULL], ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]); @@ -136,4 +137,5 @@ main (int argc, char **argv) (double) ao_scheme_loops[AO_SCHEME_COLLECT_FULL], (double) ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL] / (double) ao_scheme_loops[AO_SCHEME_COLLECT_INCREMENTAL]); +#endif } diff --git a/src/scheme/tiny-test/.gitignore b/src/scheme/tiny-test/.gitignore new file mode 100644 index 00000000..7c4c3956 --- /dev/null +++ b/src/scheme/tiny-test/.gitignore @@ -0,0 +1 @@ +ao-scheme-tiny diff --git a/src/scheme/tiny-test/Makefile b/src/scheme/tiny-test/Makefile new file mode 100644 index 00000000..5082df44 --- /dev/null +++ b/src/scheme/tiny-test/Makefile @@ -0,0 +1,28 @@ +include ../Makefile-inc + +vpath %.o . +vpath %.c .. +vpath %.h .. + +DEFS= + +SRCS=$(SCHEME_SRCS) ao_scheme_test.c +HDRS=$(SCHEME_HDRS) ao_scheme_const.h + +OBJS=$(SRCS:.c=.o) + +CFLAGS=-O0 -g -Wall -Wextra -I. -I.. + +ao-scheme-tiny: $(OBJS) + cc $(CFLAGS) -o $@ $(OBJS) -lm + +$(OBJS): $(HDRS) + +ao_scheme_const.h: ../make-const/ao_scheme_make_const ao_scheme_tiny_const.scheme + ../make-const/ao_scheme_make_const -o $@ -d FLOAT,VECTOR,QUASI,BIGINT ao_scheme_tiny_const.scheme + +clean:: + rm -f $(OBJS) ao-scheme-tiny ao_scheme_const.h + +install: ao-scheme-tiny + cp $^ $$HOME/bin diff --git a/src/scheme/tiny-test/ao_scheme_os.h b/src/scheme/tiny-test/ao_scheme_os.h new file mode 100644 index 00000000..7cfe3981 --- /dev/null +++ b/src/scheme/tiny-test/ao_scheme_os.h @@ -0,0 +1,72 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#ifndef _AO_SCHEME_OS_H_ +#define _AO_SCHEME_OS_H_ + +#include +#include +#include + +#undef AO_SCHEME_FEATURE_FLOAT +#undef AO_SCHEME_FEATURE_VECTOR +#undef AO_SCHEME_FEATURE_QUASI +#undef AO_SCHEME_FEATURE_BIGINT + +#define AO_SCHEME_POOL_TOTAL 4096 +#define AO_SCHEME_SAVE 1 + +extern int ao_scheme_getc(void); + +static inline void +ao_scheme_os_flush() { + fflush(stdout); +} + +static inline void +ao_scheme_abort(void) +{ + abort(); +} + +static inline void +ao_scheme_os_led(int led) +{ + printf("leds set to 0x%x\n", led); +} + +#define AO_SCHEME_JIFFIES_PER_SECOND 100 + +static inline void +ao_scheme_os_delay(int jiffies) +{ + struct timespec ts = { + .tv_sec = jiffies / AO_SCHEME_JIFFIES_PER_SECOND, + .tv_nsec = (jiffies % AO_SCHEME_JIFFIES_PER_SECOND) * (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND) + }; + nanosleep(&ts, NULL); +} + +static inline int +ao_scheme_os_jiffy(void) +{ + struct timespec tp; + clock_gettime(CLOCK_MONOTONIC, &tp); + return tp.tv_sec * AO_SCHEME_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND)); +} + +#endif diff --git a/src/scheme/tiny-test/ao_scheme_test.c b/src/scheme/tiny-test/ao_scheme_test.c new file mode 100644 index 00000000..45068369 --- /dev/null +++ b/src/scheme/tiny-test/ao_scheme_test.c @@ -0,0 +1,141 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include + +static FILE *ao_scheme_file; +static int newline = 1; + +static char save_file[] = "scheme.image"; + +int +ao_scheme_os_save(void) +{ + FILE *save = fopen(save_file, "w"); + + if (!save) { + perror(save_file); + return 0; + } + fwrite(ao_scheme_pool, 1, AO_SCHEME_POOL_TOTAL, save); + fclose(save); + return 1; +} + +int +ao_scheme_os_restore_save(struct ao_scheme_os_save *save, int offset) +{ + FILE *restore = fopen(save_file, "r"); + size_t ret; + + if (!restore) { + perror(save_file); + return 0; + } + fseek(restore, offset, SEEK_SET); + ret = fread(save, sizeof (struct ao_scheme_os_save), 1, restore); + fclose(restore); + if (ret != 1) + return 0; + return 1; +} + +int +ao_scheme_os_restore(void) +{ + FILE *restore = fopen(save_file, "r"); + size_t ret; + + if (!restore) { + perror(save_file); + return 0; + } + ret = fread(ao_scheme_pool, 1, AO_SCHEME_POOL_TOTAL, restore); + fclose(restore); + if (ret != AO_SCHEME_POOL_TOTAL) + return 0; + return 1; +} + +int +ao_scheme_getc(void) +{ + int c; + + if (ao_scheme_file) + return getc(ao_scheme_file); + + if (newline) { + if (ao_scheme_read_list) + printf("+ "); + else + printf("> "); + newline = 0; + } + c = getchar(); + if (c == '\n') + newline = 1; + return c; +} + +int +main (int argc, char **argv) +{ + (void) argc; + + while (*++argv) { + ao_scheme_file = fopen(*argv, "r"); + if (!ao_scheme_file) { + perror(*argv); + exit(1); + } + ao_scheme_read_eval_print(); + fclose(ao_scheme_file); + ao_scheme_file = NULL; + } + ao_scheme_read_eval_print(); + +#ifdef DBG_MEM_STATS + printf ("collects: full: %lu incremental %lu\n", + ao_scheme_collects[AO_SCHEME_COLLECT_FULL], + ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]); + + printf ("freed: full %lu incremental %lu\n", + ao_scheme_freed[AO_SCHEME_COLLECT_FULL], + ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL]); + + printf("loops: full %lu incremental %lu\n", + ao_scheme_loops[AO_SCHEME_COLLECT_FULL], + ao_scheme_loops[AO_SCHEME_COLLECT_INCREMENTAL]); + + printf("loops per collect: full %f incremental %f\n", + (double) ao_scheme_loops[AO_SCHEME_COLLECT_FULL] / + (double) ao_scheme_collects[AO_SCHEME_COLLECT_FULL], + (double) ao_scheme_loops[AO_SCHEME_COLLECT_INCREMENTAL] / + (double) ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]); + + printf("freed per collect: full %f incremental %f\n", + (double) ao_scheme_freed[AO_SCHEME_COLLECT_FULL] / + (double) ao_scheme_collects[AO_SCHEME_COLLECT_FULL], + (double) ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL] / + (double) ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]); + + printf("freed per loop: full %f incremental %f\n", + (double) ao_scheme_freed[AO_SCHEME_COLLECT_FULL] / + (double) ao_scheme_loops[AO_SCHEME_COLLECT_FULL], + (double) ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL] / + (double) ao_scheme_loops[AO_SCHEME_COLLECT_INCREMENTAL]); +#endif +} diff --git a/src/scheme/tiny-test/ao_scheme_tiny_const.scheme b/src/scheme/tiny-test/ao_scheme_tiny_const.scheme new file mode 100644 index 00000000..d0c0e578 --- /dev/null +++ b/src/scheme/tiny-test/ao_scheme_tiny_const.scheme @@ -0,0 +1,389 @@ +; +; Copyright © 2016 Keith Packard +; +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation, either version 2 of the License, or +; (at your option) any later version. +; +; This program is distributed in the hope that it will be useful, but +; WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +; General Public License for more details. +; +; Lisp code placed in ROM + + ; return a list containing all of the arguments +(def (quote list) (lambda l l)) + +(def (quote def!) + (macro (a b) + (list + def + (list quote a) + b) + ) + ) + +(begin + (def! append + (lambda args + (def! a-l + (lambda (a b) + (cond ((null? a) b) + (else (cons (car a) (a-l (cdr a) b))) + ) + ) + ) + + (def! a-ls + (lambda (l) + (cond ((null? l) l) + ((null? (cdr l)) (car l)) + (else (a-l (car l) (a-ls (cdr l)))) + ) + ) + ) + (a-ls args) + ) + ) + 'append) + +(append '(a b c) '(d e f) '(g h i)) + + ; + ; Define a variable without returning the value + ; Useful when defining functions to avoid + ; having lots of output generated. + ; + ; Also accepts the alternate + ; form for defining lambdas of + ; (define (name a y z) sexprs ...) + ; + +(begin + (def (quote define) + (macro (a . b) + ; check for alternate lambda definition form + + (cond ((list? a) + (set! b + (cons lambda (cons (cdr a) b))) + (set! a (car a)) + ) + (else + (set! b (car b)) + ) + ) + (cons begin + (cons + (cons def + (cons (cons quote (cons a '())) + (cons b '()) + ) + ) + (cons + (cons quote (cons a '())) + '()) + ) + ) + ) + ) + 'define + ) + + ; basic list accessors + +(define (caar l) (car (car l))) + +(define (cadr l) (car (cdr l))) + +(define (cdar l) (cdr (car l))) + +(define (caddr l) (car (cdr (cdr l)))) + + ; (if ) + ; (if 3 2) 'yes) +(if (> 3 2) 'yes 'no) +(if (> 2 3) 'no 'yes) +(if (> 2 3) 'no) + + ; simple math operators + +(define zero? (macro (value) (list eqv? value 0))) + +(zero? 1) +(zero? 0) +(zero? "hello") + +(define positive? (macro (value) (list > value 0))) + +(positive? 12) +(positive? -12) + +(define negative? (macro (value) (list < value 0))) + +(negative? 12) +(negative? -12) + +(define (abs a) (if (>= a 0) a (- a))) + +(abs 12) +(abs -12) + +(define max (lambda (a . b) + (while (not (null? b)) + (cond ((< a (car b)) + (set! a (car b))) + ) + (set! b (cdr b)) + ) + a) + ) + +(max 1 2 3) +(max 3 2 1) + +(define min (lambda (a . b) + (while (not (null? b)) + (cond ((> a (car b)) + (set! a (car b))) + ) + (set! b (cdr b)) + ) + a) + ) + +(min 1 2 3) +(min 3 2 1) + +(define (even? a) (zero? (% a 2))) + +(even? 2) +(even? -2) +(even? 3) +(even? -1) + +(define (odd? a) (not (even? a))) + +(odd? 2) +(odd? -2) +(odd? 3) +(odd? -1) + + +(define (list-tail a b) + (if (zero? b) + a + (list-tail (cdr a (- b 1))) + ) + ) + +(define (list-ref a b) + (car (list-tail a b)) + ) + +(define (list-tail a b) + (if (zero? b) + a + (list-tail (cdr a) (- b 1)))) + +(list-tail '(1 2 3) 2) + +(define (list-ref a b) (car (list-tail a b))) + +(list-ref '(1 2 3) 2) + + + ; define a set of local + ; variables one at a time and + ; then evaluate a list of + ; sexprs + ; + ; (let* (var-defines) sexprs) + ; + ; where var-defines are either + ; + ; (name value) + ; + ; or + ; + ; (name) + ; + ; e.g. + ; + ; (let* ((x 1) (y)) (set! y (+ x 1)) y) + +(define let* + (macro (a . b) + + ; + ; make the list of names in the let + ; + + (define (_n a) + (cond ((not (null? a)) + (cons (car (car a)) + (_n (cdr a)))) + (else ()) + ) + ) + + ; the set of expressions is + ; the list of set expressions + ; pre-pended to the + ; expressions to evaluate + + (define (_v a b) + (cond ((null? a) b) (else + (cons + (list set + (list quote + (car (car a)) + ) + (cond ((null? (cdr (car a))) ()) + (else (cadr (car a)))) + ) + (_v (cdr a) b) + ) + ) + ) + ) + + ; the parameters to the lambda is a list + ; of nils of the right length + + (define (_z a) + (cond ((null? a) ()) + (else (cons () (_z (cdr a)))) + ) + ) + ; build the lambda. + + (cons (cons lambda (cons (_n a) (_v a b))) (_z a)) + ) + ) + +(let* ((a 1) (y a)) (+ a y)) + +(define let let*) + ; recursive equality + +(define (equal? a b) + (cond ((eq? a b) #t) + ((pair? a) + (cond ((pair? b) + (cond ((equal? (car a) (car b)) + (equal? (cdr a) (cdr b))) + ) + ) + ) + ) + ) + ) + +(equal? '(a b c) '(a b c)) +(equal? '(a b c) '(a b b)) + +(define member (lambda (obj a . test?) + (cond ((null? a) + #f + ) + (else + (if (null? test?) (set! test? equal?) (set! test? (car test?))) + (if (test? obj (car a)) + a + (member obj (cdr a) test?)) + ) + ) + ) + ) + +(member '(2) '((1) (2) (3))) + +(member '(4) '((1) (2) (3))) + +(define (memq obj a) (member obj a eq?)) + +(memq 2 '(1 2 3)) + +(memq 4 '(1 2 3)) + +(memq '(2) '((1) (2) (3))) + +(define (_assoc a b t?) + (if (null? b) + #f + (if (t? a (caar b)) + (car b) + (_assoc a (cdr b) t?) + ) + ) + ) + +(define (assq a b) (_assoc a b eq?)) +(define (assoc a b) (_assoc a b equal?)) + +(assq 'a '((a 1) (b 2) (c 3))) +(assoc '(c) '((a 1) (b 2) ((c) 3))) + +(define string (lambda a (list->string a))) + +(display "apply\n") +(apply cons '(a b)) + +(define map + (lambda (a . b) + (define (args b) + (cond ((null? b) ()) + (else + (cons (caar b) (args (cdr b))) + ) + ) + ) + (define (next b) + (cond ((null? b) ()) + (else + (cons (cdr (car b)) (next (cdr b))) + ) + ) + ) + (define (domap b) + (cond ((null? (car b)) ()) + (else + (cons (apply a (args b)) (domap (next b))) + ) + ) + ) + (domap b) + ) + ) + +(map cadr '((a b) (d e) (g h))) + +(define for-each (lambda (a . b) + (apply map a b) + #t)) + +(for-each display '("hello" " " "world" "\n")) + +(define (newline) (write-char #\newline)) + +(newline) -- cgit v1.2.3 From 09ea349f5b37e257e8ca23ead493ba1694395530 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 12 Dec 2017 15:27:26 -0800 Subject: altos/lambdakey-v1.0: Get this building again The lambdakey can't hold a full implementation of the scheme interpreter, so use only a subset, removing floats, bigints and vectors. Also reduce the pre-loaded lisp code as well. It's pretty spare at this point; but it does fill the ROM. Signed-off-by: Keith Packard --- src/lambdakey-v1.0/.gitignore | 1 + src/lambdakey-v1.0/Makefile | 20 +- src/lambdakey-v1.0/ao_lambdakey.c | 4 +- src/lambdakey-v1.0/ao_lambdakey_const.scheme | 389 +++++++++++++++++++++++++++ src/lambdakey-v1.0/ao_pins.h | 2 + src/lambdakey-v1.0/ao_scheme_os.h | 8 +- src/lambdakey-v1.0/lambda.ld | 13 +- 7 files changed, 414 insertions(+), 23 deletions(-) create mode 100644 src/lambdakey-v1.0/ao_lambdakey_const.scheme diff --git a/src/lambdakey-v1.0/.gitignore b/src/lambdakey-v1.0/.gitignore index 6462d930..a57994e8 100644 --- a/src/lambdakey-v1.0/.gitignore +++ b/src/lambdakey-v1.0/.gitignore @@ -1,2 +1,3 @@ lambdakey-* ao_product.h +ao_scheme_const.h diff --git a/src/lambdakey-v1.0/Makefile b/src/lambdakey-v1.0/Makefile index 4eb045b6..bffe7d4f 100644 --- a/src/lambdakey-v1.0/Makefile +++ b/src/lambdakey-v1.0/Makefile @@ -20,6 +20,7 @@ INC = \ ao_product.h \ ao_task.h \ $(SCHEME_HDRS) \ + ao_scheme_const.h \ stm32f0.h \ Makefile @@ -27,20 +28,16 @@ ALTOS_SRC = \ ao_boot_chain.c \ ao_interrupt.c \ ao_product.c \ - ao_romconfig.c \ ao_cmd.c \ - ao_config.c \ - ao_task.c \ + ao_notask.c \ ao_led.c \ - ao_dma_stm.c \ ao_stdio.c \ - ao_mutex.c \ + ao_stdio_newlib.c \ ao_panic.c \ ao_timer.c \ ao_usb_stm.c \ - ao_flash_stm.c \ - $(SCHEME_SRCS) \ - ao_scheme_os_save.c + ao_romconfig.c \ + $(SCHEME_SRCS) PRODUCT=LambdaKey-v1.0 PRODUCT_DEF=-DLAMBDAKEY @@ -65,7 +62,7 @@ OBJ=$(SRC:.c=.o) all: $(PROG) $(HEX) -$(PROG): Makefile $(OBJ) lambda.ld altos.ld +$(PROG): Makefile $(OBJ) lambda.ld $(call quiet,CC) $(LDFLAGS) $(CFLAGS) -o $(PROG) $(OBJ) $(LIBS) $(OBJ): $(INC) @@ -73,13 +70,16 @@ $(OBJ): $(INC) ao_product.h: ao-make-product.5c ../Version $(call quiet,NICKLE,$<) $< -m altusmetrum.org -i $(IDPRODUCT) -p $(PRODUCT) -v $(VERSION) > $@ +ao_scheme_const.h: ../scheme/make-const/ao_scheme_make_const ao_lambdakey_const.scheme + ../scheme/make-const/ao_scheme_make_const -d FLOAT,VECTOR,QUASI,BIGINT -o $@ ao_lambdakey_const.scheme + load: $(PROG) stm-load $(PROG) distclean: clean clean: - rm -f *.o $(PROGNAME)-*.elf $(PROGNAME)-*.ihx + rm -f *.o $(PROGNAME)-*.elf $(PROGNAME)-*.ihx ao_scheme_const.h rm -f ao_product.h install: diff --git a/src/lambdakey-v1.0/ao_lambdakey.c b/src/lambdakey-v1.0/ao_lambdakey.c index d0996eb4..73962e29 100644 --- a/src/lambdakey-v1.0/ao_lambdakey.c +++ b/src/lambdakey-v1.0/ao_lambdakey.c @@ -29,13 +29,11 @@ void main(void) { ao_led_init(LEDS_AVAILABLE); ao_clock_init(); - ao_task_init(); ao_timer_init(); - ao_dma_init(); ao_usb_init(); ao_cmd_init(); ao_cmd_register(blink_cmds); - ao_start_scheduler(); + ao_cmd(); } diff --git a/src/lambdakey-v1.0/ao_lambdakey_const.scheme b/src/lambdakey-v1.0/ao_lambdakey_const.scheme new file mode 100644 index 00000000..d0c0e578 --- /dev/null +++ b/src/lambdakey-v1.0/ao_lambdakey_const.scheme @@ -0,0 +1,389 @@ +; +; Copyright © 2016 Keith Packard +; +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation, either version 2 of the License, or +; (at your option) any later version. +; +; This program is distributed in the hope that it will be useful, but +; WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +; General Public License for more details. +; +; Lisp code placed in ROM + + ; return a list containing all of the arguments +(def (quote list) (lambda l l)) + +(def (quote def!) + (macro (a b) + (list + def + (list quote a) + b) + ) + ) + +(begin + (def! append + (lambda args + (def! a-l + (lambda (a b) + (cond ((null? a) b) + (else (cons (car a) (a-l (cdr a) b))) + ) + ) + ) + + (def! a-ls + (lambda (l) + (cond ((null? l) l) + ((null? (cdr l)) (car l)) + (else (a-l (car l) (a-ls (cdr l)))) + ) + ) + ) + (a-ls args) + ) + ) + 'append) + +(append '(a b c) '(d e f) '(g h i)) + + ; + ; Define a variable without returning the value + ; Useful when defining functions to avoid + ; having lots of output generated. + ; + ; Also accepts the alternate + ; form for defining lambdas of + ; (define (name a y z) sexprs ...) + ; + +(begin + (def (quote define) + (macro (a . b) + ; check for alternate lambda definition form + + (cond ((list? a) + (set! b + (cons lambda (cons (cdr a) b))) + (set! a (car a)) + ) + (else + (set! b (car b)) + ) + ) + (cons begin + (cons + (cons def + (cons (cons quote (cons a '())) + (cons b '()) + ) + ) + (cons + (cons quote (cons a '())) + '()) + ) + ) + ) + ) + 'define + ) + + ; basic list accessors + +(define (caar l) (car (car l))) + +(define (cadr l) (car (cdr l))) + +(define (cdar l) (cdr (car l))) + +(define (caddr l) (car (cdr (cdr l)))) + + ; (if ) + ; (if 3 2) 'yes) +(if (> 3 2) 'yes 'no) +(if (> 2 3) 'no 'yes) +(if (> 2 3) 'no) + + ; simple math operators + +(define zero? (macro (value) (list eqv? value 0))) + +(zero? 1) +(zero? 0) +(zero? "hello") + +(define positive? (macro (value) (list > value 0))) + +(positive? 12) +(positive? -12) + +(define negative? (macro (value) (list < value 0))) + +(negative? 12) +(negative? -12) + +(define (abs a) (if (>= a 0) a (- a))) + +(abs 12) +(abs -12) + +(define max (lambda (a . b) + (while (not (null? b)) + (cond ((< a (car b)) + (set! a (car b))) + ) + (set! b (cdr b)) + ) + a) + ) + +(max 1 2 3) +(max 3 2 1) + +(define min (lambda (a . b) + (while (not (null? b)) + (cond ((> a (car b)) + (set! a (car b))) + ) + (set! b (cdr b)) + ) + a) + ) + +(min 1 2 3) +(min 3 2 1) + +(define (even? a) (zero? (% a 2))) + +(even? 2) +(even? -2) +(even? 3) +(even? -1) + +(define (odd? a) (not (even? a))) + +(odd? 2) +(odd? -2) +(odd? 3) +(odd? -1) + + +(define (list-tail a b) + (if (zero? b) + a + (list-tail (cdr a (- b 1))) + ) + ) + +(define (list-ref a b) + (car (list-tail a b)) + ) + +(define (list-tail a b) + (if (zero? b) + a + (list-tail (cdr a) (- b 1)))) + +(list-tail '(1 2 3) 2) + +(define (list-ref a b) (car (list-tail a b))) + +(list-ref '(1 2 3) 2) + + + ; define a set of local + ; variables one at a time and + ; then evaluate a list of + ; sexprs + ; + ; (let* (var-defines) sexprs) + ; + ; where var-defines are either + ; + ; (name value) + ; + ; or + ; + ; (name) + ; + ; e.g. + ; + ; (let* ((x 1) (y)) (set! y (+ x 1)) y) + +(define let* + (macro (a . b) + + ; + ; make the list of names in the let + ; + + (define (_n a) + (cond ((not (null? a)) + (cons (car (car a)) + (_n (cdr a)))) + (else ()) + ) + ) + + ; the set of expressions is + ; the list of set expressions + ; pre-pended to the + ; expressions to evaluate + + (define (_v a b) + (cond ((null? a) b) (else + (cons + (list set + (list quote + (car (car a)) + ) + (cond ((null? (cdr (car a))) ()) + (else (cadr (car a)))) + ) + (_v (cdr a) b) + ) + ) + ) + ) + + ; the parameters to the lambda is a list + ; of nils of the right length + + (define (_z a) + (cond ((null? a) ()) + (else (cons () (_z (cdr a)))) + ) + ) + ; build the lambda. + + (cons (cons lambda (cons (_n a) (_v a b))) (_z a)) + ) + ) + +(let* ((a 1) (y a)) (+ a y)) + +(define let let*) + ; recursive equality + +(define (equal? a b) + (cond ((eq? a b) #t) + ((pair? a) + (cond ((pair? b) + (cond ((equal? (car a) (car b)) + (equal? (cdr a) (cdr b))) + ) + ) + ) + ) + ) + ) + +(equal? '(a b c) '(a b c)) +(equal? '(a b c) '(a b b)) + +(define member (lambda (obj a . test?) + (cond ((null? a) + #f + ) + (else + (if (null? test?) (set! test? equal?) (set! test? (car test?))) + (if (test? obj (car a)) + a + (member obj (cdr a) test?)) + ) + ) + ) + ) + +(member '(2) '((1) (2) (3))) + +(member '(4) '((1) (2) (3))) + +(define (memq obj a) (member obj a eq?)) + +(memq 2 '(1 2 3)) + +(memq 4 '(1 2 3)) + +(memq '(2) '((1) (2) (3))) + +(define (_assoc a b t?) + (if (null? b) + #f + (if (t? a (caar b)) + (car b) + (_assoc a (cdr b) t?) + ) + ) + ) + +(define (assq a b) (_assoc a b eq?)) +(define (assoc a b) (_assoc a b equal?)) + +(assq 'a '((a 1) (b 2) (c 3))) +(assoc '(c) '((a 1) (b 2) ((c) 3))) + +(define string (lambda a (list->string a))) + +(display "apply\n") +(apply cons '(a b)) + +(define map + (lambda (a . b) + (define (args b) + (cond ((null? b) ()) + (else + (cons (caar b) (args (cdr b))) + ) + ) + ) + (define (next b) + (cond ((null? b) ()) + (else + (cons (cdr (car b)) (next (cdr b))) + ) + ) + ) + (define (domap b) + (cond ((null? (car b)) ()) + (else + (cons (apply a (args b)) (domap (next b))) + ) + ) + ) + (domap b) + ) + ) + +(map cadr '((a b) (d e) (g h))) + +(define for-each (lambda (a . b) + (apply map a b) + #t)) + +(for-each display '("hello" " " "world" "\n")) + +(define (newline) (write-char #\newline)) + +(newline) diff --git a/src/lambdakey-v1.0/ao_pins.h b/src/lambdakey-v1.0/ao_pins.h index 2ba79c01..cb1c4aa7 100644 --- a/src/lambdakey-v1.0/ao_pins.h +++ b/src/lambdakey-v1.0/ao_pins.h @@ -19,6 +19,8 @@ #ifndef _AO_PINS_H_ #define _AO_PINS_H_ +#define HAS_TASK 0 + #define LED_PORT_ENABLE STM_RCC_AHBENR_IOPBEN #define LED_PORT (&stm_gpiob) #define LED_PIN_RED 4 diff --git a/src/lambdakey-v1.0/ao_scheme_os.h b/src/lambdakey-v1.0/ao_scheme_os.h index a620684f..0d48af3b 100644 --- a/src/lambdakey-v1.0/ao_scheme_os.h +++ b/src/lambdakey-v1.0/ao_scheme_os.h @@ -20,9 +20,13 @@ #include "ao.h" -#define AO_SCHEME_SAVE 1 +#undef AO_SCHEME_FEATURE_FLOAT +#undef AO_SCHEME_FEATURE_VECTOR +#undef AO_SCHEME_FEATURE_QUASI +#undef AO_SCHEME_FEATURE_BIGINT -#define AO_SCHEME_POOL_TOTAL 2048 +#define AO_SCHEME_POOL 4096 +#define AO_SCHEME_TOKEN_MAX 64 #ifndef __BYTE_ORDER #define __LITTLE_ENDIAN 1234 diff --git a/src/lambdakey-v1.0/lambda.ld b/src/lambdakey-v1.0/lambda.ld index 5de65eb5..15b2d971 100644 --- a/src/lambdakey-v1.0/lambda.ld +++ b/src/lambdakey-v1.0/lambda.ld @@ -17,10 +17,9 @@ */ MEMORY { - rom (rx) : ORIGIN = 0x08001000, LENGTH = 25K - flash (r): ORIGIN = 0x08007400, LENGTH = 3k - ram (!w) : ORIGIN = 0x20000000, LENGTH = 6k - 128 - stack (!w) : ORIGIN = 0x20000000 + 6k - 128, LENGTH = 128 + rom (rx) : ORIGIN = 0x08001000, LENGTH = 28K + ram (!w) : ORIGIN = 0x20000000, LENGTH = 6k - 480 + stack (!w) : ORIGIN = 0x20000000 + 6k - 480, LENGTH = 480 } INCLUDE registers.ld @@ -93,9 +92,9 @@ SECTIONS { /* Data -- relocated to RAM, but written to ROM */ - .data : { + .data BLOCK(8): { *(.data) /* initialized data */ - . = ALIGN(4); + . = ALIGN(8); __data_end__ = .; } >ram AT>rom @@ -110,8 +109,6 @@ SECTIONS { PROVIDE(end = .); PROVIDE(__stack__ = ORIGIN(stack) + LENGTH(stack)); - - __flash__ = ORIGIN(flash); } ENTRY(start); -- cgit v1.2.3 From db352bd0723e8d640bb034bc14e5ad193f0afe1d Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 12 Dec 2017 15:30:45 -0800 Subject: altos/kernel: Allow ao_cmd to be built without tasking Useful for single-threaded applications, like lambdakey Signed-off-by: Keith Packard --- src/kernel/ao.h | 3 +++ src/kernel/ao_cmd.c | 6 +++++- src/kernel/ao_notask.c | 15 +++++++++++++++ src/lambdakey-v1.0/ao_pins.h | 1 + 4 files changed, 24 insertions(+), 1 deletion(-) diff --git a/src/kernel/ao.h b/src/kernel/ao.h index 139050cf..2bd0e367 100644 --- a/src/kernel/ao.h +++ b/src/kernel/ao.h @@ -218,6 +218,9 @@ ao_cmd_register(const __code struct ao_cmds *cmds); void ao_cmd_init(void); +void +ao_cmd(void); + #if HAS_CMD_FILTER /* * Provided by an external module to filter raw command lines diff --git a/src/kernel/ao_cmd.c b/src/kernel/ao_cmd.c index c1e9cef2..405fd126 100644 --- a/src/kernel/ao_cmd.c +++ b/src/kernel/ao_cmd.c @@ -423,11 +423,13 @@ ao_loader(void) } #endif +#if HAS_TASK __xdata struct ao_task ao_cmd_task; +#endif __code struct ao_cmds ao_base_cmds[] = { { help, "?\0Help" }, -#if HAS_TASK_INFO +#if HAS_TASK_INFO && HAS_TASK { ao_task_info, "T\0Tasks" }, #endif { echo, "E <0 off, 1 on>\0Echo" }, @@ -445,5 +447,7 @@ void ao_cmd_init(void) { ao_cmd_register(&ao_base_cmds[0]); +#if HAS_TASK ao_add_task(&ao_cmd_task, ao_cmd, "cmd"); +#endif } diff --git a/src/kernel/ao_notask.c b/src/kernel/ao_notask.c index 00fe1ed6..7207353a 100644 --- a/src/kernel/ao_notask.c +++ b/src/kernel/ao_notask.c @@ -39,6 +39,21 @@ ao_sleep(__xdata void *wchan) return 0; } +#if HAS_AO_DELAY +void +ao_delay(uint16_t ticks) +{ + AO_TICK_TYPE target; + + if (!ticks) + ticks = 1; + target = ao_tick_count + ticks; + do { + ao_sleep(&ao_time); + } while ((int16_t) (target - ao_tick_count) > 0); +} +#endif + void ao_wakeup(__xdata void *wchan) { diff --git a/src/lambdakey-v1.0/ao_pins.h b/src/lambdakey-v1.0/ao_pins.h index cb1c4aa7..48b9db16 100644 --- a/src/lambdakey-v1.0/ao_pins.h +++ b/src/lambdakey-v1.0/ao_pins.h @@ -20,6 +20,7 @@ #define _AO_PINS_H_ #define HAS_TASK 0 +#define HAS_AO_DELAY 1 #define LED_PORT_ENABLE STM_RCC_AHBENR_IOPBEN #define LED_PORT (&stm_gpiob) -- cgit v1.2.3 From 28dbe9a04b16f79db255baecbf0cd486c510ef58 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 12 Dec 2017 15:31:27 -0800 Subject: altos/stm: Align 'data' to 8 bytes, just like textram The textram section must be aligned to 8 bytes to keep the linker happy. However, if that section contains no data, the declaration will set the __data_start__ value to that alignment, but the data section itself would start on a 4-byte alignment, potentially 4 bytes lower than the value indicated by __data_start__. This completely scrambles initialized memory as the startup code will copy the data segment to __data_start__, 4 bytes off of the actual data segment start. Fix this by forcing the data segment to also be aligned to 8 bytes. Signed-off-by: Keith Packard --- src/micropeak-v2.0/micropeak.ld | 10 +++++----- src/stm/altos-loader.ld | 3 ++- src/stmf0/altos-loader.ld | 5 +++-- 3 files changed, 10 insertions(+), 8 deletions(-) diff --git a/src/micropeak-v2.0/micropeak.ld b/src/micropeak-v2.0/micropeak.ld index 77717e16..baeae5b8 100644 --- a/src/micropeak-v2.0/micropeak.ld +++ b/src/micropeak-v2.0/micropeak.ld @@ -19,8 +19,8 @@ MEMORY { rom (rx) : ORIGIN = 0x08001000, LENGTH = 20K flash(rx) : ORIGIN = 0x08006000, LENGTH = 8K - ram (!w) : ORIGIN = 0x20000000, LENGTH = 6k - 128 - stack (!w) : ORIGIN = 0x20000000 + 6k - 128, LENGTH = 128 + ram (!w) : ORIGIN = 0x20000000, LENGTH = 6k - 512 + stack (!w) : ORIGIN = 0x20000000 + 6k - 512, LENGTH = 512 } INCLUDE registers.ld @@ -94,11 +94,11 @@ SECTIONS { *(.ramtext) } >ram AT>rom - /* Data -- relocated to RAM, but written to ROM + /* Data -- relocated to RAM, but written to ROM, + * also aligned to 8 bytes to agree with textram */ - .data : { + .data BLOCK(8): { *(.data) /* initialized data */ - . = ALIGN(4); __data_end__ = .; } >ram AT>rom diff --git a/src/stm/altos-loader.ld b/src/stm/altos-loader.ld index a4a7dc43..806b4842 100644 --- a/src/stm/altos-loader.ld +++ b/src/stm/altos-loader.ld @@ -72,8 +72,9 @@ SECTIONS { } >ram AT>rom /* Data -- relocated to RAM, but written to ROM + * Also aligned to 8 bytes to agree with textram */ - .data : { + .data BLOCK(8): { *(.data) /* initialized data */ __data_end__ = .; } >ram AT>rom diff --git a/src/stmf0/altos-loader.ld b/src/stmf0/altos-loader.ld index c458116b..05887d0e 100644 --- a/src/stmf0/altos-loader.ld +++ b/src/stmf0/altos-loader.ld @@ -72,9 +72,10 @@ SECTIONS { __text_ram_end = .; } >ram AT>rom - /* Data -- relocated to RAM, but written to ROM + /* Data -- relocated to RAM, but written to ROM. + * also aligned to 8 bytes in case textram is empty */ - .data : { + .data BLOCK(8): { *(.data) /* initialized data */ __data_end__ = .; } >ram AT>rom -- cgit v1.2.3 From 4bfce37e7567d9c2a09ea4da8113e7639516ed6e Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 12 Dec 2017 17:54:03 -0800 Subject: altos/scheme: apply const to places taking const strings. Mostly printf and friends. Signed-off-by: Keith Packard --- src/scheme/ao_scheme.h | 12 +++++----- src/scheme/ao_scheme_builtin.c | 6 ++--- src/scheme/ao_scheme_error.c | 10 ++++----- src/scheme/ao_scheme_make_builtin | 2 +- src/scheme/ao_scheme_make_const.c | 46 +++++++++++++++++++++------------------ 5 files changed, 40 insertions(+), 36 deletions(-) diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index db4417e5..7e4b3697 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -63,7 +63,7 @@ extern uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4))) #define ao_scheme_pool ao_scheme_const #define AO_SCHEME_POOL AO_SCHEME_POOL_CONST -#define _atom(n) ao_scheme_atom_poly(ao_scheme_atom_intern(n)) +#define _atom(n) ao_scheme_atom_poly(ao_scheme_atom_intern((char *) n)) #define _bool(v) ao_scheme_bool_poly(ao_scheme_bool_get(v)) #define _ao_scheme_bool_true _bool(1) @@ -940,19 +940,19 @@ ao_scheme_stack_eval(void); /* error */ void -ao_scheme_vprintf(char *format, va_list args); +ao_scheme_vprintf(const char *format, va_list args); void -ao_scheme_printf(char *format, ...); +ao_scheme_printf(const char *format, ...); void -ao_scheme_error_poly(char *name, ao_poly poly, ao_poly last); +ao_scheme_error_poly(const char *name, ao_poly poly, ao_poly last); void -ao_scheme_error_frame(int indent, char *name, struct ao_scheme_frame *frame); +ao_scheme_error_frame(int indent, const char *name, struct ao_scheme_frame *frame); ao_poly -ao_scheme_error(int error, char *format, ...); +ao_scheme_error(int error, const char *format, ...); /* builtins */ diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index c0f636fa..4def5704 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -52,7 +52,7 @@ char *ao_scheme_args_name(uint8_t args) { case AO_SCHEME_FUNC_LAMBDA: return ao_scheme_poly_atom(_ao_scheme_atom_lambda)->name; case AO_SCHEME_FUNC_NLAMBDA: return ao_scheme_poly_atom(_ao_scheme_atom_nlambda)->name; case AO_SCHEME_FUNC_MACRO: return ao_scheme_poly_atom(_ao_scheme_atom_macro)->name; - default: return "???"; + default: return (char *) "???"; } } #else @@ -64,7 +64,7 @@ static char * ao_scheme_builtin_name(enum ao_scheme_builtin_id b) { if (b < _builtin_last) return ao_scheme_poly_atom(builtin_names[b])->name; - return "???"; + return (char *) "???"; } static const ao_poly ao_scheme_args_atoms[] = { @@ -79,7 +79,7 @@ ao_scheme_args_name(uint8_t args) args &= AO_SCHEME_FUNC_MASK; if (args < sizeof ao_scheme_args_atoms / sizeof ao_scheme_args_atoms[0]) return ao_scheme_poly_atom(ao_scheme_args_atoms[args])->name; - return "(unknown)"; + return (char *) "(unknown)"; } #endif diff --git a/src/scheme/ao_scheme_error.c b/src/scheme/ao_scheme_error.c index d580a2c0..c015c76a 100644 --- a/src/scheme/ao_scheme_error.c +++ b/src/scheme/ao_scheme_error.c @@ -16,7 +16,7 @@ #include void -ao_scheme_error_poly(char *name, ao_poly poly, ao_poly last) +ao_scheme_error_poly(const char *name, ao_poly poly, ao_poly last) { int first = 1; printf("\t\t%s(", name); @@ -50,7 +50,7 @@ static void tabs(int indent) } void -ao_scheme_error_frame(int indent, char *name, struct ao_scheme_frame *frame) +ao_scheme_error_frame(int indent, const char *name, struct ao_scheme_frame *frame) { int f; @@ -83,7 +83,7 @@ ao_scheme_error_frame(int indent, char *name, struct ao_scheme_frame *frame) } void -ao_scheme_vprintf(char *format, va_list args) +ao_scheme_vprintf(const char *format, va_list args) { char c; @@ -112,7 +112,7 @@ ao_scheme_vprintf(char *format, va_list args) } void -ao_scheme_printf(char *format, ...) +ao_scheme_printf(const char *format, ...) { va_list args; va_start(args, format); @@ -121,7 +121,7 @@ ao_scheme_printf(char *format, ...) } ao_poly -ao_scheme_error(int error, char *format, ...) +ao_scheme_error(int error, const char *format, ...) { va_list args; diff --git a/src/scheme/ao_scheme_make_builtin b/src/scheme/ao_scheme_make_builtin index 78f97789..a4d8326f 100644 --- a/src/scheme/ao_scheme_make_builtin +++ b/src/scheme/ao_scheme_make_builtin @@ -101,7 +101,7 @@ dump_casename(builtin_t[*] builtins) { builtins[i].c_name, builtins[i].lisp_names[0]); dump_endif(builtins[i]); } - printf("\tdefault: return \"???\";\n"); + printf("\tdefault: return (char *) \"???\";\n"); printf("\t}\n"); printf("}\n"); printf("#endif /* AO_SCHEME_BUILTIN_CASENAME */\n"); diff --git a/src/scheme/ao_scheme_make_const.c b/src/scheme/ao_scheme_make_const.c index 6bd552f5..d0a51ec8 100644 --- a/src/scheme/ao_scheme_make_const.c +++ b/src/scheme/ao_scheme_make_const.c @@ -30,15 +30,15 @@ ao_scheme_make_builtin(enum ao_scheme_builtin_id func, int args) { } struct builtin_func { - char *feature; - char *name; - int args; + const char *feature; + const char *name; + int args; enum ao_scheme_builtin_id func; }; struct builtin_atom { - char *feature; - char *name; + const char *feature; + const char *name; }; #define AO_SCHEME_BUILTIN_CONSTS @@ -306,8 +306,8 @@ ao_scheme_add_feature(struct feature **list, char *name) *list = feature; } -bool -ao_scheme_has_feature(struct feature *list, char *name) +static bool +ao_scheme_has_feature(struct feature *list, const char *name) { while (list) { if (!strcmp(list->name, name)) @@ -317,17 +317,20 @@ ao_scheme_has_feature(struct feature *list, char *name) return false; } -void -ao_scheme_add_features(struct feature **list, char *names) +static void +ao_scheme_add_features(struct feature **list, const char *names) { char *saveptr = NULL; char *name; + char *copy = strdup(names); + char *save = copy; - while ((name = strtok_r(names, ",", &saveptr)) != NULL) { - names = NULL; + while ((name = strtok_r(copy, ",", &saveptr)) != NULL) { + copy = NULL; if (!ao_scheme_has_feature(*list, name)) ao_scheme_add_feature(list, name); } + free(save); } int @@ -407,7 +410,7 @@ main(int argc, char **argv) */ func_map[prev_func] = target_func++; } - a = ao_scheme_atom_intern(funcs[f].name); + a = ao_scheme_atom_intern((char *) funcs[f].name); ao_scheme_atom_def(ao_scheme_atom_poly(a), ao_scheme_builtin_poly(b)); } @@ -474,32 +477,33 @@ main(int argc, char **argv) fprintf(out, "#define _ao_scheme_bool_true 0x%04x\n", ao_scheme_bool_poly(ao_scheme_true)); for (a = ao_scheme_atoms; a; a = ao_scheme_poly_atom(a->next)) { - char *n = a->name, c; + const char *n = a->name; + char ch; fprintf(out, "#define _ao_scheme_atom_"); - while ((c = *n++)) { - if (isalnum(c)) - fprintf(out, "%c", c); + while ((ch = *n++)) { + if (isalnum(ch)) + fprintf(out, "%c", ch); else - fprintf(out, "%02x", c); + fprintf(out, "%02x", ch); } fprintf(out, " 0x%04x\n", ao_scheme_atom_poly(a)); } fprintf(out, "#ifdef AO_SCHEME_CONST_BITS\n"); fprintf(out, "const uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute((aligned(4))) = {"); for (o = 0; o < ao_scheme_top; o++) { - uint8_t c; + uint8_t ch; if ((o & 0xf) == 0) fprintf(out, "\n\t"); else fprintf(out, " "); - c = ao_scheme_const[o]; + ch = ao_scheme_const[o]; if (!in_atom) in_atom = is_atom(o); if (in_atom) { - fprintf(out, " '%c',", c); + fprintf(out, " '%c',", ch); in_atom--; } else { - fprintf(out, "0x%02x,", c); + fprintf(out, "0x%02x,", ch); } } fprintf(out, "\n};\n"); -- cgit v1.2.3 From ca27d467198c556be483961a6ca3b8f97bbe96a6 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 12 Dec 2017 17:59:26 -0800 Subject: altos/scheme: More compiler warning cleanups Make local funcs static. Don't mix decls and code.x Signed-off-by: Keith Packard --- src/scheme/ao_scheme.h | 23 ++++++----------------- src/scheme/ao_scheme_builtin.c | 10 ++++++---- src/scheme/ao_scheme_lambda.c | 8 ++++---- src/scheme/ao_scheme_make_const.c | 19 ++++++++++++------- src/scheme/ao_scheme_save.c | 13 ++++++++++--- src/scheme/ao_scheme_stack.c | 3 ++- src/scheme/ao_scheme_string.c | 19 +++++++++++++------ src/scheme/make-const/Makefile | 2 +- src/scheme/test/Makefile | 2 +- src/scheme/test/ao_scheme_os.h | 2 +- src/scheme/tiny-test/Makefile | 2 +- src/scheme/tiny-test/ao_scheme_os.h | 7 +------ 12 files changed, 58 insertions(+), 52 deletions(-) diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index 7e4b3697..ad80db2f 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -43,6 +43,10 @@ struct ao_scheme_os_save { uint16_t const_checksum_inv; }; +#ifndef AO_SCHEME_POOL_TOTAL +#error Must define AO_SCHEME_POOL_TOTAL for AO_SCHEME_SAVE +#endif + #define AO_SCHEME_POOL_EXTRA (sizeof(struct ao_scheme_os_save)) #define AO_SCHEME_POOL ((int) (AO_SCHEME_POOL_TOTAL - AO_SCHEME_POOL_EXTRA)) @@ -78,7 +82,7 @@ extern uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4))) #else #include "ao_scheme_const.h" #ifndef AO_SCHEME_POOL -#define AO_SCHEME_POOL 3072 +#error Must define AO_SCHEME_POOL #endif #ifndef AO_SCHEME_POOL_EXTRA #define AO_SCHEME_POOL_EXTRA 0 @@ -560,21 +564,10 @@ extern uint64_t ao_scheme_collects[2]; extern uint64_t ao_scheme_freed[2]; extern uint64_t ao_scheme_loops[2]; -/* returns 1 if the object was already marked */ -int -ao_scheme_mark(const struct ao_scheme_type *type, void *addr); - /* returns 1 if the object was already marked */ int ao_scheme_mark_memory(const struct ao_scheme_type *type, void *addr); -void * -ao_scheme_move_map(void *addr); - -/* returns 1 if the object was already moved */ -int -ao_scheme_move(const struct ao_scheme_type *type, void **ref); - /* returns 1 if the object was already moved */ int ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref); @@ -635,7 +628,7 @@ void ao_scheme_bool_write(ao_poly v); #ifdef AO_SCHEME_MAKE_CONST -struct ao_scheme_bool *ao_scheme_true, *ao_scheme_false; +extern struct ao_scheme_bool *ao_scheme_true, *ao_scheme_false; struct ao_scheme_bool * ao_scheme_bool_get(uint8_t value); @@ -825,12 +818,8 @@ ao_scheme_number_typep(uint8_t t) { return ao_scheme_integer_typep(t) || (t == AO_SCHEME_FLOAT); } - -float -ao_scheme_poly_number(ao_poly p); #else #define ao_scheme_number_typep ao_scheme_integer_typep -#define ao_scheme_poly_number ao_scheme_poly_integer #endif /* builtin */ diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index 4def5704..b6788993 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -127,7 +127,7 @@ ao_scheme_check_argt(ao_poly name, struct ao_scheme_cons *cons, int argc, int ty return _ao_scheme_bool_true; } -int32_t +static int32_t ao_scheme_arg_int(ao_poly name, struct ao_scheme_cons *cons, int argc) { ao_poly p = ao_scheme_arg(cons, argc); @@ -306,10 +306,10 @@ ao_scheme_do_display(struct ao_scheme_cons *cons) return _ao_scheme_bool_true; } -ao_poly +static ao_poly ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) { - struct ao_scheme_cons *cons = cons; + struct ao_scheme_cons *cons; ao_poly ret = AO_SCHEME_NIL; for (cons = orig_cons; cons; cons = ao_scheme_cons_cdr(cons)) { @@ -501,7 +501,7 @@ ao_scheme_do_remainder(struct ao_scheme_cons *cons) return ao_scheme_math(cons, builtin_remainder); } -ao_poly +static ao_poly ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op) { ao_poly left; @@ -545,6 +545,7 @@ ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op) default: break; } +#ifdef AO_SCHEME_FEATURE_FLOAT } else if (ao_scheme_number_typep(lt) && ao_scheme_number_typep(rt)) { float l, r; @@ -574,6 +575,7 @@ ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op) default: break; } +#endif /* AO_SCHEME_FEATURE_FLOAT */ } else if (lt == AO_SCHEME_STRING && rt == AO_SCHEME_STRING) { int c = strcmp(ao_scheme_poly_string(left), ao_scheme_poly_string(right)); diff --git a/src/scheme/ao_scheme_lambda.c b/src/scheme/ao_scheme_lambda.c index ec6f858c..be87f4d1 100644 --- a/src/scheme/ao_scheme_lambda.c +++ b/src/scheme/ao_scheme_lambda.c @@ -17,14 +17,14 @@ #include "ao_scheme.h" -int +static int lambda_size(void *addr) { (void) addr; return sizeof (struct ao_scheme_lambda); } -void +static void lambda_mark(void *addr) { struct ao_scheme_lambda *lambda = addr; @@ -33,7 +33,7 @@ lambda_mark(void *addr) ao_scheme_poly_mark(lambda->frame, 0); } -void +static void lambda_move(void *addr) { struct ao_scheme_lambda *lambda = addr; @@ -65,7 +65,7 @@ ao_scheme_lambda_write(ao_poly poly) printf(")"); } -ao_poly +static ao_poly ao_scheme_lambda_alloc(struct ao_scheme_cons *code, int args) { struct ao_scheme_lambda *lambda; diff --git a/src/scheme/ao_scheme_make_const.c b/src/scheme/ao_scheme_make_const.c index d0a51ec8..51bb1269 100644 --- a/src/scheme/ao_scheme_make_const.c +++ b/src/scheme/ao_scheme_make_const.c @@ -80,7 +80,7 @@ ao_fec_crc_byte(uint8_t byte, uint16_t crc) return crc; } -uint16_t +static uint16_t ao_fec_crc(const uint8_t *bytes, uint8_t len) { uint16_t crc = AO_FEC_CRC_INIT; @@ -97,7 +97,7 @@ struct ao_scheme_macro_stack { struct ao_scheme_macro_stack *macro_stack; -int +static int ao_scheme_macro_push(ao_poly p) { struct ao_scheme_macro_stack *m = macro_stack; @@ -114,7 +114,7 @@ ao_scheme_macro_push(ao_poly p) return 0; } -void +static void ao_scheme_macro_pop(void) { struct ao_scheme_macro_stack *m = macro_stack; @@ -141,7 +141,7 @@ void indent(void) ao_poly ao_has_macro(ao_poly p); -ao_poly +static ao_poly ao_macro_test_get(ao_poly atom) { ao_poly *ref = ao_scheme_atom_ref(atom, NULL); @@ -150,7 +150,7 @@ ao_macro_test_get(ao_poly atom) return AO_SCHEME_NIL; } -ao_poly +static ao_poly ao_is_macro(ao_poly p) { struct ao_scheme_builtin *builtin; @@ -269,7 +269,7 @@ ao_scheme_seen_builtin(struct ao_scheme_builtin *b) return 0; } -int +static int ao_scheme_read_eval_abort(void) { ao_poly in, out = AO_SCHEME_NIL; @@ -297,7 +297,7 @@ struct feature { static struct feature *enable; static struct feature *disable; -void +static void ao_scheme_add_feature(struct feature **list, char *name) { struct feature *feature = malloc (sizeof (struct feature) + strlen(name) + 1); @@ -359,6 +359,7 @@ main(int argc, char **argv) ao_poly val; struct ao_scheme_atom *a; struct ao_scheme_builtin *b; + struct feature *d; int in_atom = 0; char *out_name = NULL; int c; @@ -394,6 +395,7 @@ main(int argc, char **argv) prev_func = _builtin_last; target_func = 0; + b = NULL; for (f = 0; f < (int) N_FUNC; f++) { if (ao_scheme_has_feature(enable, funcs[f].feature) || !ao_scheme_has_feature(disable, funcs[f].feature)) { if (funcs[f].func != prev_func) { @@ -467,6 +469,9 @@ main(int argc, char **argv) fprintf(out, "/* Generated file, do not edit */\n\n"); + for (d = disable; d; d = d->next) + fprintf(out, "#undef AO_SCHEME_FEATURE_%s\n", d->name); + fprintf(out, "#define AO_SCHEME_POOL_CONST %d\n", ao_scheme_top); fprintf(out, "extern const uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4)));\n"); fprintf(out, "#define ao_builtin_atoms 0x%04x\n", ao_scheme_atom_poly(ao_scheme_atoms)); diff --git a/src/scheme/ao_scheme_save.c b/src/scheme/ao_scheme_save.c index af9345b8..3a595d71 100644 --- a/src/scheme/ao_scheme_save.c +++ b/src/scheme/ao_scheme_save.c @@ -17,11 +17,15 @@ ao_poly ao_scheme_do_save(struct ao_scheme_cons *cons) { +#ifdef AO_SCHEME_SAVE + struct ao_scheme_os_save *os; +#endif + if (!ao_scheme_check_argc(_ao_scheme_atom_save, cons, 0, 0)) return AO_SCHEME_NIL; #ifdef AO_SCHEME_SAVE - struct ao_scheme_os_save *os = (struct ao_scheme_os_save *) (void *) &ao_scheme_pool[AO_SCHEME_POOL]; + os = (struct ao_scheme_os_save *) (void *) &ao_scheme_pool[AO_SCHEME_POOL]; ao_scheme_collect(AO_SCHEME_COLLECT_FULL); os->atoms = ao_scheme_atom_poly(ao_scheme_atoms); @@ -38,12 +42,15 @@ ao_scheme_do_save(struct ao_scheme_cons *cons) ao_poly ao_scheme_do_restore(struct ao_scheme_cons *cons) { +#ifdef AO_SCHEME_SAVE + struct ao_scheme_os_save save; + struct ao_scheme_os_save *os = (struct ao_scheme_os_save *) (void *) &ao_scheme_pool[AO_SCHEME_POOL]; +#endif if (!ao_scheme_check_argc(_ao_scheme_atom_save, cons, 0, 0)) return AO_SCHEME_NIL; #ifdef AO_SCHEME_SAVE - struct ao_scheme_os_save save; - struct ao_scheme_os_save *os = (struct ao_scheme_os_save *) (void *) &ao_scheme_pool[AO_SCHEME_POOL]; + os = (struct ao_scheme_os_save *) (void *) &ao_scheme_pool[AO_SCHEME_POOL]; if (!ao_scheme_os_restore_save(&save, AO_SCHEME_POOL)) return ao_scheme_error(AO_SCHEME_INVALID, "header restore failed"); diff --git a/src/scheme/ao_scheme_stack.c b/src/scheme/ao_scheme_stack.c index d19dd6d6..e062a093 100644 --- a/src/scheme/ao_scheme_stack.c +++ b/src/scheme/ao_scheme_stack.c @@ -221,11 +221,12 @@ ao_scheme_stack_copy(struct ao_scheme_stack *old) ao_poly ao_scheme_stack_eval(void) { + struct ao_scheme_cons *cons; struct ao_scheme_stack *new = ao_scheme_stack_copy(ao_scheme_poly_stack(ao_scheme_v)); if (!new) return AO_SCHEME_NIL; - struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_stack->values); + cons = ao_scheme_poly_cons(ao_scheme_stack->values); if (!cons || !cons->cdr) return ao_scheme_error(AO_SCHEME_INVALID, "continuation requires a value"); diff --git a/src/scheme/ao_scheme_string.c b/src/scheme/ao_scheme_string.c index e25306cb..ada626c3 100644 --- a/src/scheme/ao_scheme_string.c +++ b/src/scheme/ao_scheme_string.c @@ -45,9 +45,10 @@ char * ao_scheme_string_copy(char *a) { int alen = strlen(a); + char *r; ao_scheme_string_stash(0, a); - char *r = ao_scheme_alloc(alen + 1); + r = ao_scheme_alloc(alen + 1); a = ao_scheme_string_fetch(0); if (!r) return NULL; @@ -60,10 +61,11 @@ ao_scheme_string_cat(char *a, char *b) { int alen = strlen(a); int blen = strlen(b); + char *r; ao_scheme_string_stash(0, a); ao_scheme_string_stash(1, b); - char *r = ao_scheme_alloc(alen + blen + 1); + r = ao_scheme_alloc(alen + blen + 1); a = ao_scheme_string_fetch(0); b = ao_scheme_string_fetch(1); if (!r) @@ -76,11 +78,15 @@ ao_scheme_string_cat(char *a, char *b) ao_poly ao_scheme_string_pack(struct ao_scheme_cons *cons) { - int len = ao_scheme_cons_length(cons); + char *r; + char *s; + int len; + + len = ao_scheme_cons_length(cons); ao_scheme_cons_stash(0, cons); - char *r = ao_scheme_alloc(len + 1); + r = ao_scheme_alloc(len + 1); cons = ao_scheme_cons_fetch(0); - char *s = r; + s = r; while (cons) { if (!ao_scheme_integer_typep(ao_scheme_poly_type(cons->car))) @@ -100,10 +106,11 @@ ao_scheme_string_unpack(char *a) int i; for (i = 0; (c = a[i]); i++) { + struct ao_scheme_cons *n; ao_scheme_cons_stash(0, cons); ao_scheme_cons_stash(1, tail); ao_scheme_string_stash(0, a); - struct ao_scheme_cons *n = ao_scheme_cons_cons(ao_scheme_int_poly(c), AO_SCHEME_NIL); + n = ao_scheme_cons_cons(ao_scheme_int_poly(c), AO_SCHEME_NIL); a = ao_scheme_string_fetch(0); cons = ao_scheme_cons_fetch(0); tail = ao_scheme_cons_fetch(1); diff --git a/src/scheme/make-const/Makefile b/src/scheme/make-const/Makefile index caf7acbe..438b6a79 100644 --- a/src/scheme/make-const/Makefile +++ b/src/scheme/make-const/Makefile @@ -10,7 +10,7 @@ HDRS=$(SCHEME_HDRS) ao_scheme_os.h OBJS=$(SRCS:.c=.o) CC=cc -CFLAGS=-DAO_SCHEME_MAKE_CONST -O0 -g -I. -Wall -Wextra +CFLAGS=-DAO_SCHEME_MAKE_CONST -O2 -g -I. -Wall -Wextra -Wpointer-arith -Wmissing-declarations -Wformat=2 -Wstrict-prototypes -Wmissing-prototypes -Wnested-externs -Wbad-function-cast -Wold-style-definition -Wdeclaration-after-statement -Wunused -Wuninitialized -Wshadow -Wmissing-noreturn -Wmissing-format-attribute -Wredundant-decls -Wlogical-op -Werror=implicit -Werror=nonnull -Werror=init-self -Werror=main -Werror=missing-braces -Werror=sequence-point -Werror=return-type -Werror=trigraphs -Werror=array-bounds -Werror=write-strings -Werror=address -Werror=int-to-pointer-cast -Werror=pointer-to-int-cast .c.o: $(CC) -c $(CFLAGS) $< -o $@ diff --git a/src/scheme/test/Makefile b/src/scheme/test/Makefile index d1bc4239..d51fa7ba 100644 --- a/src/scheme/test/Makefile +++ b/src/scheme/test/Makefile @@ -9,7 +9,7 @@ HDRS=$(SCHEME_HDRS) ao_scheme_const.h OBJS=$(SRCS:.c=.o) -CFLAGS=-O2 -g -Wall -Wextra -I. -I.. +CFLAGS=-O2 -g -Wall -Wextra -I. -I.. -Wpointer-arith -Wmissing-declarations -Wformat=2 -Wstrict-prototypes -Wmissing-prototypes -Wnested-externs -Wbad-function-cast -Wold-style-definition -Wdeclaration-after-statement -Wunused -Wuninitialized -Wshadow -Wmissing-noreturn -Wmissing-format-attribute -Wredundant-decls -Wlogical-op -Werror=implicit -Werror=nonnull -Werror=init-self -Werror=main -Werror=missing-braces -Werror=sequence-point -Werror=return-type -Werror=trigraphs -Werror=array-bounds -Werror=write-strings -Werror=address -Werror=int-to-pointer-cast -Werror=pointer-to-int-cast ao-scheme: $(OBJS) cc $(CFLAGS) -o $@ $(OBJS) -lm diff --git a/src/scheme/test/ao_scheme_os.h b/src/scheme/test/ao_scheme_os.h index 958f68be..b225b2e8 100644 --- a/src/scheme/test/ao_scheme_os.h +++ b/src/scheme/test/ao_scheme_os.h @@ -28,7 +28,7 @@ extern int ao_scheme_getc(void); static inline void -ao_scheme_os_flush() { +ao_scheme_os_flush(void) { fflush(stdout); } diff --git a/src/scheme/tiny-test/Makefile b/src/scheme/tiny-test/Makefile index 5082df44..6b1fe003 100644 --- a/src/scheme/tiny-test/Makefile +++ b/src/scheme/tiny-test/Makefile @@ -11,7 +11,7 @@ HDRS=$(SCHEME_HDRS) ao_scheme_const.h OBJS=$(SRCS:.c=.o) -CFLAGS=-O0 -g -Wall -Wextra -I. -I.. +CFLAGS=-O0 -g -Wall -Wextra -I. -I.. -Wpointer-arith -Wmissing-declarations -Wformat=2 -Wstrict-prototypes -Wmissing-prototypes -Wnested-externs -Wbad-function-cast -Wold-style-definition -Wdeclaration-after-statement -Wunused -Wuninitialized -Wshadow -Wmissing-noreturn -Wmissing-format-attribute -Wredundant-decls -Wlogical-op -Werror=implicit -Werror=nonnull -Werror=init-self -Werror=main -Werror=missing-braces -Werror=sequence-point -Werror=return-type -Werror=trigraphs -Werror=array-bounds -Werror=write-strings -Werror=address -Werror=int-to-pointer-cast -Werror=pointer-to-int-cast ao-scheme-tiny: $(OBJS) cc $(CFLAGS) -o $@ $(OBJS) -lm diff --git a/src/scheme/tiny-test/ao_scheme_os.h b/src/scheme/tiny-test/ao_scheme_os.h index 7cfe3981..b9f3e31f 100644 --- a/src/scheme/tiny-test/ao_scheme_os.h +++ b/src/scheme/tiny-test/ao_scheme_os.h @@ -22,18 +22,13 @@ #include #include -#undef AO_SCHEME_FEATURE_FLOAT -#undef AO_SCHEME_FEATURE_VECTOR -#undef AO_SCHEME_FEATURE_QUASI -#undef AO_SCHEME_FEATURE_BIGINT - #define AO_SCHEME_POOL_TOTAL 4096 #define AO_SCHEME_SAVE 1 extern int ao_scheme_getc(void); static inline void -ao_scheme_os_flush() { +ao_scheme_os_flush(void) { fflush(stdout); } -- cgit v1.2.3 From c490efdf90befdf048ff7d9cbbe26bcc6f942820 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 12 Dec 2017 18:00:12 -0800 Subject: altos/scheme: Use direct calls from frame to frame_vals mem functions Avoids the extra stack depth of the poly versions. Signed-off-by: Keith Packard --- src/scheme/ao_scheme_frame.c | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/src/scheme/ao_scheme_frame.c b/src/scheme/ao_scheme_frame.c index e5d481e7..7f521863 100644 --- a/src/scheme/ao_scheme_frame.c +++ b/src/scheme/ao_scheme_frame.c @@ -84,10 +84,13 @@ frame_mark(void *addr) struct ao_scheme_frame *frame = addr; for (;;) { + struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); + MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); if (!AO_SCHEME_IS_POOL(frame)) break; - ao_scheme_poly_mark(frame->vals, 0); + if (!ao_scheme_mark_memory(&ao_scheme_frame_vals_type, vals)) + frame_vals_mark(vals); frame = ao_scheme_poly_frame(frame->prev); MDBG_MOVE("frame next %d\n", MDBG_OFFSET(frame)); if (!frame) @@ -103,13 +106,20 @@ frame_move(void *addr) struct ao_scheme_frame *frame = addr; for (;;) { - struct ao_scheme_frame *prev; - int ret; + struct ao_scheme_frame *prev; + struct ao_scheme_frame_vals *vals; + int ret; MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); if (!AO_SCHEME_IS_POOL(frame)) break; - ao_scheme_poly_move(&frame->vals, 0); + + vals = ao_scheme_poly_frame_vals(frame->vals); + if (!ao_scheme_move_memory(&ao_scheme_frame_vals_type, (void **) &vals)) + frame_vals_move(vals); + if (vals != ao_scheme_poly_frame_vals(frame->vals)) + frame->vals = ao_scheme_frame_vals_poly(vals); + prev = ao_scheme_poly_frame(frame->prev); if (!prev) break; -- cgit v1.2.3 From 839a7454686415a52f532d0e4f379061a68d5f1b Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 12 Dec 2017 18:01:21 -0800 Subject: altos/scheme: inline some mem calls to reduce stack usage. Also includes some code to display stack usage during collect calls. Signed-off-by: Keith Packard --- src/scheme/ao_scheme_mem.c | 115 ++++++++++++++++++++++++++++++--------------- 1 file changed, 77 insertions(+), 38 deletions(-) diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c index 292d0f9d..afa06d54 100644 --- a/src/scheme/ao_scheme_mem.c +++ b/src/scheme/ao_scheme_mem.c @@ -41,6 +41,36 @@ uint8_t ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribute__((ali #define DBG_MEM_STATS DBG_MEM #endif +#define DBG_MEM_STACK 0 +#if DBG_MEM_STACK +char *mem_collect_stack; +int64_t mem_collect_max_depth; + +static void +ao_scheme_check_stack(void) +{ + char x; + int64_t depth; + + depth = mem_collect_stack - &x; + if (depth > mem_collect_max_depth) + mem_collect_max_depth = depth; +} + +static void +_ao_scheme_reset_stack(char *x) +{ + mem_collect_stack = x; +// mem_collect_max_depth = 0; +} +#define ao_scheme_declare_stack char x; +#define ao_scheme_reset_stack() _ao_scheme_reset_stack(&x) +#else +#define ao_scheme_check_stack() +#define ao_scheme_declare_stack +#define ao_scheme_reset_stack() +#endif + #if DBG_MEM int dbg_move_depth; int dbg_mem = DBG_MEM_START; @@ -281,6 +311,7 @@ static inline uint16_t pool_offset(void *addr) { static inline void mark(uint8_t *tag, int offset) { int byte = offset >> 5; int bit = (offset >> 2) & 7; + ao_scheme_check_stack(); tag[byte] |= (1 << bit); } @@ -303,7 +334,7 @@ static inline int limit(int offset) { return min(AO_SCHEME_POOL, max(offset, 0)); } -static void +static inline void note_cons(uint16_t offset) { MDBG_MOVE("note cons %d\n", offset); @@ -335,6 +366,7 @@ static void note_chunk(uint16_t offset, uint16_t size) { int l; + int end; if (offset < chunk_low || chunk_high <= offset) return; @@ -357,7 +389,7 @@ note_chunk(uint16_t offset, uint16_t size) #endif /* Shuffle existing entries right */ - int end = min(AO_SCHEME_NCHUNK, chunk_last + 1); + end = min(AO_SCHEME_NCHUNK, chunk_last + 1); memmove(&ao_scheme_chunk[l+1], &ao_scheme_chunk[l], @@ -476,6 +508,12 @@ static const struct ao_scheme_type * const ao_scheme_types[AO_SCHEME_NUM_TYPE] = #endif }; +static int +ao_scheme_mark(const struct ao_scheme_type *type, void *addr); + +static int +ao_scheme_move(const struct ao_scheme_type *type, void **ref); + static int ao_scheme_mark_ref(const struct ao_scheme_type *type, void **ref) { @@ -499,6 +537,7 @@ int ao_scheme_last_top; int ao_scheme_collect(uint8_t style) { + ao_scheme_declare_stack int i; int top; #if DBG_MEM_STATS @@ -511,6 +550,8 @@ ao_scheme_collect(uint8_t style) #endif MDBG_DO(ao_scheme_frame_write(ao_scheme_frame_poly(ao_scheme_frame_global))); + ao_scheme_reset_stack(); + /* The first time through, we're doing a full collect */ if (ao_scheme_last_top == 0) style = AO_SCHEME_COLLECT_FULL; @@ -628,6 +669,9 @@ ao_scheme_collect(uint8_t style) MDBG_DO(memset(ao_scheme_chunk, '\0', sizeof (ao_scheme_chunk)); walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref)); +#if DBG_MEM_STACK + fprintf(stderr, "max collect stack depth %lu\n", mem_collect_max_depth); +#endif return AO_SCHEME_POOL - ao_scheme_top; } @@ -662,28 +706,6 @@ ao_scheme_cons_check(struct ao_scheme_cons *cons) */ -/* - * Mark a block of memory with an explicit size - */ - -int -ao_scheme_mark_block(void *addr, int size) -{ - int offset; - if (!AO_SCHEME_IS_POOL(addr)) - return 1; - - offset = pool_offset(addr); - MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); - if (busy(ao_scheme_busy, offset)) { - MDBG_MOVE("already marked\n"); - return 1; - } - mark(ao_scheme_busy, offset); - note_chunk(offset, size); - return 0; -} - /* * Note a reference to memory and collect information about a few * object sizes at a time @@ -710,7 +732,7 @@ ao_scheme_mark_memory(const struct ao_scheme_type *type, void *addr) /* * Mark an object and all that it refereces */ -int +static int ao_scheme_mark(const struct ao_scheme_type *type, void *addr) { int ret; @@ -737,6 +759,7 @@ ao_scheme_poly_mark(ao_poly p, uint8_t do_note_cons) { uint8_t type; void *addr; + int ret; type = ao_scheme_poly_base_type(p); @@ -751,16 +774,26 @@ ao_scheme_poly_mark(ao_poly p, uint8_t do_note_cons) note_cons(pool_offset(addr)); return 1; } else { + const struct ao_scheme_type *lisp_type; + if (type == AO_SCHEME_OTHER) type = ao_scheme_other_type(addr); - const struct ao_scheme_type *lisp_type = ao_scheme_types[type]; + lisp_type = ao_scheme_types[type]; #if DBG_MEM if (!lisp_type) ao_scheme_abort(); #endif - return ao_scheme_mark(lisp_type, addr); + MDBG_MOVE("mark %d\n", MDBG_OFFSET(addr)); + MDBG_MOVE_IN(); + ret = ao_scheme_mark_memory(lisp_type, addr); + if (!ret) { + MDBG_MOVE("mark recurse\n"); + lisp_type->mark(addr); + } + MDBG_MOVE_OUT(); + return ret; } } @@ -817,7 +850,7 @@ ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref) return 0; } -int +static int ao_scheme_move(const struct ao_scheme_type *type, void **ref) { int ret; @@ -835,16 +868,12 @@ ao_scheme_move(const struct ao_scheme_type *type, void **ref) int ao_scheme_poly_move(ao_poly *ref, uint8_t do_note_cons) { - uint8_t type; ao_poly p = *ref; int ret; void *addr; uint16_t offset, orig_offset; - uint8_t base_type; - base_type = type = ao_scheme_poly_base_type(p); - - if (type == AO_SCHEME_INT) + if (ao_scheme_poly_base_type(p) == AO_SCHEME_INT) return 1; addr = ao_scheme_ref(p); @@ -854,25 +883,35 @@ ao_scheme_poly_move(ao_poly *ref, uint8_t do_note_cons) orig_offset = pool_offset(addr); offset = move_map(orig_offset); - if (type == AO_SCHEME_CONS && do_note_cons) { + if (ao_scheme_poly_base_type(p) == AO_SCHEME_CONS && do_note_cons) { note_cons(orig_offset); ret = 1; } else { + uint8_t type = ao_scheme_poly_base_type(p); + const struct ao_scheme_type *lisp_type; + if (type == AO_SCHEME_OTHER) type = ao_scheme_other_type(ao_scheme_pool + offset); - const struct ao_scheme_type *lisp_type = ao_scheme_types[type]; + lisp_type = ao_scheme_types[type]; #if DBG_MEM if (!lisp_type) ao_scheme_abort(); #endif - - ret = ao_scheme_move(lisp_type, &addr); + /* inline ao_scheme_move to save stack space */ + MDBG_MOVE("move object %d\n", MDBG_OFFSET(addr)); + MDBG_MOVE_IN(); + ret = ao_scheme_move_memory(lisp_type, &addr); + if (!ret) { + MDBG_MOVE("move recurse\n"); + lisp_type->move(addr); + } + MDBG_MOVE_OUT(); } /* Re-write the poly value */ if (offset != orig_offset) { - ao_poly np = ao_scheme_poly(ao_scheme_pool + offset, base_type); + ao_poly np = ao_scheme_poly(ao_scheme_pool + offset, ao_scheme_poly_base_type(p)); MDBG_MOVE("poly %d moved %d -> %d\n", type, orig_offset, offset); *ref = np; -- cgit v1.2.3 From 0614c653a8ca8c4ccbf59d34296ca4b3e7d9f3a0 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 12 Dec 2017 18:02:17 -0800 Subject: altos/lambdakey-v1.0: Make stack larger scheme doesn't like to run with less than a 1kB stack. Signed-off-by: Keith Packard --- src/lambdakey-v1.0/ao_scheme_os.h | 7 +------ src/lambdakey-v1.0/lambda.ld | 4 ++-- 2 files changed, 3 insertions(+), 8 deletions(-) diff --git a/src/lambdakey-v1.0/ao_scheme_os.h b/src/lambdakey-v1.0/ao_scheme_os.h index 0d48af3b..b3080f31 100644 --- a/src/lambdakey-v1.0/ao_scheme_os.h +++ b/src/lambdakey-v1.0/ao_scheme_os.h @@ -20,12 +20,7 @@ #include "ao.h" -#undef AO_SCHEME_FEATURE_FLOAT -#undef AO_SCHEME_FEATURE_VECTOR -#undef AO_SCHEME_FEATURE_QUASI -#undef AO_SCHEME_FEATURE_BIGINT - -#define AO_SCHEME_POOL 4096 +#define AO_SCHEME_POOL 3584 #define AO_SCHEME_TOKEN_MAX 64 #ifndef __BYTE_ORDER diff --git a/src/lambdakey-v1.0/lambda.ld b/src/lambdakey-v1.0/lambda.ld index 15b2d971..b09fdb4a 100644 --- a/src/lambdakey-v1.0/lambda.ld +++ b/src/lambdakey-v1.0/lambda.ld @@ -18,8 +18,8 @@ MEMORY { rom (rx) : ORIGIN = 0x08001000, LENGTH = 28K - ram (!w) : ORIGIN = 0x20000000, LENGTH = 6k - 480 - stack (!w) : ORIGIN = 0x20000000 + 6k - 480, LENGTH = 480 + ram (!w) : ORIGIN = 0x20000000, LENGTH = 6k - 1k + stack (!w) : ORIGIN = 0x20000000 + 6k - 1k, LENGTH = 1k } INCLUDE registers.ld -- cgit v1.2.3 From 2e11cae044cd2c053049effd76df9c5adecb84d7 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 12 Dec 2017 18:07:06 -0800 Subject: altos/scheme: integer? is builtin on all versions Signed-off-by: Keith Packard --- src/scheme/ao_scheme_builtin.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/scheme/ao_scheme_builtin.txt b/src/scheme/ao_scheme_builtin.txt index 14f279a4..23adf6ed 100644 --- a/src/scheme/ao_scheme_builtin.txt +++ b/src/scheme/ao_scheme_builtin.txt @@ -47,7 +47,7 @@ all f_lambda nullp null? all f_lambda not all f_lambda listp list? all f_lambda pairp pair? -FLOAT f_lambda integerp integer? exact? exact-integer? +all f_lambda integerp integer? exact? exact-integer? all f_lambda numberp number? real? all f_lambda booleanp boolean? all f_lambda set_car set-car! -- cgit v1.2.3 From 32f6877288ea6b7eb1cae9a42fbe8e2c5dbb2f08 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 14 Dec 2017 23:04:39 -0800 Subject: altos/scheme: swap BIGINT and STRING types This lets BIGINT be a primitive type, allowing it to use all 32 bits for storage. This does make strings another byte longer, and also slightly harder to deal with. It's a trade off. Signed-off-by: Keith Packard --- src/scheme/ao_scheme.h | 82 +++++++++++++----------------- src/scheme/ao_scheme_atom.c | 40 ++++++++++++--- src/scheme/ao_scheme_builtin.c | 55 +++++++++++---------- src/scheme/ao_scheme_float.c | 4 +- src/scheme/ao_scheme_int.c | 17 ++++--- src/scheme/ao_scheme_mem.c | 25 +++++++--- src/scheme/ao_scheme_poly.c | 16 +++--- src/scheme/ao_scheme_read.c | 4 +- src/scheme/ao_scheme_string.c | 110 +++++++++++++++++++++++++++++------------ src/scheme/ao_scheme_vector.c | 11 +++-- 10 files changed, 220 insertions(+), 144 deletions(-) diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index ad80db2f..521ec105 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -23,6 +23,7 @@ #include #include +#include #define AO_SCHEME_BUILTIN_FEATURES #include "ao_scheme_builtin.h" #undef AO_SCHEME_BUILTIN_FEATURES @@ -93,7 +94,7 @@ extern uint8_t ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribut /* Primitive types */ #define AO_SCHEME_CONS 0 #define AO_SCHEME_INT 1 -#define AO_SCHEME_STRING 2 +#define AO_SCHEME_BIGINT 2 #define AO_SCHEME_OTHER 3 #define AO_SCHEME_TYPE_MASK 0x0003 @@ -109,17 +110,12 @@ extern uint8_t ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribut #define AO_SCHEME_LAMBDA 8 #define AO_SCHEME_STACK 9 #define AO_SCHEME_BOOL 10 -#ifdef AO_SCHEME_FEATURE_BIGINT -#define AO_SCHEME_BIGINT 11 -#define _AO_SCHEME_BIGINT AO_SCHEME_BIGINT -#else -#define _AO_SCHEME_BIGINT AO_SCHEME_BOOL -#endif +#define AO_SCHEME_STRING 11 #ifdef AO_SCHEME_FEATURE_FLOAT -#define AO_SCHEME_FLOAT (_AO_SCHEME_BIGINT + 1) +#define AO_SCHEME_FLOAT 12 #define _AO_SCHEME_FLOAT AO_SCHEME_FLOAT #else -#define _AO_SCHEME_FLOAT _AO_SCHEME_BIGINT +#define _AO_SCHEME_FLOAT 12 #endif #ifdef AO_SCHEME_FEATURE_VECTOR #define AO_SCHEME_VECTOR 13 @@ -180,6 +176,11 @@ struct ao_scheme_atom { char name[]; }; +struct ao_scheme_string { + uint8_t type; + char val[]; +}; + struct ao_scheme_val { ao_poly atom; ao_poly val; @@ -227,38 +228,16 @@ struct ao_scheme_vector { #define AO_SCHEME_MAX_INT ((1 << (15 - AO_SCHEME_TYPE_SHIFT)) - 1) #ifdef AO_SCHEME_FEATURE_BIGINT + struct ao_scheme_bigint { uint32_t value; }; -#define AO_SCHEME_MIN_BIGINT (-(1 << 24)) -#define AO_SCHEME_MAX_BIGINT ((1 << 24) - 1) - -#if __BYTE_ORDER == __LITTLE_ENDIAN +#define AO_SCHEME_MIN_BIGINT INT32_MIN +#define AO_SCHEME_MAX_BIGINT INT32_MAX -static inline uint32_t -ao_scheme_int_bigint(int32_t i) { - return AO_SCHEME_BIGINT | (i << 8); -} -static inline int32_t -ao_scheme_bigint_int(uint32_t bi) { - return (int32_t) bi >> 8; -} -#else -static inline uint32_t -ao_scheme_int_bigint(int32_t i) { - return (uint32_t) (i & 0xffffff) | (AO_SCHEME_BIGINT << 24); -} -static inlint int32_t -ao_scheme_bigint_int(uint32_t bi) { - return (int32_t) (bi << 8) >> 8; -} - -#endif /* __BYTE_ORDER */ #endif /* AO_SCHEME_FEATURE_BIGINT */ -#define AO_SCHEME_NOT_INTEGER 0x7fffffff - /* Set on type when the frame escapes the lambda */ #define AO_SCHEME_FRAME_MARK 0x80 #define AO_SCHEME_FRAME_PRINT 0x40 @@ -475,20 +454,20 @@ ao_scheme_poly_bigint(ao_poly poly) static inline ao_poly ao_scheme_bigint_poly(struct ao_scheme_bigint *bi) { - return ao_scheme_poly(bi, AO_SCHEME_OTHER); + return ao_scheme_poly(bi, AO_SCHEME_BIGINT); } #endif /* AO_SCHEME_FEATURE_BIGINT */ -static inline char * +static inline struct ao_scheme_string * ao_scheme_poly_string(ao_poly poly) { return ao_scheme_ref(poly); } static inline ao_poly -ao_scheme_string_poly(char *s) +ao_scheme_string_poly(struct ao_scheme_string *s) { - return ao_scheme_poly(s, AO_SCHEME_STRING); + return ao_scheme_poly(s, AO_SCHEME_OTHER); } static inline struct ao_scheme_atom * @@ -599,9 +578,9 @@ ao_poly ao_scheme_poly_fetch(int id); void -ao_scheme_string_stash(int id, char *string); +ao_scheme_string_stash(int id, struct ao_scheme_string *string); -char * +struct ao_scheme_string * ao_scheme_string_fetch(int id); static inline void @@ -667,17 +646,23 @@ ao_scheme_cons_copy(struct ao_scheme_cons *cons); /* string */ extern const struct ao_scheme_type ao_scheme_string_type; -char * -ao_scheme_string_copy(char *a); +struct ao_scheme_string * +ao_scheme_string_copy(struct ao_scheme_string *a); -char * -ao_scheme_string_cat(char *a, char *b); +struct ao_scheme_string * +ao_scheme_string_make(char *a); + +struct ao_scheme_string * +ao_scheme_atom_to_string(struct ao_scheme_atom *a); + +struct ao_scheme_string * +ao_scheme_string_cat(struct ao_scheme_string *a, struct ao_scheme_string *b); ao_poly ao_scheme_string_pack(struct ao_scheme_cons *cons); ao_poly -ao_scheme_string_unpack(char *a); +ao_scheme_string_unpack(struct ao_scheme_string *a); void ao_scheme_string_write(ao_poly s); @@ -695,6 +680,9 @@ extern struct ao_scheme_frame *ao_scheme_frame_current; void ao_scheme_atom_write(ao_poly a); +struct ao_scheme_atom * +ao_scheme_string_to_atom(struct ao_scheme_string *string); + struct ao_scheme_atom * ao_scheme_atom_intern(char *name); @@ -716,7 +704,7 @@ ao_scheme_int_write(ao_poly i); #ifdef AO_SCHEME_FEATURE_BIGINT int32_t -ao_scheme_poly_integer(ao_poly p); +ao_scheme_poly_integer(ao_poly p, bool *fail); ao_poly ao_scheme_integer_poly(int32_t i); @@ -734,7 +722,7 @@ extern const struct ao_scheme_type ao_scheme_bigint_type; #else -#define ao_scheme_poly_integer ao_scheme_poly_int +#define ao_scheme_poly_integer(a,b) ao_scheme_poly_int(a) #define ao_scheme_integer_poly ao_scheme_int_poly static inline int diff --git a/src/scheme/ao_scheme_atom.c b/src/scheme/ao_scheme_atom.c index cb32b7fe..745c32fe 100644 --- a/src/scheme/ao_scheme_atom.c +++ b/src/scheme/ao_scheme_atom.c @@ -71,8 +71,8 @@ const struct ao_scheme_type ao_scheme_atom_type = { struct ao_scheme_atom *ao_scheme_atoms; -struct ao_scheme_atom * -ao_scheme_atom_intern(char *name) +static struct ao_scheme_atom * +ao_scheme_atom_find(char *name) { struct ao_scheme_atom *atom; @@ -86,15 +86,43 @@ ao_scheme_atom_intern(char *name) return atom; } #endif - ao_scheme_string_stash(0, name); - atom = ao_scheme_alloc(name_size(name)); - name = ao_scheme_string_fetch(0); + return NULL; +} + +static void +ao_scheme_atom_init(struct ao_scheme_atom *atom, char *name) +{ if (atom) { atom->type = AO_SCHEME_ATOM; + strcpy(atom->name, name); atom->next = ao_scheme_atom_poly(ao_scheme_atoms); ao_scheme_atoms = atom; - strcpy(atom->name, name); } +} + +struct ao_scheme_atom * +ao_scheme_string_to_atom(struct ao_scheme_string *string) +{ + struct ao_scheme_atom *atom = ao_scheme_atom_find(string->val); + + if (atom) + return atom; + ao_scheme_string_stash(0, string); + atom = ao_scheme_alloc(name_size(string->val)); + string = ao_scheme_string_fetch(0); + ao_scheme_atom_init(atom, string->val); + return atom; +} + +struct ao_scheme_atom * +ao_scheme_atom_intern(char *name) +{ + struct ao_scheme_atom *atom = ao_scheme_atom_find(name); + if (atom) + return atom; + + atom = ao_scheme_alloc(name_size(name)); + ao_scheme_atom_init(atom, name); return atom; } diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index b6788993..9a823f6a 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -130,10 +130,11 @@ ao_scheme_check_argt(ao_poly name, struct ao_scheme_cons *cons, int argc, int ty static int32_t ao_scheme_arg_int(ao_poly name, struct ao_scheme_cons *cons, int argc) { - ao_poly p = ao_scheme_arg(cons, argc); - int32_t i = ao_scheme_poly_integer(p); + ao_poly p = ao_scheme_arg(cons, argc); + bool fail = false; + int32_t i = ao_scheme_poly_integer(p, &fail); - if (i == AO_SCHEME_NOT_INTEGER) + if (fail) (void) ao_scheme_error(AO_SCHEME_INVALID, "%v: arg %d invalid type %v", name, argc, p); return i; } @@ -324,14 +325,14 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) switch (op) { case builtin_minus: if (ao_scheme_integer_typep(ct)) - ret = ao_scheme_integer_poly(-ao_scheme_poly_integer(ret)); + ret = ao_scheme_integer_poly(-ao_scheme_poly_integer(ret, NULL)); #ifdef AO_SCHEME_FEATURE_FLOAT else if (ct == AO_SCHEME_FLOAT) ret = ao_scheme_float_get(-ao_scheme_poly_number(ret)); #endif break; case builtin_divide: - if (ao_scheme_integer_typep(ct) && ao_scheme_poly_integer(ret) == 1) { + if (ao_scheme_poly_integer(ret, NULL) == 1) { } else { #ifdef AO_SCHEME_FEATURE_FLOAT if (ao_scheme_number_typep(ct)) { @@ -349,8 +350,8 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) } cons = ao_scheme_cons_fetch(0); } else if (ao_scheme_integer_typep(rt) && ao_scheme_integer_typep(ct)) { - int32_t r = ao_scheme_poly_integer(ret); - int32_t c = ao_scheme_poly_integer(car); + int32_t r = ao_scheme_poly_integer(ret, NULL); + int32_t c = ao_scheme_poly_integer(car, NULL); #ifdef AO_SCHEME_FEATURE_FLOAT int64_t t; #endif @@ -519,8 +520,8 @@ ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op) uint8_t lt = ao_scheme_poly_type(left); uint8_t rt = ao_scheme_poly_type(right); if (ao_scheme_integer_typep(lt) && ao_scheme_integer_typep(rt)) { - int32_t l = ao_scheme_poly_integer(left); - int32_t r = ao_scheme_poly_integer(right); + int32_t l = ao_scheme_poly_integer(left, NULL); + int32_t r = ao_scheme_poly_integer(right, NULL); switch (op) { case builtin_less: @@ -577,8 +578,8 @@ ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op) } #endif /* AO_SCHEME_FEATURE_FLOAT */ } else if (lt == AO_SCHEME_STRING && rt == AO_SCHEME_STRING) { - int c = strcmp(ao_scheme_poly_string(left), - ao_scheme_poly_string(right)); + int c = strcmp(ao_scheme_poly_string(left)->val, + ao_scheme_poly_string(right)->val); switch (op) { case builtin_less: if (!(c < 0)) @@ -664,16 +665,16 @@ ao_scheme_do_string_to_list(struct ao_scheme_cons *cons) ao_poly ao_scheme_do_string_ref(struct ao_scheme_cons *cons) { - char *string; + char *string; int32_t ref; if (!ao_scheme_check_argc(_ao_scheme_atom_string2dref, cons, 2, 2)) return AO_SCHEME_NIL; if (!ao_scheme_check_argt(_ao_scheme_atom_string2dref, cons, 0, AO_SCHEME_STRING, 0)) return AO_SCHEME_NIL; ref = ao_scheme_arg_int(_ao_scheme_atom_string2dref, cons, 1); - if (ref == AO_SCHEME_NOT_INTEGER) + if (ao_scheme_exception) return AO_SCHEME_NIL; - string = ao_scheme_poly_string(ao_scheme_arg(cons, 0)); + string = ao_scheme_poly_string(ao_scheme_arg(cons, 0))->val; while (*string && ref) { ++string; --ref; @@ -689,20 +690,20 @@ ao_scheme_do_string_ref(struct ao_scheme_cons *cons) ao_poly ao_scheme_do_string_length(struct ao_scheme_cons *cons) { - char *string; + struct ao_scheme_string *string; if (!ao_scheme_check_argc(_ao_scheme_atom_string2dlength, cons, 1, 1)) return AO_SCHEME_NIL; if (!ao_scheme_check_argt(_ao_scheme_atom_string2dlength, cons, 0, AO_SCHEME_STRING, 0)) return AO_SCHEME_NIL; string = ao_scheme_poly_string(ao_scheme_arg(cons, 0)); - return ao_scheme_integer_poly(strlen(string)); + return ao_scheme_integer_poly(strlen(string->val)); } ao_poly ao_scheme_do_string_copy(struct ao_scheme_cons *cons) { - char *string; + struct ao_scheme_string *string; if (!ao_scheme_check_argc(_ao_scheme_atom_string2dcopy, cons, 1, 1)) return AO_SCHEME_NIL; @@ -715,7 +716,7 @@ ao_scheme_do_string_copy(struct ao_scheme_cons *cons) ao_poly ao_scheme_do_string_set(struct ao_scheme_cons *cons) { - char *string; + char *string; int32_t ref; int32_t val; @@ -723,12 +724,12 @@ ao_scheme_do_string_set(struct ao_scheme_cons *cons) return AO_SCHEME_NIL; if (!ao_scheme_check_argt(_ao_scheme_atom_string2dset21, cons, 0, AO_SCHEME_STRING, 0)) return AO_SCHEME_NIL; - string = ao_scheme_poly_string(ao_scheme_arg(cons, 0)); + string = ao_scheme_poly_string(ao_scheme_arg(cons, 0))->val; ref = ao_scheme_arg_int(_ao_scheme_atom_string2dset21, cons, 1); - if (ref == AO_SCHEME_NOT_INTEGER) + if (ao_scheme_exception) return AO_SCHEME_NIL; val = ao_scheme_arg_int(_ao_scheme_atom_string2dset21, cons, 2); - if (val == AO_SCHEME_NOT_INTEGER) + if (ao_scheme_exception) return AO_SCHEME_NIL; while (*string && ref) { ++string; @@ -759,7 +760,7 @@ ao_scheme_do_led(struct ao_scheme_cons *cons) if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) return AO_SCHEME_NIL; led = ao_scheme_arg_int(_ao_scheme_atom_led, cons, 0); - if (led == AO_SCHEME_NOT_INTEGER) + if (ao_scheme_exception) return AO_SCHEME_NIL; led = ao_scheme_arg(cons, 0); ao_scheme_os_led(ao_scheme_poly_int(led)); @@ -774,7 +775,7 @@ ao_scheme_do_delay(struct ao_scheme_cons *cons) if (!ao_scheme_check_argc(_ao_scheme_atom_delay, cons, 1, 1)) return AO_SCHEME_NIL; delay = ao_scheme_arg_int(_ao_scheme_atom_delay, cons, 0); - if (delay == AO_SCHEME_NOT_INTEGER) + if (ao_scheme_exception) return AO_SCHEME_NIL; ao_scheme_os_delay(delay); return delay; @@ -978,7 +979,7 @@ ao_scheme_do_symbol_to_string(struct ao_scheme_cons *cons) return AO_SCHEME_NIL; if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_ATOM, 0)) return AO_SCHEME_NIL; - return ao_scheme_string_poly(ao_scheme_string_copy(ao_scheme_poly_atom(ao_scheme_arg(cons, 0))->name)); + return ao_scheme_string_poly(ao_scheme_atom_to_string(ao_scheme_poly_atom(ao_scheme_arg(cons, 0)))); } ao_poly @@ -989,7 +990,7 @@ ao_scheme_do_string_to_symbol(struct ao_scheme_cons *cons) if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_STRING, 0)) return AO_SCHEME_NIL; - return ao_scheme_atom_poly(ao_scheme_atom_intern(ao_scheme_poly_string(ao_scheme_arg(cons, 0)))); + return ao_scheme_atom_poly(ao_scheme_string_to_atom(ao_scheme_poly_string(ao_scheme_arg(cons, 0))));; } ao_poly @@ -1009,7 +1010,7 @@ ao_scheme_do_write_char(struct ao_scheme_cons *cons) return AO_SCHEME_NIL; if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0)) return AO_SCHEME_NIL; - putchar(ao_scheme_poly_integer(ao_scheme_arg(cons, 0))); + putchar(ao_scheme_poly_integer(ao_scheme_arg(cons, 0), NULL)); return _ao_scheme_bool_true; } @@ -1068,7 +1069,7 @@ ao_scheme_do_make_vector(struct ao_scheme_cons *cons) if (!ao_scheme_check_argc(_ao_scheme_atom_make2dvector, cons, 2, 2)) return AO_SCHEME_NIL; k = ao_scheme_arg_int(_ao_scheme_atom_make2dvector, cons, 0); - if (k == AO_SCHEME_NOT_INTEGER) + if (ao_scheme_exception) return AO_SCHEME_NIL; return ao_scheme_vector_poly(ao_scheme_vector_alloc(k, ao_scheme_arg(cons, 1))); } diff --git a/src/scheme/ao_scheme_float.c b/src/scheme/ao_scheme_float.c index c026c6fb..b75289d7 100644 --- a/src/scheme/ao_scheme_float.c +++ b/src/scheme/ao_scheme_float.c @@ -69,10 +69,10 @@ ao_scheme_poly_number(ao_poly p) switch (ao_scheme_poly_base_type(p)) { case AO_SCHEME_INT: return ao_scheme_poly_int(p); + case AO_SCHEME_BIGINT: + return ao_scheme_poly_bigint(p)->value; case AO_SCHEME_OTHER: switch (ao_scheme_other_type(ao_scheme_poly_other(p))) { - case AO_SCHEME_BIGINT: - return ao_scheme_bigint_int(ao_scheme_poly_bigint(p)->value); case AO_SCHEME_FLOAT: return ao_scheme_poly_float(p)->value; } diff --git a/src/scheme/ao_scheme_int.c b/src/scheme/ao_scheme_int.c index 43d6b8e1..4fcf4931 100644 --- a/src/scheme/ao_scheme_int.c +++ b/src/scheme/ao_scheme_int.c @@ -24,16 +24,19 @@ ao_scheme_int_write(ao_poly p) #ifdef AO_SCHEME_FEATURE_BIGINT int32_t -ao_scheme_poly_integer(ao_poly p) +ao_scheme_poly_integer(ao_poly p, bool *fail) { + if (fail) + *fail = false; switch (ao_scheme_poly_base_type(p)) { case AO_SCHEME_INT: return ao_scheme_poly_int(p); - case AO_SCHEME_OTHER: - if (ao_scheme_other_type(ao_scheme_poly_other(p)) == AO_SCHEME_BIGINT) - return ao_scheme_bigint_int(ao_scheme_poly_bigint(p)->value); + case AO_SCHEME_BIGINT: + return ao_scheme_poly_bigint(p)->value; } - return AO_SCHEME_NOT_INTEGER; + if (fail) + *fail = true; + return 0; } ao_poly @@ -44,7 +47,7 @@ ao_scheme_integer_poly(int32_t p) if (AO_SCHEME_MIN_INT <= p && p <= AO_SCHEME_MAX_INT) return ao_scheme_int_poly(p); bi = ao_scheme_alloc(sizeof (struct ao_scheme_bigint)); - bi->value = ao_scheme_int_bigint(p); + bi->value = p; return ao_scheme_bigint_poly(bi); } @@ -77,6 +80,6 @@ ao_scheme_bigint_write(ao_poly p) { struct ao_scheme_bigint *bi = ao_scheme_poly_bigint(p); - printf("%d", ao_scheme_bigint_int(bi->value)); + printf("%d", bi->value); } #endif /* AO_SCHEME_FEATURE_BIGINT */ diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c index afa06d54..e7e89b89 100644 --- a/src/scheme/ao_scheme_mem.c +++ b/src/scheme/ao_scheme_mem.c @@ -178,7 +178,7 @@ struct ao_scheme_root { }; static struct ao_scheme_cons *save_cons[2]; -static char *save_string[2]; +static struct ao_scheme_string *save_string[2]; static struct ao_scheme_frame *save_frame[1]; static ao_poly save_poly[3]; @@ -488,7 +488,9 @@ dump_busy(void) static const struct ao_scheme_type * const ao_scheme_types[AO_SCHEME_NUM_TYPE] = { [AO_SCHEME_CONS] = &ao_scheme_cons_type, [AO_SCHEME_INT] = NULL, - [AO_SCHEME_STRING] = &ao_scheme_string_type, +#ifdef AO_SCHEME_FEATURE_BIGINT + [AO_SCHEME_BIGINT] = &ao_scheme_bigint_type, +#endif [AO_SCHEME_OTHER] = (void *) 0x1, [AO_SCHEME_ATOM] = &ao_scheme_atom_type, [AO_SCHEME_BUILTIN] = &ao_scheme_builtin_type, @@ -497,9 +499,7 @@ static const struct ao_scheme_type * const ao_scheme_types[AO_SCHEME_NUM_TYPE] = [AO_SCHEME_LAMBDA] = &ao_scheme_lambda_type, [AO_SCHEME_STACK] = &ao_scheme_stack_type, [AO_SCHEME_BOOL] = &ao_scheme_bool_type, -#ifdef AO_SCHEME_FEATURE_BIGINT - [AO_SCHEME_BIGINT] = &ao_scheme_bigint_type, -#endif + [AO_SCHEME_STRING] = &ao_scheme_string_type, #ifdef AO_SCHEME_FEATURE_FLOAT [AO_SCHEME_FLOAT] = &ao_scheme_float_type, #endif @@ -533,6 +533,7 @@ uint64_t ao_scheme_loops[2]; #endif int ao_scheme_last_top; +int ao_scheme_collect_counts; int ao_scheme_collect(uint8_t style) @@ -556,6 +557,14 @@ ao_scheme_collect(uint8_t style) if (ao_scheme_last_top == 0) style = AO_SCHEME_COLLECT_FULL; + /* One in a while, just do a full collect */ + + if (ao_scheme_collect_counts >= 128) + style = AO_SCHEME_COLLECT_FULL; + + if (style == AO_SCHEME_COLLECT_FULL) + ao_scheme_collect_counts = 0; + /* Clear references to all caches */ for (i = 0; i < (int) AO_SCHEME_CACHE; i++) *ao_scheme_cache[i] = NULL; @@ -984,16 +993,16 @@ ao_scheme_poly_fetch(int id) } void -ao_scheme_string_stash(int id, char *string) +ao_scheme_string_stash(int id, struct ao_scheme_string *string) { assert(save_string[id] == NULL); save_string[id] = string; } -char * +struct ao_scheme_string * ao_scheme_string_fetch(int id) { - char *string = save_string[id]; + struct ao_scheme_string *string = save_string[id]; save_string[id] = NULL; return string; } diff --git a/src/scheme/ao_scheme_poly.c b/src/scheme/ao_scheme_poly.c index 0bb427b9..2ea221ec 100644 --- a/src/scheme/ao_scheme_poly.c +++ b/src/scheme/ao_scheme_poly.c @@ -24,10 +24,12 @@ static const struct ao_scheme_funcs ao_scheme_funcs[AO_SCHEME_NUM_TYPE] = { .write = ao_scheme_cons_write, .display = ao_scheme_cons_display, }, - [AO_SCHEME_STRING] = { - .write = ao_scheme_string_write, - .display = ao_scheme_string_display, +#ifdef AO_SCHEME_FEATURE_BIGINT + [AO_SCHEME_BIGINT] = { + .write = ao_scheme_bigint_write, + .display = ao_scheme_bigint_write, }, +#endif [AO_SCHEME_INT] = { .write = ao_scheme_int_write, .display = ao_scheme_int_write, @@ -60,12 +62,10 @@ static const struct ao_scheme_funcs ao_scheme_funcs[AO_SCHEME_NUM_TYPE] = { .write = ao_scheme_bool_write, .display = ao_scheme_bool_write, }, -#ifdef AO_SCHEME_FEATURE_BIGINT - [AO_SCHEME_BIGINT] = { - .write = ao_scheme_bigint_write, - .display = ao_scheme_bigint_write, + [AO_SCHEME_STRING] = { + .write = ao_scheme_string_write, + .display = ao_scheme_string_display, }, -#endif #ifdef AO_SCHEME_FEATURE_FLOAT [AO_SCHEME_FLOAT] = { .write = ao_scheme_float_write, diff --git a/src/scheme/ao_scheme_read.c b/src/scheme/ao_scheme_read.c index dce480ab..721211bc 100644 --- a/src/scheme/ao_scheme_read.c +++ b/src/scheme/ao_scheme_read.c @@ -555,7 +555,7 @@ ao_poly ao_scheme_read(void) { struct ao_scheme_atom *atom; - char *string; + struct ao_scheme_string *string; int read_state; ao_poly v = AO_SCHEME_NIL; @@ -605,7 +605,7 @@ ao_scheme_read(void) v = _ao_scheme_bool_false; break; case STRING: - string = ao_scheme_string_copy(token_string); + string = ao_scheme_string_make(token_string); if (string) v = ao_scheme_string_poly(string); else diff --git a/src/scheme/ao_scheme_string.c b/src/scheme/ao_scheme_string.c index ada626c3..e18a8e85 100644 --- a/src/scheme/ao_scheme_string.c +++ b/src/scheme/ao_scheme_string.c @@ -24,9 +24,10 @@ static void string_mark(void *addr) static int string_size(void *addr) { + struct ao_scheme_string *string = addr; if (!addr) return 0; - return strlen(addr) + 1; + return strlen(string->val) + 2; } static void string_move(void *addr) @@ -41,71 +42,114 @@ const struct ao_scheme_type ao_scheme_string_type = { .name = "string", }; -char * -ao_scheme_string_copy(char *a) +static struct ao_scheme_string * +ao_scheme_string_alloc(int len) { - int alen = strlen(a); - char *r; + struct ao_scheme_string *s; + + s = ao_scheme_alloc(len + 2); + if (!s) + return NULL; + s->type = AO_SCHEME_STRING; + return s; +} + +struct ao_scheme_string * +ao_scheme_string_copy(struct ao_scheme_string *a) +{ + int alen = strlen(a->val); + struct ao_scheme_string *r; ao_scheme_string_stash(0, a); - r = ao_scheme_alloc(alen + 1); + r = ao_scheme_string_alloc(alen); a = ao_scheme_string_fetch(0); if (!r) return NULL; - strcpy(r, a); + strcpy(r->val, a->val); + return r; +} + +struct ao_scheme_string * +ao_scheme_string_make(char *a) +{ + struct ao_scheme_string *r; + + r = ao_scheme_string_alloc(strlen(a)); + if (!r) + return NULL; + strcpy(r->val, a); + return r; +} + +struct ao_scheme_string * +ao_scheme_atom_to_string(struct ao_scheme_atom *a) +{ + int alen = strlen(a->name); + struct ao_scheme_string *r; + + ao_scheme_poly_stash(0, ao_scheme_atom_poly(a)); + r = ao_scheme_string_alloc(alen); + a = ao_scheme_poly_atom(ao_scheme_poly_fetch(0)); + if (!r) + return NULL; + strcpy(r->val, a->name); return r; } -char * -ao_scheme_string_cat(char *a, char *b) +struct ao_scheme_string * +ao_scheme_string_cat(struct ao_scheme_string *a, struct ao_scheme_string *b) { - int alen = strlen(a); - int blen = strlen(b); - char *r; + int alen = strlen(a->val); + int blen = strlen(b->val); + struct ao_scheme_string *r; ao_scheme_string_stash(0, a); ao_scheme_string_stash(1, b); - r = ao_scheme_alloc(alen + blen + 1); + r = ao_scheme_string_alloc(alen + blen); a = ao_scheme_string_fetch(0); b = ao_scheme_string_fetch(1); if (!r) return NULL; - strcpy(r, a); - strcpy(r+alen, b); + strcpy(r->val, a->val); + strcpy(r->val+alen, b->val); return r; } ao_poly ao_scheme_string_pack(struct ao_scheme_cons *cons) { - char *r; - char *s; - int len; + struct ao_scheme_string *r; + char *rval; + int len; len = ao_scheme_cons_length(cons); ao_scheme_cons_stash(0, cons); - r = ao_scheme_alloc(len + 1); + r = ao_scheme_string_alloc(len); cons = ao_scheme_cons_fetch(0); - s = r; + if (!r) + return AO_SCHEME_NIL; + rval = r->val; while (cons) { - if (!ao_scheme_integer_typep(ao_scheme_poly_type(cons->car))) + bool fail = false; + ao_poly car = cons->car; + *rval++ = ao_scheme_poly_integer(car, &fail); + if (fail) return ao_scheme_error(AO_SCHEME_INVALID, "non-int passed to pack"); - *s++ = ao_scheme_poly_integer(cons->car); - cons = ao_scheme_poly_cons(cons->cdr); + cons = ao_scheme_cons_cdr(cons); } - *s++ = 0; + *rval++ = 0; return ao_scheme_string_poly(r); } ao_poly -ao_scheme_string_unpack(char *a) +ao_scheme_string_unpack(struct ao_scheme_string *a) { struct ao_scheme_cons *cons = NULL, *tail = NULL; int c; int i; - for (i = 0; (c = a[i]); i++) { + for (i = 0; (c = a->val[i]); i++) { struct ao_scheme_cons *n; ao_scheme_cons_stash(0, cons); ao_scheme_cons_stash(1, tail); @@ -131,11 +175,12 @@ ao_scheme_string_unpack(char *a) void ao_scheme_string_write(ao_poly p) { - char *s = ao_scheme_poly_string(p); - char c; + struct ao_scheme_string *s = ao_scheme_poly_string(p); + char *sval = s->val; + char c; putchar('"'); - while ((c = *s++)) { + while ((c = *sval++)) { switch (c) { case '\n': printf ("\\n"); @@ -160,9 +205,10 @@ ao_scheme_string_write(ao_poly p) void ao_scheme_string_display(ao_poly p) { - char *s = ao_scheme_poly_string(p); - char c; + struct ao_scheme_string *s = ao_scheme_poly_string(p); + char *sval = s->val; + char c; - while ((c = *s++)) + while ((c = *sval++)) putchar(c); } diff --git a/src/scheme/ao_scheme_vector.c b/src/scheme/ao_scheme_vector.c index 0114c5a9..a4127f64 100644 --- a/src/scheme/ao_scheme_vector.c +++ b/src/scheme/ao_scheme_vector.c @@ -107,14 +107,15 @@ ao_scheme_vector_display(ao_poly v) static int32_t ao_scheme_vector_offset(struct ao_scheme_vector *vector, ao_poly i) { - int32_t offset = ao_scheme_poly_integer(i); + bool fail; + int32_t offset = ao_scheme_poly_integer(i, &fail); - if (offset == AO_SCHEME_NOT_INTEGER) + if (fail) ao_scheme_error(AO_SCHEME_INVALID, "vector index %v not integer", i); if (offset < 0 || vector->length <= offset) { ao_scheme_error(AO_SCHEME_INVALID, "vector index %v out of range (max %d)", i, vector->length); - offset = AO_SCHEME_NOT_INTEGER; + offset = -1; } return offset; } @@ -125,7 +126,7 @@ ao_scheme_vector_get(ao_poly v, ao_poly i) struct ao_scheme_vector *vector = ao_scheme_poly_vector(v); int32_t offset = ao_scheme_vector_offset(vector, i); - if (offset == AO_SCHEME_NOT_INTEGER) + if (offset < 0) return AO_SCHEME_NIL; return vector->vals[offset]; } @@ -136,7 +137,7 @@ ao_scheme_vector_set(ao_poly v, ao_poly i, ao_poly p) struct ao_scheme_vector *vector = ao_scheme_poly_vector(v); int32_t offset = ao_scheme_vector_offset(vector, i); - if (offset == AO_SCHEME_NOT_INTEGER) + if (offset < 0) return AO_SCHEME_NIL; return vector->vals[offset] = p; } -- cgit v1.2.3 From a4c9233aa8a2f1b1dca6580d6d6275b48c40f01f Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 14 Dec 2017 23:09:02 -0800 Subject: altos/lambdakey-v1.0: shrink scheme code to fit the ROM scheme has grown a bit; adapt Signed-off-by: Keith Packard --- src/lambdakey-v1.0/ao_lambdakey_const.scheme | 24 ++---------------------- 1 file changed, 2 insertions(+), 22 deletions(-) diff --git a/src/lambdakey-v1.0/ao_lambdakey_const.scheme b/src/lambdakey-v1.0/ao_lambdakey_const.scheme index d0c0e578..50373272 100644 --- a/src/lambdakey-v1.0/ao_lambdakey_const.scheme +++ b/src/lambdakey-v1.0/ao_lambdakey_const.scheme @@ -100,8 +100,6 @@ (define (cdar l) (cdr (car l))) -(define (caddr l) (car (cdr (cdr l)))) - ; (if ) ; (if string a))) -(display "apply\n") -(apply cons '(a b)) - (define map (lambda (a . b) (define (args b) @@ -378,12 +364,6 @@ (map cadr '((a b) (d e) (g h))) -(define for-each (lambda (a . b) - (apply map a b) - #t)) - -(for-each display '("hello" " " "world" "\n")) - (define (newline) (write-char #\newline)) (newline) -- cgit v1.2.3 From b866b3ca249dce61f8ff16c8d28514d1b80386d7 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 14 Dec 2017 23:10:43 -0800 Subject: ao-bringup/test-chaoskey: Make finding most recent device more reliable Use dmesg -t to strip off the timestamp, which avoids having a variable number of fields for awk to look at. Signed-off-by: Keith Packard --- ao-bringup/test-chaoskey | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ao-bringup/test-chaoskey b/ao-bringup/test-chaoskey index f64b1f84..26684875 100755 --- a/ao-bringup/test-chaoskey +++ b/ao-bringup/test-chaoskey @@ -12,8 +12,8 @@ case "$#" in serial="--serial $1" ;; 0) - snum=`sudo dmesg | awk '/usb.*Product:/ { ck = index($0, "ChaosKey"); } - /usb.*SerialNumber:/ { if (ck) print $5; }' | tail -1` + snum=`sudo dmesg -t | awk '/usb.*Product:/ { ck = index($0, "ChaosKey"); } + /usb.*SerialNumber:/ { if (ck) print $4; }' | tail -1` case "$snum" in "") -- cgit v1.2.3 From 9d1131da911f7220ac8b6cb7ba5a0afd3deef657 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 17 Dec 2017 22:19:38 -0800 Subject: altos/scheme: Use AO_SCHEME_IS_CONS in cons memory funcs More efficient than ao_scheme_poly_type as it doesn't care about non-prim types. Signed-off-by: Keith Packard --- src/scheme/ao_scheme.h | 1 + src/scheme/ao_scheme_cons.c | 6 +++--- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index 521ec105..48d0149b 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -150,6 +150,7 @@ ao_scheme_is_const(ao_poly poly) { #define AO_SCHEME_IS_CONST(a) (ao_scheme_const <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_scheme_const + AO_SCHEME_POOL_CONST) #define AO_SCHEME_IS_POOL(a) (ao_scheme_pool <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_scheme_pool + AO_SCHEME_POOL) #define AO_SCHEME_IS_INT(p) (ao_scheme_poly_base_type(p) == AO_SCHEME_INT) +#define AO_SCHEME_IS_CONS(p) (ao_scheme_poly_base_type(p) == AO_SCHEME_CONS) void * ao_scheme_ref(ao_poly poly); diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c index 02512e15..912100a9 100644 --- a/src/scheme/ao_scheme_cons.c +++ b/src/scheme/ao_scheme_cons.c @@ -24,8 +24,8 @@ static void cons_mark(void *addr) ao_scheme_poly_mark(cons->car, 1); if (!cdr) break; - if (ao_scheme_poly_type(cdr) != AO_SCHEME_CONS) { - ao_scheme_poly_mark(cdr, 1); + if (!AO_SCHEME_IS_CONS(cdr)) { + ao_scheme_poly_mark(cdr, 0); break; } cons = ao_scheme_poly_cons(cdr); @@ -58,7 +58,7 @@ static void cons_move(void *addr) cdr = cons->cdr; if (!cdr) break; - if (ao_scheme_poly_base_type(cdr) != AO_SCHEME_CONS) { + if (!AO_SCHEME_IS_CONS(cdr)) { (void) ao_scheme_poly_move(&cons->cdr, 0); break; } -- cgit v1.2.3 From e1a6b3bf458f311d832aea7eec34935d42f8efed Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 17 Dec 2017 22:22:50 -0800 Subject: altos/scheme: Use memory manager mark code to note recursive print This flags any object being printed and checks before recursing to avoid infinite loops. Signed-off-by: Keith Packard --- src/scheme/ao_scheme.h | 15 ++++++++++++ src/scheme/ao_scheme_cons.c | 19 +++++++++------ src/scheme/ao_scheme_frame.c | 1 - src/scheme/ao_scheme_mem.c | 56 +++++++++++++++++++++++++++++++++++++++++++ src/scheme/ao_scheme_vector.c | 28 ++++++++++++---------- 5 files changed, 99 insertions(+), 20 deletions(-) diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index 48d0149b..cc7f8f1d 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -555,6 +555,21 @@ ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref); void * ao_scheme_alloc(int size); +/* Marks an object as being printed, returns 1 if it was already marked */ +int +ao_scheme_print_mark_addr(void *addr); + +int +ao_scheme_print_mark_poly(ao_poly poly); + +/* Notes that printing has started */ +void +ao_scheme_print_start(void); + +/* Notes that printing has ended */ +void +ao_scheme_print_stop(void); + #define AO_SCHEME_COLLECT_FULL 1 #define AO_SCHEME_COLLECT_INCREMENTAL 0 diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c index 912100a9..0b3cbf80 100644 --- a/src/scheme/ao_scheme_cons.c +++ b/src/scheme/ao_scheme_cons.c @@ -181,16 +181,17 @@ ao_scheme_cons_write(ao_poly c) ao_poly cdr; int first = 1; + ao_scheme_print_start(); printf("("); while (cons) { if (!first) printf(" "); - ao_scheme_poly_write(cons->car); - cdr = cons->cdr; - if (cdr == c) { - printf(" ..."); + if (ao_scheme_print_mark_addr(cons)) { + printf("..."); break; } + ao_scheme_poly_write(cons->car); + cdr = cons->cdr; if (ao_scheme_poly_type(cdr) == AO_SCHEME_CONS) { cons = ao_scheme_poly_cons(cdr); first = 0; @@ -201,6 +202,7 @@ ao_scheme_cons_write(ao_poly c) } } printf(")"); + ao_scheme_print_stop(); } void @@ -209,13 +211,15 @@ ao_scheme_cons_display(ao_poly c) struct ao_scheme_cons *cons = ao_scheme_poly_cons(c); ao_poly cdr; + ao_scheme_print_start(); while (cons) { - ao_scheme_poly_display(cons->car); - cdr = cons->cdr; - if (cdr == c) { + if (ao_scheme_print_mark_addr(cons)) { printf("..."); break; } + ao_scheme_poly_display(cons->car); + + cdr = cons->cdr; if (ao_scheme_poly_type(cdr) == AO_SCHEME_CONS) cons = ao_scheme_poly_cons(cdr); else { @@ -223,6 +227,7 @@ ao_scheme_cons_display(ao_poly c) cons = NULL; } } + ao_scheme_print_stop(); } int diff --git a/src/scheme/ao_scheme_frame.c b/src/scheme/ao_scheme_frame.c index 7f521863..3f4c9157 100644 --- a/src/scheme/ao_scheme_frame.c +++ b/src/scheme/ao_scheme_frame.c @@ -41,7 +41,6 @@ frame_vals_mark(void *addr) ao_scheme_poly_atom(v->atom)->name, MDBG_OFFSET(ao_scheme_ref(v->atom)), MDBG_OFFSET(ao_scheme_ref(v->val)), f); - MDBG_DO(ao_scheme_poly_write(v->val)); MDBG_DO(printf("\n")); } } diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c index e7e89b89..c7d6b1f8 100644 --- a/src/scheme/ao_scheme_mem.c +++ b/src/scheme/ao_scheme_mem.c @@ -280,6 +280,10 @@ static const void ** const ao_scheme_cache[] = { #define AO_SCHEME_BUSY_SIZE ((AO_SCHEME_POOL + 31) / 32) +static int ao_scheme_printing, ao_scheme_print_cleared; +#if DBG_MEM +static int ao_scheme_collecting; +#endif static uint8_t ao_scheme_busy[AO_SCHEME_BUSY_SIZE]; static uint8_t ao_scheme_cons_note[AO_SCHEME_BUSY_SIZE]; static uint8_t ao_scheme_cons_last[AO_SCHEME_BUSY_SIZE]; @@ -550,6 +554,7 @@ ao_scheme_collect(uint8_t style) MDBG_MOVE("collect %d\n", ao_scheme_collects[style]); #endif MDBG_DO(ao_scheme_frame_write(ao_scheme_frame_poly(ao_scheme_frame_global))); + MDBG_DO(++ao_scheme_collecting); ao_scheme_reset_stack(); @@ -681,6 +686,7 @@ ao_scheme_collect(uint8_t style) #if DBG_MEM_STACK fprintf(stderr, "max collect stack depth %lu\n", mem_collect_max_depth); #endif + MDBG_DO(--ao_scheme_collecting); return AO_SCHEME_POOL - ao_scheme_top; } @@ -1021,3 +1027,53 @@ ao_scheme_frame_fetch(int id) save_frame[id] = NULL; return frame; } + +int +ao_scheme_print_mark_addr(void *addr) +{ + int offset; + +#if DBG_MEM + if (ao_scheme_collecting) + ao_scheme_abort(); +#endif + + if (!AO_SCHEME_IS_POOL(addr)) + return 1; + + if (!ao_scheme_print_cleared) { + ao_scheme_print_cleared = 1; + memset(ao_scheme_busy, '\0', sizeof (ao_scheme_busy)); + } + offset = pool_offset(addr); + if (busy(ao_scheme_busy, offset)) + return 1; + mark(ao_scheme_busy, offset); + return 0; +} + +int +ao_scheme_print_mark_poly(ao_poly p) +{ + uint8_t type = ao_scheme_poly_base_type(p); + + if (type == AO_SCHEME_INT) + return 1; + return ao_scheme_print_mark_addr(ao_scheme_ref(p)); +} + +/* Notes that printing has started */ +void +ao_scheme_print_start(void) +{ + ao_scheme_printing++; +} + +/* Notes that printing has ended */ +void +ao_scheme_print_stop(void) +{ + ao_scheme_printing--; + if (ao_scheme_printing == 0) + ao_scheme_print_cleared = 0; +} diff --git a/src/scheme/ao_scheme_vector.c b/src/scheme/ao_scheme_vector.c index a4127f64..ff2067e2 100644 --- a/src/scheme/ao_scheme_vector.c +++ b/src/scheme/ao_scheme_vector.c @@ -78,16 +78,19 @@ ao_scheme_vector_write(ao_poly v) struct ao_scheme_vector *vector = ao_scheme_poly_vector(v); unsigned int i; - printf("#("); - for (i = 0; i < vector->length; i++) { - if (i != 0) - printf(" "); - if (vector->vals[i] == v) - printf ("..."); - else + ao_scheme_print_start(); + if (ao_scheme_print_mark_addr(vector)) + printf ("..."); + else { + printf("#("); + for (i = 0; i < vector->length; i++) { + if (i != 0) + printf(" "); ao_scheme_poly_write(vector->vals[i]); + } + printf(")"); } - printf(")"); + ao_scheme_print_stop(); } void @@ -96,10 +99,11 @@ ao_scheme_vector_display(ao_poly v) struct ao_scheme_vector *vector = ao_scheme_poly_vector(v); unsigned int i; - for (i = 0; i < vector->length; i++) { - if (vector->vals[i] == v) - printf("..."); - else + ao_scheme_print_start(); + if (ao_scheme_print_mark_addr(vector)) + printf ("..."); + else { + for (i = 0; i < vector->length; i++) ao_scheme_poly_display(vector->vals[i]); } } -- cgit v1.2.3 From 2def6abebb3d14a29fe0e03bac09b9d74d2d1578 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 18 Dec 2017 02:08:23 -0800 Subject: altos/scheme: abort when we try to print an invalid value This can catch a host of interpreter bugs; best to abandon the program when it happens. Signed-off-by: Keith Packard --- src/scheme/ao_scheme_poly.c | 1 + 1 file changed, 1 insertion(+) diff --git a/src/scheme/ao_scheme_poly.c b/src/scheme/ao_scheme_poly.c index 2ea221ec..70e577a2 100644 --- a/src/scheme/ao_scheme_poly.c +++ b/src/scheme/ao_scheme_poly.c @@ -82,6 +82,7 @@ static const struct ao_scheme_funcs ao_scheme_funcs[AO_SCHEME_NUM_TYPE] = { static void ao_scheme_invalid_write(ao_poly p) { printf("??? 0x%04x ???", p); + ao_scheme_abort(); } static const struct ao_scheme_funcs ao_scheme_invalid_funcs = { -- cgit v1.2.3 From 9f1849e548e35498f88a0b8adbbc4a57c7a39222 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 18 Dec 2017 02:11:07 -0800 Subject: altos/scheme: rearrange debugging defines Allow applications to redefine these as desired, add more flexibility in what the various memory debugging flags can do. Signed-off-by: Keith Packard --- src/scheme/ao_scheme.h | 45 ++++++++++++++++++++++++++++++++------- src/scheme/ao_scheme_mem.c | 52 ++++++++++++++++++++++++++-------------------- 2 files changed, 67 insertions(+), 30 deletions(-) diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index cc7f8f1d..0881721b 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -15,10 +15,18 @@ #ifndef _AO_SCHEME_H_ #define _AO_SCHEME_H_ +#ifndef DBG_MEM #define DBG_MEM 0 +#endif +#ifndef DBG_EVAL #define DBG_EVAL 0 +#endif +#ifndef DBG_READ #define DBG_READ 0 +#endif +#ifndef DBG_FREE_CONS #define DBG_FREE_CONS 0 +#endif #define NDEBUG 1 #include @@ -954,9 +962,11 @@ ao_scheme_error(int error, const char *format, ...); /* debugging macros */ -#if DBG_EVAL || DBG_READ || DBG_MEM -#define DBG_CODE 1 +#if DBG_EVAL || DBG_READ int ao_scheme_stack_depth; +#endif + +#if DBG_EVAL #define DBG_DO(a) a #define DBG_INDENT() do { int _s; for(_s = 0; _s < ao_scheme_stack_depth; _s++) printf(" "); } while(0) #define DBG_IN() (++ao_scheme_stack_depth) @@ -993,27 +1003,46 @@ ao_scheme_frames_dump(void) #endif #if DBG_READ -#define RDBGI(...) DBGI(__VA_ARGS__) -#define RDBG_IN() DBG_IN() -#define RDBG_OUT() DBG_OUT() +#define RDBGI(...) do { printf("%4d: ", __LINE__); DBG_INDENT(); ao_scheme_printf(__VA_ARGS__); } while (0) +#define RDBG_IN() (++ao_scheme_stack_depth) +#define RDBG_OUT() (--ao_scheme_stack_depth) #else #define RDBGI(...) #define RDBG_IN() #define RDBG_OUT() #endif -#define DBG_MEM_START 1 +static inline int +ao_scheme_mdbg_offset(void *a) +{ + uint8_t *u = a; + + if (u == 0) + return -1; + + if (ao_scheme_pool <= u && u < ao_scheme_pool + AO_SCHEME_POOL) + return u - ao_scheme_pool; + +#ifndef AO_SCHEME_MAKE_CONST + if (ao_scheme_const <= u && u < ao_scheme_const + AO_SCHEME_POOL_CONST) + return - (int) (u - ao_scheme_const); +#endif + return -2; +} + +#define MDBG_OFFSET(a) ao_scheme_mdbg_offset(a) #if DBG_MEM +#define DBG_MEM_START 1 + #include extern int dbg_move_depth; #define MDBG_DUMP 1 -#define MDBG_OFFSET(a) ((a) ? (int) ((uint8_t *) (a) - ao_scheme_pool) : -1) extern int dbg_mem; -#define MDBG_DO(a) DBG_DO(a) +#define MDBG_DO(a) a #define MDBG_MOVE(...) do { if (dbg_mem) { int d; for (d = 0; d < dbg_move_depth; d++) printf (" "); printf(__VA_ARGS__); } } while (0) #define MDBG_MORE(...) do { if (dbg_mem) printf(__VA_ARGS__); } while (0) #define MDBG_MOVE_IN() (dbg_move_depth++) diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c index c7d6b1f8..3659d3ec 100644 --- a/src/scheme/ao_scheme_mem.c +++ b/src/scheme/ao_scheme_mem.c @@ -71,11 +71,17 @@ _ao_scheme_reset_stack(char *x) #define ao_scheme_reset_stack() #endif +#if DBG_MEM +#define DBG_MEM_RECORD 1 +#endif + #if DBG_MEM int dbg_move_depth; int dbg_mem = DBG_MEM_START; int dbg_validate = 0; +#endif +#if DBG_MEM_RECORD struct ao_scheme_record { struct ao_scheme_record *next; const struct ao_scheme_type *type; @@ -129,9 +135,9 @@ ao_scheme_record_save(void) } static void -ao_scheme_record_compare(char *where, - struct ao_scheme_record *a, - struct ao_scheme_record *b) +ao_scheme_record_compare(const char *where, + struct ao_scheme_record *a, + struct ao_scheme_record *b) { while (a && b) { if (a->type != b->type || a->size != b->size) { @@ -168,6 +174,7 @@ ao_scheme_record_compare(char *where, #else #define ao_scheme_record_reset() +#define ao_scheme_record(t,a,s) #endif uint8_t ao_scheme_exception; @@ -390,6 +397,9 @@ note_chunk(uint16_t offset, uint16_t size) /* Off the left side */ if (l == 0 && chunk_last && offset > ao_scheme_chunk[0].old_offset) ao_scheme_abort(); + + if (l < chunk_last && ao_scheme_chunk[l].old_offset == offset) + ao_scheme_abort(); #endif /* Shuffle existing entries right */ @@ -469,20 +479,19 @@ static void dump_busy(void) { int i; - MDBG_MOVE("busy:"); + printf("busy:"); for (i = 0; i < ao_scheme_top; i += 4) { if ((i & 0xff) == 0) { - MDBG_MORE("\n"); - MDBG_MOVE("%s", ""); + printf("\n\t"); } else if ((i & 0x1f) == 0) - MDBG_MORE(" "); + printf(" "); if (busy(ao_scheme_busy, i)) - MDBG_MORE("*"); + printf("*"); else - MDBG_MORE("-"); + printf("-"); } - MDBG_MORE ("\n"); + printf ("\n"); } #define DUMP_BUSY() dump_busy() #else @@ -548,11 +557,11 @@ ao_scheme_collect(uint8_t style) #if DBG_MEM_STATS int loops = 0; #endif -#if DBG_MEM +#if DBG_MEM_RECORD struct ao_scheme_record *mark_record = NULL, *move_record = NULL; - - MDBG_MOVE("collect %d\n", ao_scheme_collects[style]); #endif + MDBG_MOVE("collect %lu\n", ao_scheme_collects[style]); + MDBG_DO(ao_scheme_frame_write(ao_scheme_frame_poly(ao_scheme_frame_global))); MDBG_DO(++ao_scheme_collecting); @@ -579,15 +588,12 @@ ao_scheme_collect(uint8_t style) chunk_low = top = ao_scheme_last_top; } for (;;) { -#if DBG_MEM_STATS - loops++; -#endif MDBG_MOVE("move chunks from %d to %d\n", chunk_low, top); /* Find the sizes of the first chunk of objects to move */ reset_chunks(); walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); -#if DBG_MEM +#if DBG_MEM_RECORD ao_scheme_record_free(mark_record); mark_record = ao_scheme_record_save(); if (mark_record && move_record) @@ -599,7 +605,6 @@ ao_scheme_collect(uint8_t style) /* Find the first moving object */ for (i = 0; i < chunk_last; i++) { uint16_t size = ao_scheme_chunk[i].size; - #if DBG_MEM if (!size) ao_scheme_abort(); @@ -651,7 +656,7 @@ ao_scheme_collect(uint8_t style) /* Relocate all references to the objects */ walk(ao_scheme_move, ao_scheme_poly_move); -#if DBG_MEM +#if DBG_MEM_RECORD ao_scheme_record_free(move_record); move_record = ao_scheme_record_save(); if (mark_record && move_record) @@ -659,6 +664,9 @@ ao_scheme_collect(uint8_t style) #endif } +#if DBG_MEM_STATS + loops++; +#endif /* If we ran into the end of the heap, then * there's no need to keep walking */ @@ -861,7 +869,7 @@ ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref) return 1; } mark(ao_scheme_busy, offset); - MDBG_DO(ao_scheme_record(type, addr, ao_scheme_size(type, addr))); + ao_scheme_record(type, addr, ao_scheme_size(type, addr)); return 0; } @@ -928,14 +936,14 @@ ao_scheme_poly_move(ao_poly *ref, uint8_t do_note_cons) if (offset != orig_offset) { ao_poly np = ao_scheme_poly(ao_scheme_pool + offset, ao_scheme_poly_base_type(p)); MDBG_MOVE("poly %d moved %d -> %d\n", - type, orig_offset, offset); + ao_scheme_poly_type(np), orig_offset, offset); *ref = np; } return ret; } #if DBG_MEM -void +static void ao_scheme_validate(void) { chunk_low = 0; -- cgit v1.2.3 From 6593570418e087b9f83ed7f90303d4e1e7d20e83 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 18 Dec 2017 02:12:04 -0800 Subject: altos/scheme: Work around gcc 7.2.0 optimization bug in memory manager After marking a set of memory chunks, it's possible that all of them will be packed tight against 'top', in which case none of them will be moving. In that case, gcc 7.2.0 appears to generate incorrect code causing the loop to be abandoned, meaning that we don't actually collect anything at all. Add a quick short-circuit test just after the mark phase that skips the code which wouldn't do anything in this case. Signed-off-by: Keith Packard --- src/scheme/ao_scheme_mem.c | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c index 3659d3ec..94275451 100644 --- a/src/scheme/ao_scheme_mem.c +++ b/src/scheme/ao_scheme_mem.c @@ -623,6 +623,20 @@ ao_scheme_collect(uint8_t style) top += size; } + /* Short-circuit the rest of the loop when all of the + * found objects aren't moving. This isn't strictly + * necessary as the rest of the loop is structured to + * work in this case, but GCC 7.2.0 with optimization + * greater than 2 generates incorrect code for this... + */ + if (i == AO_SCHEME_NCHUNK) { + chunk_low = chunk_high; +#if DBG_MEM_STATS + loops++; +#endif + continue; + } + /* * Limit amount of chunk array used in mapping moves * to the active region -- cgit v1.2.3 From 5628b983497d9d03e10cccee157419210a49cfa9 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 18 Dec 2017 02:14:57 -0800 Subject: altos/scheme: Compile scheme test with -O3 This level of optimization caused trouble, so use it all of the time. Signed-off-by: Keith Packard --- src/scheme/test/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/scheme/test/Makefile b/src/scheme/test/Makefile index d51fa7ba..898c75f3 100644 --- a/src/scheme/test/Makefile +++ b/src/scheme/test/Makefile @@ -9,7 +9,7 @@ HDRS=$(SCHEME_HDRS) ao_scheme_const.h OBJS=$(SRCS:.c=.o) -CFLAGS=-O2 -g -Wall -Wextra -I. -I.. -Wpointer-arith -Wmissing-declarations -Wformat=2 -Wstrict-prototypes -Wmissing-prototypes -Wnested-externs -Wbad-function-cast -Wold-style-definition -Wdeclaration-after-statement -Wunused -Wuninitialized -Wshadow -Wmissing-noreturn -Wmissing-format-attribute -Wredundant-decls -Wlogical-op -Werror=implicit -Werror=nonnull -Werror=init-self -Werror=main -Werror=missing-braces -Werror=sequence-point -Werror=return-type -Werror=trigraphs -Werror=array-bounds -Werror=write-strings -Werror=address -Werror=int-to-pointer-cast -Werror=pointer-to-int-cast +CFLAGS=-O3 -g -Wall -Wextra -I. -I.. -Wpointer-arith -Wmissing-declarations -Wformat=2 -Wstrict-prototypes -Wmissing-prototypes -Wnested-externs -Wbad-function-cast -Wold-style-definition -Wdeclaration-after-statement -Wunused -Wuninitialized -Wshadow -Wmissing-noreturn -Wmissing-format-attribute -Wredundant-decls -Wlogical-op -Werror=implicit -Werror=nonnull -Werror=init-self -Werror=main -Werror=missing-braces -Werror=sequence-point -Werror=return-type -Werror=trigraphs -Werror=array-bounds -Werror=write-strings -Werror=address -Werror=int-to-pointer-cast -Werror=pointer-to-int-cast ao-scheme: $(OBJS) cc $(CFLAGS) -o $@ $(OBJS) -lm -- cgit v1.2.3 From 431165e5fa72ba6dffd477de32960745cdec332c Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 19 Dec 2017 11:33:36 -0800 Subject: altos/scheme: Rework display/write code MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Unify output functions and add bool to switch between write and display mode. Make that only affect strings (as per r⁷rs). Use print recursion detection in frame and stack code, eliminating PRINT flags in type field. Signed-off-by: Keith Packard --- src/scheme/ao_scheme.h | 65 +++++++++--------------- src/scheme/ao_scheme_atom.c | 3 +- src/scheme/ao_scheme_bool.c | 3 +- src/scheme/ao_scheme_builtin.c | 11 ++-- src/scheme/ao_scheme_cons.c | 62 +++++++++++------------ src/scheme/ao_scheme_error.c | 74 ++------------------------- src/scheme/ao_scheme_float.c | 3 +- src/scheme/ao_scheme_frame.c | 55 +++++++++++++------- src/scheme/ao_scheme_int.c | 6 ++- src/scheme/ao_scheme_lambda.c | 4 +- src/scheme/ao_scheme_make_const.c | 6 +-- src/scheme/ao_scheme_mem.c | 33 ++++++++---- src/scheme/ao_scheme_poly.c | 103 ++++++++------------------------------ src/scheme/ao_scheme_rep.c | 2 +- src/scheme/ao_scheme_stack.c | 31 ++++++++---- src/scheme/ao_scheme_string.c | 56 +++++++++------------ src/scheme/ao_scheme_vector.c | 28 +++-------- 17 files changed, 213 insertions(+), 332 deletions(-) diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index 0881721b..b37e9098 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -249,7 +249,6 @@ struct ao_scheme_bigint { /* Set on type when the frame escapes the lambda */ #define AO_SCHEME_FRAME_MARK 0x80 -#define AO_SCHEME_FRAME_PRINT 0x40 static inline int ao_scheme_frame_marked(struct ao_scheme_frame *f) { return f->type & AO_SCHEME_FRAME_MARK; @@ -301,7 +300,6 @@ struct ao_scheme_stack { }; #define AO_SCHEME_STACK_MARK 0x80 /* set on type when a reference has been taken */ -#define AO_SCHEME_STACK_PRINT 0x40 /* stack is being printed */ static inline int ao_scheme_stack_marked(struct ao_scheme_stack *s) { return s->type & AO_SCHEME_STACK_MARK; @@ -567,15 +565,15 @@ ao_scheme_alloc(int size); int ao_scheme_print_mark_addr(void *addr); -int -ao_scheme_print_mark_poly(ao_poly poly); +void +ao_scheme_print_clear_addr(void *addr); /* Notes that printing has started */ void ao_scheme_print_start(void); -/* Notes that printing has ended */ -void +/* Notes that printing has ended, returns 1 if printing is still happening */ +int ao_scheme_print_stop(void); #define AO_SCHEME_COLLECT_FULL 1 @@ -628,7 +626,7 @@ ao_scheme_frame_fetch(int id); extern const struct ao_scheme_type ao_scheme_bool_type; void -ao_scheme_bool_write(ao_poly v); +ao_scheme_bool_write(ao_poly v, bool write); #ifdef AO_SCHEME_MAKE_CONST extern struct ao_scheme_bool *ao_scheme_true, *ao_scheme_false; @@ -656,10 +654,7 @@ void ao_scheme_cons_free(struct ao_scheme_cons *cons); void -ao_scheme_cons_write(ao_poly); - -void -ao_scheme_cons_display(ao_poly); +ao_scheme_cons_write(ao_poly, bool write); int ao_scheme_cons_length(struct ao_scheme_cons *cons); @@ -689,10 +684,7 @@ ao_poly ao_scheme_string_unpack(struct ao_scheme_string *a); void -ao_scheme_string_write(ao_poly s); - -void -ao_scheme_string_display(ao_poly s); +ao_scheme_string_write(ao_poly s, bool write); /* atom */ extern const struct ao_scheme_type ao_scheme_atom_type; @@ -702,7 +694,7 @@ extern struct ao_scheme_frame *ao_scheme_frame_global; extern struct ao_scheme_frame *ao_scheme_frame_current; void -ao_scheme_atom_write(ao_poly a); +ao_scheme_atom_write(ao_poly a, bool write); struct ao_scheme_atom * ao_scheme_string_to_atom(struct ao_scheme_string *string); @@ -724,7 +716,7 @@ ao_scheme_atom_def(ao_poly atom, ao_poly val); /* int */ void -ao_scheme_int_write(ao_poly i); +ao_scheme_int_write(ao_poly i, bool write); #ifdef AO_SCHEME_FEATURE_BIGINT int32_t @@ -740,7 +732,7 @@ ao_scheme_integer_typep(uint8_t t) } void -ao_scheme_bigint_write(ao_poly i); +ao_scheme_bigint_write(ao_poly i, bool write); extern const struct ao_scheme_type ao_scheme_bigint_type; @@ -760,10 +752,7 @@ ao_scheme_integer_typep(uint8_t t) /* vector */ void -ao_scheme_vector_write(ao_poly v); - -void -ao_scheme_vector_display(ao_poly v); +ao_scheme_vector_write(ao_poly v, bool write); struct ao_scheme_vector * ao_scheme_vector_alloc(uint16_t length, ao_poly fill); @@ -783,14 +772,10 @@ ao_scheme_vector_to_list(struct ao_scheme_vector *vector); extern const struct ao_scheme_type ao_scheme_vector_type; /* prim */ -void (*ao_scheme_poly_write_func(ao_poly p))(ao_poly p); -void (*ao_scheme_poly_display_func(ao_poly p))(ao_poly p); - -static inline void -ao_scheme_poly_write(ao_poly p) { (*ao_scheme_poly_write_func(p))(p); } +void (*ao_scheme_poly_write_func(ao_poly p))(ao_poly p, bool write); static inline void -ao_scheme_poly_display(ao_poly p) { (*ao_scheme_poly_display_func(p))(p); } +ao_scheme_poly_write(ao_poly p, bool write) { (*ao_scheme_poly_write_func(p))(p, write); } int ao_scheme_poly_mark(ao_poly p, uint8_t note_cons); @@ -818,7 +803,7 @@ ao_scheme_set_cond(struct ao_scheme_cons *cons); extern const struct ao_scheme_type ao_scheme_float_type; void -ao_scheme_float_write(ao_poly p); +ao_scheme_float_write(ao_poly p, bool write); ao_poly ao_scheme_float_get(float value); @@ -836,7 +821,7 @@ ao_scheme_number_typep(uint8_t t) /* builtin */ void -ao_scheme_builtin_write(ao_poly b); +ao_scheme_builtin_write(ao_poly b, bool write); extern const struct ao_scheme_type ao_scheme_builtin_type; @@ -895,7 +880,7 @@ ao_poly ao_scheme_frame_add(struct ao_scheme_frame *frame, ao_poly atom, ao_poly val); void -ao_scheme_frame_write(ao_poly p); +ao_scheme_frame_write(ao_poly p, bool write); void ao_scheme_frame_init(void); @@ -909,7 +894,7 @@ struct ao_scheme_lambda * ao_scheme_lambda_new(ao_poly cons); void -ao_scheme_lambda_write(ao_poly lambda); +ao_scheme_lambda_write(ao_poly lambda, bool write); ao_poly ao_scheme_lambda_eval(void); @@ -920,6 +905,8 @@ extern const struct ao_scheme_type ao_scheme_stack_type; extern struct ao_scheme_stack *ao_scheme_stack; extern struct ao_scheme_stack *ao_scheme_stack_free_list; +extern int ao_scheme_frame_print_indent; + void ao_scheme_stack_reset(struct ao_scheme_stack *stack); @@ -933,7 +920,7 @@ void ao_scheme_stack_clear(void); void -ao_scheme_stack_write(ao_poly stack); +ao_scheme_stack_write(ao_poly stack, bool write); ao_poly ao_scheme_stack_eval(void); @@ -946,12 +933,6 @@ ao_scheme_vprintf(const char *format, va_list args); void ao_scheme_printf(const char *format, ...); -void -ao_scheme_error_poly(const char *name, ao_poly poly, ao_poly last); - -void -ao_scheme_error_frame(int indent, const char *name, struct ao_scheme_frame *frame); - ao_poly ao_scheme_error(int error, const char *format, ...); @@ -974,10 +955,10 @@ int ao_scheme_stack_depth; #define DBG_RESET() (ao_scheme_stack_depth = 0) #define DBG(...) ao_scheme_printf(__VA_ARGS__) #define DBGI(...) do { printf("%4d: ", __LINE__); DBG_INDENT(); DBG(__VA_ARGS__); } while (0) -#define DBG_CONS(a) ao_scheme_cons_write(ao_scheme_cons_poly(a)) -#define DBG_POLY(a) ao_scheme_poly_write(a) +#define DBG_CONS(a) ao_scheme_cons_write(ao_scheme_cons_poly(a), true) +#define DBG_POLY(a) ao_scheme_poly_write(a, true) #define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_scheme_pool) : -1) -#define DBG_STACK() ao_scheme_stack_write(ao_scheme_stack_poly(ao_scheme_stack)) +#define DBG_STACK() ao_scheme_stack_write(ao_scheme_stack_poly(ao_scheme_stack), true) static inline void ao_scheme_frames_dump(void) { diff --git a/src/scheme/ao_scheme_atom.c b/src/scheme/ao_scheme_atom.c index 745c32fe..8989cefd 100644 --- a/src/scheme/ao_scheme_atom.c +++ b/src/scheme/ao_scheme_atom.c @@ -188,8 +188,9 @@ ao_scheme_atom_def(ao_poly atom, ao_poly val) } void -ao_scheme_atom_write(ao_poly a) +ao_scheme_atom_write(ao_poly a, bool write) { struct ao_scheme_atom *atom = ao_scheme_poly_atom(a); + (void) write; printf("%s", atom->name); } diff --git a/src/scheme/ao_scheme_bool.c b/src/scheme/ao_scheme_bool.c index c1e880ca..88970667 100644 --- a/src/scheme/ao_scheme_bool.c +++ b/src/scheme/ao_scheme_bool.c @@ -38,10 +38,11 @@ const struct ao_scheme_type ao_scheme_bool_type = { }; void -ao_scheme_bool_write(ao_poly v) +ao_scheme_bool_write(ao_poly v, bool write) { struct ao_scheme_bool *b = ao_scheme_poly_bool(v); + (void) write; if (b->value) printf("#t"); else diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index 9a823f6a..221570c7 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -84,9 +84,10 @@ ao_scheme_args_name(uint8_t args) #endif void -ao_scheme_builtin_write(ao_poly b) +ao_scheme_builtin_write(ao_poly b, bool write) { struct ao_scheme_builtin *builtin = ao_scheme_poly_builtin(b); + (void) write; printf("%s", ao_scheme_builtin_name(builtin->func)); } @@ -287,7 +288,7 @@ ao_scheme_do_write(struct ao_scheme_cons *cons) ao_poly val = AO_SCHEME_NIL; while (cons) { val = cons->car; - ao_scheme_poly_write(val); + ao_scheme_poly_write(val, true); cons = ao_scheme_cons_cdr(cons); if (cons) printf(" "); @@ -301,7 +302,7 @@ ao_scheme_do_display(struct ao_scheme_cons *cons) ao_poly val = AO_SCHEME_NIL; while (cons) { val = cons->car; - ao_scheme_poly_display(val); + ao_scheme_poly_write(val, false); cons = ao_scheme_cons_cdr(cons); } return _ao_scheme_bool_true; @@ -855,7 +856,7 @@ ao_scheme_do_pairp(struct ao_scheme_cons *cons) if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) return AO_SCHEME_NIL; v = ao_scheme_arg(cons, 0); - if (v != AO_SCHEME_NIL && ao_scheme_poly_type(v) == AO_SCHEME_CONS) + if (v != AO_SCHEME_NIL && AO_SCHEME_IS_CONS(v)) return _ao_scheme_bool_true; return _ao_scheme_bool_false; } @@ -946,7 +947,7 @@ ao_scheme_do_listp(struct ao_scheme_cons *cons) for (;;) { if (v == AO_SCHEME_NIL) return _ao_scheme_bool_true; - if (ao_scheme_poly_type(v) != AO_SCHEME_CONS) + if (!AO_SCHEME_IS_CONS(v)) return _ao_scheme_bool_false; v = ao_scheme_poly_cons(v)->cdr; } diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c index 0b3cbf80..7976250b 100644 --- a/src/scheme/ao_scheme_cons.c +++ b/src/scheme/ao_scheme_cons.c @@ -111,7 +111,7 @@ ao_scheme_cons_cdr(struct ao_scheme_cons *cons) ao_poly cdr = cons->cdr; if (cdr == AO_SCHEME_NIL) return NULL; - if (ao_scheme_poly_type(cdr) != AO_SCHEME_CONS) { + if (!AO_SCHEME_IS_CONS(cdr)) { (void) ao_scheme_error(AO_SCHEME_INVALID, "improper cdr %v", cdr); return NULL; } @@ -151,7 +151,7 @@ ao_scheme_cons_copy(struct ao_scheme_cons *cons) tail->cdr = ao_scheme_cons_poly(new); tail = new; cdr = cons->cdr; - if (ao_scheme_poly_type(cdr) != AO_SCHEME_CONS) { + if (!AO_SCHEME_IS_CONS(cdr)) { tail->cdr = cdr; break; } @@ -175,59 +175,53 @@ ao_scheme_cons_free(struct ao_scheme_cons *cons) } void -ao_scheme_cons_write(ao_poly c) +ao_scheme_cons_write(ao_poly c, bool write) { struct ao_scheme_cons *cons = ao_scheme_poly_cons(c); + struct ao_scheme_cons *clear = cons; ao_poly cdr; - int first = 1; + int written = 0; ao_scheme_print_start(); printf("("); while (cons) { - if (!first) + if (written != 0) printf(" "); + + /* Note if there's recursion in printing. Not + * as good as actual references, but at least + * we don't infinite loop... + */ if (ao_scheme_print_mark_addr(cons)) { printf("..."); break; } - ao_scheme_poly_write(cons->car); + + ao_scheme_poly_write(cons->car, write); + + /* keep track of how many pairs have been printed */ + written++; + cdr = cons->cdr; - if (ao_scheme_poly_type(cdr) == AO_SCHEME_CONS) { - cons = ao_scheme_poly_cons(cdr); - first = 0; - } else { + if (!AO_SCHEME_IS_CONS(cdr)) { printf(" . "); - ao_scheme_poly_write(cdr); - cons = NULL; + ao_scheme_poly_write(cdr, write); + break; } + cons = ao_scheme_poly_cons(cdr); } printf(")"); - ao_scheme_print_stop(); -} -void -ao_scheme_cons_display(ao_poly c) -{ - struct ao_scheme_cons *cons = ao_scheme_poly_cons(c); - ao_poly cdr; - - ao_scheme_print_start(); - while (cons) { - if (ao_scheme_print_mark_addr(cons)) { - printf("..."); - break; - } - ao_scheme_poly_display(cons->car); + if (ao_scheme_print_stop()) { - cdr = cons->cdr; - if (ao_scheme_poly_type(cdr) == AO_SCHEME_CONS) - cons = ao_scheme_poly_cons(cdr); - else { - ao_scheme_poly_display(cdr); - cons = NULL; + /* If we're still printing, clear the print marks on + * all printed pairs + */ + while (written--) { + ao_scheme_print_clear_addr(clear); + clear = ao_scheme_poly_cons(clear->cdr); } } - ao_scheme_print_stop(); } int diff --git a/src/scheme/ao_scheme_error.c b/src/scheme/ao_scheme_error.c index c015c76a..6a71ca51 100644 --- a/src/scheme/ao_scheme_error.c +++ b/src/scheme/ao_scheme_error.c @@ -15,73 +15,6 @@ #include "ao_scheme.h" #include -void -ao_scheme_error_poly(const char *name, ao_poly poly, ao_poly last) -{ - int first = 1; - printf("\t\t%s(", name); - if (ao_scheme_poly_type(poly) == AO_SCHEME_CONS) { - if (poly) { - while (poly) { - struct ao_scheme_cons *cons = ao_scheme_poly_cons(poly); - if (!first) - printf("\t\t "); - else - first = 0; - ao_scheme_poly_write(cons->car); - printf("\n"); - if (poly == last) - break; - poly = cons->cdr; - } - printf("\t\t )\n"); - } else - printf(")\n"); - } else { - ao_scheme_poly_write(poly); - printf("\n"); - } -} - -static void tabs(int indent) -{ - while (indent--) - printf("\t"); -} - -void -ao_scheme_error_frame(int indent, const char *name, struct ao_scheme_frame *frame) -{ - int f; - - tabs(indent); - printf ("%s{", name); - if (frame) { - struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); - if (frame->type & AO_SCHEME_FRAME_PRINT) - printf("recurse..."); - else { - frame->type |= AO_SCHEME_FRAME_PRINT; - for (f = 0; f < frame->num; f++) { - if (f != 0) { - tabs(indent); - printf(" "); - } - ao_scheme_poly_write(vals->vals[f].atom); - printf(" = "); - ao_scheme_poly_write(vals->vals[f].val); - printf("\n"); - } - if (frame->prev) - ao_scheme_error_frame(indent + 1, "prev: ", ao_scheme_poly_frame(frame->prev)); - frame->type &= ~AO_SCHEME_FRAME_PRINT; - } - tabs(indent); - printf(" }\n"); - } else - printf ("}\n"); -} - void ao_scheme_vprintf(const char *format, va_list args) { @@ -91,7 +24,10 @@ ao_scheme_vprintf(const char *format, va_list args) if (c == '%') { switch (c = *format++) { case 'v': - ao_scheme_poly_write((ao_poly) va_arg(args, unsigned int)); + ao_scheme_poly_write((ao_poly) va_arg(args, unsigned int), true); + break; + case 'V': + ao_scheme_poly_write((ao_poly) va_arg(args, unsigned int), false); break; case 'p': printf("%p", va_arg(args, void *)); @@ -133,7 +69,7 @@ ao_scheme_error(int error, const char *format, ...) ao_scheme_printf("Value: %v\n", ao_scheme_v); ao_scheme_printf("Frame: %v\n", ao_scheme_frame_poly(ao_scheme_frame_current)); printf("Stack:\n"); - ao_scheme_stack_write(ao_scheme_stack_poly(ao_scheme_stack)); + ao_scheme_stack_write(ao_scheme_stack_poly(ao_scheme_stack), true); ao_scheme_printf("Globals: %v\n", ao_scheme_frame_poly(ao_scheme_frame_global)); return AO_SCHEME_NIL; } diff --git a/src/scheme/ao_scheme_float.c b/src/scheme/ao_scheme_float.c index b75289d7..d8501548 100644 --- a/src/scheme/ao_scheme_float.c +++ b/src/scheme/ao_scheme_float.c @@ -46,11 +46,12 @@ const struct ao_scheme_type ao_scheme_float_type = { #endif void -ao_scheme_float_write(ao_poly p) +ao_scheme_float_write(ao_poly p, bool write) { struct ao_scheme_float *f = ao_scheme_poly_float(p); float v = f->value; + (void) write; if (isnanf(v)) printf("+nan.0"); else if (isinff(v)) { diff --git a/src/scheme/ao_scheme_frame.c b/src/scheme/ao_scheme_frame.c index 3f4c9157..46f941e6 100644 --- a/src/scheme/ao_scheme_frame.c +++ b/src/scheme/ao_scheme_frame.c @@ -142,32 +142,53 @@ const struct ao_scheme_type ao_scheme_frame_type = { .name = "frame", }; +int ao_scheme_frame_print_indent; + +static void +ao_scheme_frame_indent(int extra) +{ + int i; + putchar('\n'); + for (i = 0; i < ao_scheme_frame_print_indent+extra; i++) + putchar('\t'); +} + void -ao_scheme_frame_write(ao_poly p) +ao_scheme_frame_write(ao_poly p, bool write) { struct ao_scheme_frame *frame = ao_scheme_poly_frame(p); + struct ao_scheme_frame *clear = frame; struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); int f; + int written = 0; - printf ("{"); - if (frame) { - if (frame->type & AO_SCHEME_FRAME_PRINT) + ao_scheme_print_start(); + while (frame) { + if (written != 0) + printf(", "); + if (ao_scheme_print_mark_addr(frame)) { printf("recurse..."); - else { - frame->type |= AO_SCHEME_FRAME_PRINT; - for (f = 0; f < frame->num; f++) { - if (f != 0) - printf(", "); - ao_scheme_poly_write(vals->vals[f].atom); - printf(" = "); - ao_scheme_poly_write(vals->vals[f].val); - } - if (frame->prev) - ao_scheme_poly_write(frame->prev); - frame->type &= ~AO_SCHEME_FRAME_PRINT; + break; + } + + putchar('{'); + written++; + for (f = 0; f < frame->num; f++) { + ao_scheme_frame_indent(1); + ao_scheme_poly_write(vals->vals[f].atom, write); + printf(" = "); + ao_scheme_poly_write(vals->vals[f].val, write); + } + frame = ao_scheme_poly_frame(frame->prev); + ao_scheme_frame_indent(0); + putchar('}'); + } + if (ao_scheme_print_stop()) { + while (written--) { + ao_scheme_print_clear_addr(clear); + clear = ao_scheme_poly_frame(clear->prev); } } - printf("}"); } static int diff --git a/src/scheme/ao_scheme_int.c b/src/scheme/ao_scheme_int.c index 4fcf4931..01b571c0 100644 --- a/src/scheme/ao_scheme_int.c +++ b/src/scheme/ao_scheme_int.c @@ -15,9 +15,10 @@ #include "ao_scheme.h" void -ao_scheme_int_write(ao_poly p) +ao_scheme_int_write(ao_poly p, bool write) { int i = ao_scheme_poly_int(p); + (void) write; printf("%d", i); } @@ -76,10 +77,11 @@ const struct ao_scheme_type ao_scheme_bigint_type = { }; void -ao_scheme_bigint_write(ao_poly p) +ao_scheme_bigint_write(ao_poly p, bool write) { struct ao_scheme_bigint *bi = ao_scheme_poly_bigint(p); + (void) write; printf("%d", bi->value); } #endif /* AO_SCHEME_FEATURE_BIGINT */ diff --git a/src/scheme/ao_scheme_lambda.c b/src/scheme/ao_scheme_lambda.c index be87f4d1..e8ce0710 100644 --- a/src/scheme/ao_scheme_lambda.c +++ b/src/scheme/ao_scheme_lambda.c @@ -50,7 +50,7 @@ const struct ao_scheme_type ao_scheme_lambda_type = { }; void -ao_scheme_lambda_write(ao_poly poly) +ao_scheme_lambda_write(ao_poly poly, bool write) { struct ao_scheme_lambda *lambda = ao_scheme_poly_lambda(poly); struct ao_scheme_cons *cons = ao_scheme_poly_cons(lambda->code); @@ -59,7 +59,7 @@ ao_scheme_lambda_write(ao_poly poly) printf("%s", ao_scheme_args_name(lambda->args)); while (cons) { printf(" "); - ao_scheme_poly_write(cons->car); + ao_scheme_poly_write(cons->car, write); cons = ao_scheme_poly_cons(cons->cdr); } printf(")"); diff --git a/src/scheme/ao_scheme_make_const.c b/src/scheme/ao_scheme_make_const.c index 51bb1269..79ba1bf1 100644 --- a/src/scheme/ao_scheme_make_const.c +++ b/src/scheme/ao_scheme_make_const.c @@ -220,7 +220,7 @@ ao_has_macro(ao_poly p) list = cons->cdr; p = AO_SCHEME_NIL; - while (list != AO_SCHEME_NIL && ao_scheme_poly_type(list) == AO_SCHEME_CONS) { + while (list != AO_SCHEME_NIL && AO_SCHEME_IS_CONS(list)) { cons = ao_scheme_poly_cons(list); m = ao_has_macro(cons->car); if (m) { @@ -280,7 +280,7 @@ ao_scheme_read_eval_abort(void) out = ao_scheme_eval(in); if (ao_scheme_exception) return 0; - ao_scheme_poly_write(out); + ao_scheme_poly_write(out, true); putchar ('\n'); } return 1; @@ -446,7 +446,7 @@ main(int argc, char **argv) if (val != AO_SCHEME_NIL) { printf("error: function %s contains unresolved macro: ", ao_scheme_poly_atom(vals->vals[f].atom)->name); - ao_scheme_poly_write(val); + ao_scheme_poly_write(val, true); printf("\n"); exit(1); } diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c index 94275451..a336fdfe 100644 --- a/src/scheme/ao_scheme_mem.c +++ b/src/scheme/ao_scheme_mem.c @@ -1061,7 +1061,7 @@ ao_scheme_print_mark_addr(void *addr) #endif if (!AO_SCHEME_IS_POOL(addr)) - return 1; + return 0; if (!ao_scheme_print_cleared) { ao_scheme_print_cleared = 1; @@ -1074,14 +1074,23 @@ ao_scheme_print_mark_addr(void *addr) return 0; } -int -ao_scheme_print_mark_poly(ao_poly p) +void +ao_scheme_print_clear_addr(void *addr) { - uint8_t type = ao_scheme_poly_base_type(p); + int offset; - if (type == AO_SCHEME_INT) - return 1; - return ao_scheme_print_mark_addr(ao_scheme_ref(p)); +#if DBG_MEM + if (ao_scheme_collecting) + ao_scheme_abort(); +#endif + + if (!AO_SCHEME_IS_POOL(addr)) + return; + + if (!ao_scheme_print_cleared) + return; + offset = pool_offset(addr); + clear(ao_scheme_busy, offset); } /* Notes that printing has started */ @@ -1091,11 +1100,13 @@ ao_scheme_print_start(void) ao_scheme_printing++; } -/* Notes that printing has ended */ -void +/* Notes that printing has ended. Returns 1 if printing is still going on */ +int ao_scheme_print_stop(void) { ao_scheme_printing--; - if (ao_scheme_printing == 0) - ao_scheme_print_cleared = 0; + if (ao_scheme_printing != 0) + return 1; + ao_scheme_print_cleared = 0; + return 0; } diff --git a/src/scheme/ao_scheme_poly.c b/src/scheme/ao_scheme_poly.c index 70e577a2..25ac6d67 100644 --- a/src/scheme/ao_scheme_poly.c +++ b/src/scheme/ao_scheme_poly.c @@ -14,100 +14,41 @@ #include "ao_scheme.h" -struct ao_scheme_funcs { - void (*write)(ao_poly); - void (*display)(ao_poly); -}; +static void ao_scheme_invalid_write(ao_poly p, bool write) { + printf("??? type %d poly 0x%04x ???", ao_scheme_poly_type (p), p); + (void) write; + ao_scheme_abort(); +} -static const struct ao_scheme_funcs ao_scheme_funcs[AO_SCHEME_NUM_TYPE] = { - [AO_SCHEME_CONS] = { - .write = ao_scheme_cons_write, - .display = ao_scheme_cons_display, - }, +static void (*const ao_scheme_write_funcs[AO_SCHEME_NUM_TYPE]) (ao_poly p, bool write) = { + [AO_SCHEME_CONS] = ao_scheme_cons_write, #ifdef AO_SCHEME_FEATURE_BIGINT - [AO_SCHEME_BIGINT] = { - .write = ao_scheme_bigint_write, - .display = ao_scheme_bigint_write, - }, + [AO_SCHEME_BIGINT] = ao_scheme_bigint_write, #endif - [AO_SCHEME_INT] = { - .write = ao_scheme_int_write, - .display = ao_scheme_int_write, - }, - [AO_SCHEME_ATOM] = { - .write = ao_scheme_atom_write, - .display = ao_scheme_atom_write, - }, - [AO_SCHEME_BUILTIN] = { - .write = ao_scheme_builtin_write, - .display = ao_scheme_builtin_write, - }, - [AO_SCHEME_FRAME] = { - .write = ao_scheme_frame_write, - .display = ao_scheme_frame_write, - }, - [AO_SCHEME_FRAME_VALS] = { - .write = NULL, - .display = NULL, - }, - [AO_SCHEME_LAMBDA] = { - .write = ao_scheme_lambda_write, - .display = ao_scheme_lambda_write, - }, - [AO_SCHEME_STACK] = { - .write = ao_scheme_stack_write, - .display = ao_scheme_stack_write, - }, - [AO_SCHEME_BOOL] = { - .write = ao_scheme_bool_write, - .display = ao_scheme_bool_write, - }, - [AO_SCHEME_STRING] = { - .write = ao_scheme_string_write, - .display = ao_scheme_string_display, - }, + [AO_SCHEME_INT] = ao_scheme_int_write, + [AO_SCHEME_ATOM] = ao_scheme_atom_write, + [AO_SCHEME_BUILTIN] = ao_scheme_builtin_write, + [AO_SCHEME_FRAME] = ao_scheme_frame_write, + [AO_SCHEME_FRAME_VALS] = ao_scheme_invalid_write, + [AO_SCHEME_LAMBDA] = ao_scheme_lambda_write, + [AO_SCHEME_STACK] = ao_scheme_stack_write, + [AO_SCHEME_BOOL] = ao_scheme_bool_write, + [AO_SCHEME_STRING] = ao_scheme_string_write, #ifdef AO_SCHEME_FEATURE_FLOAT - [AO_SCHEME_FLOAT] = { - .write = ao_scheme_float_write, - .display = ao_scheme_float_write, - }, + [AO_SCHEME_FLOAT] = ao_scheme_float_write, #endif #ifdef AO_SCHEME_FEATURE_VECTOR - [AO_SCHEME_VECTOR] = { - .write = ao_scheme_vector_write, - .display = ao_scheme_vector_display - }, + [AO_SCHEME_VECTOR] = ao_scheme_vector_write, #endif }; -static void ao_scheme_invalid_write(ao_poly p) { - printf("??? 0x%04x ???", p); - ao_scheme_abort(); -} - -static const struct ao_scheme_funcs ao_scheme_invalid_funcs = { - .write = ao_scheme_invalid_write, - .display = ao_scheme_invalid_write, -}; - -static const struct ao_scheme_funcs * -funcs(ao_poly p) +void (*ao_scheme_poly_write_func(ao_poly p))(ao_poly p, bool write) { uint8_t type = ao_scheme_poly_type(p); if (type < AO_SCHEME_NUM_TYPE) - return &ao_scheme_funcs[type]; - return &ao_scheme_invalid_funcs; -} - -void (*ao_scheme_poly_write_func(ao_poly p))(ao_poly p) -{ - return funcs(p)->write; -} - -void (*ao_scheme_poly_display_func(ao_poly p))(ao_poly p) -{ - return funcs(p)->display; + return ao_scheme_write_funcs[type]; + return ao_scheme_invalid_write; } void * diff --git a/src/scheme/ao_scheme_rep.c b/src/scheme/ao_scheme_rep.c index 5b94d940..b35ba5b8 100644 --- a/src/scheme/ao_scheme_rep.c +++ b/src/scheme/ao_scheme_rep.c @@ -30,7 +30,7 @@ ao_scheme_read_eval_print(void) break; ao_scheme_exception = 0; } else { - ao_scheme_poly_write(out); + ao_scheme_poly_write(out, true); putchar ('\n'); } } diff --git a/src/scheme/ao_scheme_stack.c b/src/scheme/ao_scheme_stack.c index e062a093..e29e2b68 100644 --- a/src/scheme/ao_scheme_stack.c +++ b/src/scheme/ao_scheme_stack.c @@ -158,26 +158,35 @@ ao_scheme_stack_clear(void) } void -ao_scheme_stack_write(ao_poly poly) +ao_scheme_stack_write(ao_poly poly, bool write) { - struct ao_scheme_stack *s = ao_scheme_poly_stack(poly); + struct ao_scheme_stack *s = ao_scheme_poly_stack(poly); + struct ao_scheme_stack *clear = s; + int written = 0; + (void) write; + ao_scheme_print_start(); + ao_scheme_frame_print_indent += 2; while (s) { - if (s->type & AO_SCHEME_STACK_PRINT) { + if (ao_scheme_print_mark_addr(s)) { printf("[recurse...]"); - return; + break; } - s->type |= AO_SCHEME_STACK_PRINT; + written++; printf("\t[\n"); - printf("\t\texpr: "); ao_scheme_poly_write(s->list); printf("\n"); - printf("\t\tstate: %s\n", ao_scheme_state_names[s->state]); - ao_scheme_error_poly ("values: ", s->values, s->values_tail); - ao_scheme_error_poly ("sexprs: ", s->sexprs, AO_SCHEME_NIL); - ao_scheme_error_frame(2, "frame: ", ao_scheme_poly_frame(s->frame)); + ao_scheme_printf("\t\texpr: %v\n", s->list); + ao_scheme_printf("\t\tvalues: %v\n", s->values); + ao_scheme_printf("\t\tframe: %v\n", s->frame); printf("\t]\n"); - s->type &= ~AO_SCHEME_STACK_PRINT; s = ao_scheme_poly_stack(s->prev); } + ao_scheme_frame_print_indent -= 2; + if (ao_scheme_print_stop()) { + while (written--) { + ao_scheme_print_clear_addr(clear); + clear = ao_scheme_poly_stack(clear->prev); + } + } } /* diff --git a/src/scheme/ao_scheme_string.c b/src/scheme/ao_scheme_string.c index e18a8e85..b00ef276 100644 --- a/src/scheme/ao_scheme_string.c +++ b/src/scheme/ao_scheme_string.c @@ -173,42 +173,36 @@ ao_scheme_string_unpack(struct ao_scheme_string *a) } void -ao_scheme_string_write(ao_poly p) +ao_scheme_string_write(ao_poly p, bool write) { struct ao_scheme_string *s = ao_scheme_poly_string(p); char *sval = s->val; char c; - putchar('"'); - while ((c = *sval++)) { - switch (c) { - case '\n': - printf ("\\n"); - break; - case '\r': - printf ("\\r"); - break; - case '\t': - printf ("\\t"); - break; - default: - if (c < ' ') - printf("\\%03o", c); - else - putchar(c); - break; + if (write) { + putchar('"'); + while ((c = *sval++)) { + switch (c) { + case '\n': + printf ("\\n"); + break; + case '\r': + printf ("\\r"); + break; + case '\t': + printf ("\\t"); + break; + default: + if (c < ' ') + printf("\\%03o", c); + else + putchar(c); + break; + } } + putchar('"'); + } else { + while ((c = *sval++)) + putchar(c); } - putchar('"'); -} - -void -ao_scheme_string_display(ao_poly p) -{ - struct ao_scheme_string *s = ao_scheme_poly_string(p); - char *sval = s->val; - char c; - - while ((c = *sval++)) - putchar(c); } diff --git a/src/scheme/ao_scheme_vector.c b/src/scheme/ao_scheme_vector.c index ff2067e2..419d6765 100644 --- a/src/scheme/ao_scheme_vector.c +++ b/src/scheme/ao_scheme_vector.c @@ -73,39 +73,27 @@ ao_scheme_vector_alloc(uint16_t length, ao_poly fill) } void -ao_scheme_vector_write(ao_poly v) +ao_scheme_vector_write(ao_poly v, bool write) { struct ao_scheme_vector *vector = ao_scheme_poly_vector(v); unsigned int i; + int was_marked = 0; ao_scheme_print_start(); - if (ao_scheme_print_mark_addr(vector)) + was_marked = ao_scheme_print_mark_addr(vector); + if (was_marked) { printf ("..."); - else { + } else { printf("#("); for (i = 0; i < vector->length; i++) { if (i != 0) printf(" "); - ao_scheme_poly_write(vector->vals[i]); + ao_scheme_poly_write(vector->vals[i], write); } printf(")"); } - ao_scheme_print_stop(); -} - -void -ao_scheme_vector_display(ao_poly v) -{ - struct ao_scheme_vector *vector = ao_scheme_poly_vector(v); - unsigned int i; - - ao_scheme_print_start(); - if (ao_scheme_print_mark_addr(vector)) - printf ("..."); - else { - for (i = 0; i < vector->length; i++) - ao_scheme_poly_display(vector->vals[i]); - } + if (ao_scheme_print_stop() && !was_marked) + ao_scheme_print_clear_addr(vector); } static int32_t -- cgit v1.2.3 From fbe5dc9f215e7014aa8f9d325c1fba939816be03 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 19 Dec 2017 11:35:09 -0800 Subject: altos/scheme: apply also needs to not free value list on lambdas When apply is invoked on any function, the cons in the argument list cannot be immediately freed as they have been passed to the function. That applies to both built-ins as well as lambdas; this patch removes the special ao_scheme_skip_cons_free global and just marks the stack in both cases. Signed-off-by: Keith Packard --- src/scheme/ao_scheme_eval.c | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/src/scheme/ao_scheme_eval.c b/src/scheme/ao_scheme_eval.c index 907ecf0b..9204ce1a 100644 --- a/src/scheme/ao_scheme_eval.c +++ b/src/scheme/ao_scheme_eval.c @@ -17,7 +17,6 @@ struct ao_scheme_stack *ao_scheme_stack; ao_poly ao_scheme_v; -uint8_t ao_scheme_skip_cons_free; ao_poly ao_scheme_set_cond(struct ao_scheme_cons *c) @@ -265,7 +264,7 @@ ao_scheme_eval_exec(void) DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n"); }); builtin = ao_scheme_poly_builtin(ao_scheme_v); - if (builtin && (builtin->args & AO_SCHEME_FUNC_FREE_ARGS) && !ao_scheme_stack_marked(ao_scheme_stack) && !ao_scheme_skip_cons_free) { + if (builtin && (builtin->args & AO_SCHEME_FUNC_FREE_ARGS) && !ao_scheme_stack_marked(ao_scheme_stack)) { struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_stack->values); ao_scheme_stack->values = AO_SCHEME_NIL; ao_scheme_cons_free(cons); @@ -294,7 +293,6 @@ ao_scheme_eval_exec(void) DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); break; } - ao_scheme_skip_cons_free = 0; return 1; } @@ -325,7 +323,7 @@ ao_scheme_eval_apply(void) ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->values)->car; DBGI("apply: "); DBG_POLY(ao_scheme_stack->values); DBG ("\n"); ao_scheme_stack->state = eval_exec; - ao_scheme_skip_cons_free = 1; + ao_scheme_stack_mark(ao_scheme_stack); return 1; } @@ -350,7 +348,7 @@ ao_scheme_eval_cond(void) ao_scheme_stack->state = eval_val; } else { ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car; - if (!ao_scheme_v || ao_scheme_poly_type(ao_scheme_v) != AO_SCHEME_CONS) { + if (!ao_scheme_v || !AO_SCHEME_IS_CONS(ao_scheme_v)) { ao_scheme_error(AO_SCHEME_INVALID, "invalid cond clause"); return 0; } @@ -494,7 +492,7 @@ ao_scheme_eval_macro(void) if (ao_scheme_v == AO_SCHEME_NIL) ao_scheme_abort(); - if (ao_scheme_poly_type(ao_scheme_v) == AO_SCHEME_CONS) { + if (AO_SCHEME_IS_CONS(ao_scheme_v)) { *ao_scheme_poly_cons(ao_scheme_stack->sexprs) = *ao_scheme_poly_cons(ao_scheme_v); ao_scheme_v = ao_scheme_stack->sexprs; DBGI("sexprs rewritten to: "); DBG_POLY(ao_scheme_v); DBG("\n"); -- cgit v1.2.3 From 53b99e0419cb44c7983e41026bf0430deae58940 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 19 Dec 2017 11:37:33 -0800 Subject: altos/scheme: (define (foo . bar)) has a pair, not list as card When defining a lambda with varargs, the args are not a list as the final element is not a pair or nil. Use pair? instead of list? to detect this form correctly. Signed-off-by: Keith Packard --- src/scheme/ao_scheme_const.scheme | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/scheme/ao_scheme_const.scheme b/src/scheme/ao_scheme_const.scheme index 060fd955..4616477f 100644 --- a/src/scheme/ao_scheme_const.scheme +++ b/src/scheme/ao_scheme_const.scheme @@ -248,7 +248,7 @@ (macro (first . rest) ; check for alternate lambda definition form - (cond ((list? first) + (cond ((pair? first) (set! rest (append (list @@ -640,7 +640,7 @@ (char-whitespace? #\0) (char-whitespace? #\space) -(define (char->integer c) c) +(define char->integer (macro (v) v)) (define integer->char char->integer) (define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c)) -- cgit v1.2.3 From ba472dda57e134fe0f0e4a571a6d0c1e5a1ea6eb Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 19 Dec 2017 11:39:39 -0800 Subject: altos/scheme: Clean up test CFLAGS make it easy to switch between debug and optimized builds. Signed-off-by: Keith Packard --- src/scheme/test/Makefile | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/scheme/test/Makefile b/src/scheme/test/Makefile index 898c75f3..ee46118e 100644 --- a/src/scheme/test/Makefile +++ b/src/scheme/test/Makefile @@ -9,7 +9,11 @@ HDRS=$(SCHEME_HDRS) ao_scheme_const.h OBJS=$(SRCS:.c=.o) -CFLAGS=-O3 -g -Wall -Wextra -I. -I.. -Wpointer-arith -Wmissing-declarations -Wformat=2 -Wstrict-prototypes -Wmissing-prototypes -Wnested-externs -Wbad-function-cast -Wold-style-definition -Wdeclaration-after-statement -Wunused -Wuninitialized -Wshadow -Wmissing-noreturn -Wmissing-format-attribute -Wredundant-decls -Wlogical-op -Werror=implicit -Werror=nonnull -Werror=init-self -Werror=main -Werror=missing-braces -Werror=sequence-point -Werror=return-type -Werror=trigraphs -Werror=array-bounds -Werror=write-strings -Werror=address -Werror=int-to-pointer-cast -Werror=pointer-to-int-cast +#PGFLAGS=-pg -no-pie +OFLAGS=-O3 +#DFLAGS=-O0 + +CFLAGS=$(DFLAGS) $(OFLAGS) $(PGFLAGS) -g -Wall -Wextra -I. -I.. -Wpointer-arith -Wmissing-declarations -Wformat=2 -Wstrict-prototypes -Wmissing-prototypes -Wnested-externs -Wbad-function-cast -Wold-style-definition -Wdeclaration-after-statement -Wunused -Wuninitialized -Wshadow -Wmissing-noreturn -Wmissing-format-attribute -Wredundant-decls -Wlogical-op -Werror=implicit -Werror=nonnull -Werror=init-self -Werror=main -Werror=missing-braces -Werror=sequence-point -Werror=return-type -Werror=trigraphs -Werror=array-bounds -Werror=write-strings -Werror=address -Werror=int-to-pointer-cast -Werror=pointer-to-int-cast ao-scheme: $(OBJS) cc $(CFLAGS) -o $@ $(OBJS) -lm @@ -23,4 +27,4 @@ clean:: rm -f $(OBJS) ao-scheme ao_scheme_const.h install: ao-scheme - cp $^ $$HOME/bin + install -t $$HOME/bin $^ -- cgit v1.2.3 From 00390fb09f47654905824af671b966ffca0a38b3 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 19 Dec 2017 11:40:08 -0800 Subject: altos/scheme: Don't optimize ao_scheme_make_const Performance isn't interesting, and it's nice to have a bare system ready for debugging. Signed-off-by: Keith Packard --- src/scheme/make-const/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/scheme/make-const/Makefile b/src/scheme/make-const/Makefile index 438b6a79..a8e3a7f5 100644 --- a/src/scheme/make-const/Makefile +++ b/src/scheme/make-const/Makefile @@ -10,7 +10,7 @@ HDRS=$(SCHEME_HDRS) ao_scheme_os.h OBJS=$(SRCS:.c=.o) CC=cc -CFLAGS=-DAO_SCHEME_MAKE_CONST -O2 -g -I. -Wall -Wextra -Wpointer-arith -Wmissing-declarations -Wformat=2 -Wstrict-prototypes -Wmissing-prototypes -Wnested-externs -Wbad-function-cast -Wold-style-definition -Wdeclaration-after-statement -Wunused -Wuninitialized -Wshadow -Wmissing-noreturn -Wmissing-format-attribute -Wredundant-decls -Wlogical-op -Werror=implicit -Werror=nonnull -Werror=init-self -Werror=main -Werror=missing-braces -Werror=sequence-point -Werror=return-type -Werror=trigraphs -Werror=array-bounds -Werror=write-strings -Werror=address -Werror=int-to-pointer-cast -Werror=pointer-to-int-cast +CFLAGS=-DAO_SCHEME_MAKE_CONST -O0 -g -I. -Wall -Wextra -Wpointer-arith -Wmissing-declarations -Wformat=2 -Wstrict-prototypes -Wmissing-prototypes -Wnested-externs -Wbad-function-cast -Wold-style-definition -Wdeclaration-after-statement -Wunused -Wuninitialized -Wshadow -Wmissing-noreturn -Wmissing-format-attribute -Wredundant-decls -Wlogical-op -Werror=implicit -Werror=nonnull -Werror=init-self -Werror=main -Werror=missing-braces -Werror=sequence-point -Werror=return-type -Werror=trigraphs -Werror=array-bounds -Werror=write-strings -Werror=address -Werror=int-to-pointer-cast -Werror=pointer-to-int-cast .c.o: $(CC) -c $(CFLAGS) $< -o $@ -- cgit v1.2.3 From fa6f4b331db9d37da6767005fd375b696485b46b Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 19 Dec 2017 11:43:23 -0800 Subject: altos/scheme: ao_scheme__cons -> ao_scheme_cons Fix the double underscore in this name. Ick. Signed-off-by: Keith Packard --- src/scheme/ao_scheme.h | 2 +- src/scheme/ao_scheme_builtin.c | 10 +++++----- src/scheme/ao_scheme_cons.c | 2 +- src/scheme/ao_scheme_eval.c | 2 +- src/scheme/ao_scheme_read.c | 2 +- 5 files changed, 9 insertions(+), 9 deletions(-) diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index b37e9098..5b31c623 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -646,7 +646,7 @@ struct ao_scheme_cons * ao_scheme_cons_cdr(struct ao_scheme_cons *cons); ao_poly -ao_scheme__cons(ao_poly car, ao_poly cdr); +ao_scheme_cons(ao_poly car, ao_poly cdr); extern struct ao_scheme_cons *ao_scheme_cons_free_list; diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index 221570c7..f4dff5bf 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -168,7 +168,7 @@ ao_scheme_do_cons(struct ao_scheme_cons *cons) return AO_SCHEME_NIL; car = ao_scheme_arg(cons, 0); cdr = ao_scheme_arg(cons, 1); - return ao_scheme__cons(car, cdr); + return ao_scheme_cons(car, cdr); } ao_poly @@ -253,10 +253,10 @@ ao_scheme_do_setq(struct ao_scheme_cons *cons) return ao_scheme_error(AO_SCHEME_INVALID, "set! of non-atom %v", name); if (!ao_scheme_atom_ref(name, NULL)) return ao_scheme_error(AO_SCHEME_INVALID, "atom %v not defined", name); - return ao_scheme__cons(_ao_scheme_atom_set, - ao_scheme__cons(ao_scheme__cons(_ao_scheme_atom_quote, - ao_scheme__cons(name, AO_SCHEME_NIL)), - cons->cdr)); + return ao_scheme_cons(_ao_scheme_atom_set, + ao_scheme_cons(ao_scheme_cons(_ao_scheme_atom_quote, + ao_scheme_cons(name, AO_SCHEME_NIL)), + cons->cdr)); } ao_poly diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c index 7976250b..d40c2826 100644 --- a/src/scheme/ao_scheme_cons.c +++ b/src/scheme/ao_scheme_cons.c @@ -119,7 +119,7 @@ ao_scheme_cons_cdr(struct ao_scheme_cons *cons) } ao_poly -ao_scheme__cons(ao_poly car, ao_poly cdr) +ao_scheme_cons(ao_poly car, ao_poly cdr) { return ao_scheme_cons_poly(ao_scheme_cons_cons(car, cdr)); } diff --git a/src/scheme/ao_scheme_eval.c b/src/scheme/ao_scheme_eval.c index 9204ce1a..edc16a73 100644 --- a/src/scheme/ao_scheme_eval.c +++ b/src/scheme/ao_scheme_eval.c @@ -206,7 +206,7 @@ ao_scheme_eval_formal(void) } /* Append formal to list of values */ - formal = ao_scheme__cons(ao_scheme_v, AO_SCHEME_NIL); + formal = ao_scheme_cons(ao_scheme_v, AO_SCHEME_NIL); if (!formal) return 0; diff --git a/src/scheme/ao_scheme_read.c b/src/scheme/ao_scheme_read.c index 721211bc..e93466fc 100644 --- a/src/scheme/ao_scheme_read.c +++ b/src/scheme/ao_scheme_read.c @@ -510,7 +510,7 @@ push_read_stack(int read_state) RDBG_IN(); if (ao_scheme_read_list) { ao_scheme_read_stack = ao_scheme_cons_cons(ao_scheme_cons_poly(ao_scheme_read_cons), - ao_scheme__cons(ao_scheme_int_poly(read_state), + ao_scheme_cons(ao_scheme_int_poly(read_state), ao_scheme_cons_poly(ao_scheme_read_stack))); if (!ao_scheme_read_stack) return 0; -- cgit v1.2.3 From 34f998d147d08e966daad1ab76c40906018d3d8d Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 19 Dec 2017 11:51:33 -0800 Subject: altos/scheme: AO_SCHEME_IS_CONS -> ao_scheme_is_cons This inline was already defined; just use it. Also, switch some places to use ao_scheme_is_pair instead as appropriate. Signed-off-by: Keith Packard --- src/scheme/ao_scheme.h | 2 -- src/scheme/ao_scheme_builtin.c | 4 ++-- src/scheme/ao_scheme_cons.c | 10 +++++----- src/scheme/ao_scheme_eval.c | 4 ++-- src/scheme/ao_scheme_make_const.c | 2 +- 5 files changed, 10 insertions(+), 12 deletions(-) diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index 5b31c623..b8e683fb 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -157,8 +157,6 @@ ao_scheme_is_const(ao_poly poly) { #define AO_SCHEME_IS_CONST(a) (ao_scheme_const <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_scheme_const + AO_SCHEME_POOL_CONST) #define AO_SCHEME_IS_POOL(a) (ao_scheme_pool <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_scheme_pool + AO_SCHEME_POOL) -#define AO_SCHEME_IS_INT(p) (ao_scheme_poly_base_type(p) == AO_SCHEME_INT) -#define AO_SCHEME_IS_CONS(p) (ao_scheme_poly_base_type(p) == AO_SCHEME_CONS) void * ao_scheme_ref(ao_poly poly); diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index f4dff5bf..84382434 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -856,7 +856,7 @@ ao_scheme_do_pairp(struct ao_scheme_cons *cons) if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) return AO_SCHEME_NIL; v = ao_scheme_arg(cons, 0); - if (v != AO_SCHEME_NIL && AO_SCHEME_IS_CONS(v)) + if (ao_scheme_is_pair(v)) return _ao_scheme_bool_true; return _ao_scheme_bool_false; } @@ -947,7 +947,7 @@ ao_scheme_do_listp(struct ao_scheme_cons *cons) for (;;) { if (v == AO_SCHEME_NIL) return _ao_scheme_bool_true; - if (!AO_SCHEME_IS_CONS(v)) + if (!ao_scheme_is_cons(v)) return _ao_scheme_bool_false; v = ao_scheme_poly_cons(v)->cdr; } diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c index d40c2826..1a2de823 100644 --- a/src/scheme/ao_scheme_cons.c +++ b/src/scheme/ao_scheme_cons.c @@ -24,7 +24,7 @@ static void cons_mark(void *addr) ao_scheme_poly_mark(cons->car, 1); if (!cdr) break; - if (!AO_SCHEME_IS_CONS(cdr)) { + if (!ao_scheme_is_cons(cdr)) { ao_scheme_poly_mark(cdr, 0); break; } @@ -58,7 +58,7 @@ static void cons_move(void *addr) cdr = cons->cdr; if (!cdr) break; - if (!AO_SCHEME_IS_CONS(cdr)) { + if (!ao_scheme_is_cons(cdr)) { (void) ao_scheme_poly_move(&cons->cdr, 0); break; } @@ -111,7 +111,7 @@ ao_scheme_cons_cdr(struct ao_scheme_cons *cons) ao_poly cdr = cons->cdr; if (cdr == AO_SCHEME_NIL) return NULL; - if (!AO_SCHEME_IS_CONS(cdr)) { + if (!ao_scheme_is_cons(cdr)) { (void) ao_scheme_error(AO_SCHEME_INVALID, "improper cdr %v", cdr); return NULL; } @@ -151,7 +151,7 @@ ao_scheme_cons_copy(struct ao_scheme_cons *cons) tail->cdr = ao_scheme_cons_poly(new); tail = new; cdr = cons->cdr; - if (!AO_SCHEME_IS_CONS(cdr)) { + if (!ao_scheme_is_cons(cdr)) { tail->cdr = cdr; break; } @@ -203,7 +203,7 @@ ao_scheme_cons_write(ao_poly c, bool write) written++; cdr = cons->cdr; - if (!AO_SCHEME_IS_CONS(cdr)) { + if (!ao_scheme_is_cons(cdr)) { printf(" . "); ao_scheme_poly_write(cdr, write); break; diff --git a/src/scheme/ao_scheme_eval.c b/src/scheme/ao_scheme_eval.c index edc16a73..91f6a84f 100644 --- a/src/scheme/ao_scheme_eval.c +++ b/src/scheme/ao_scheme_eval.c @@ -348,7 +348,7 @@ ao_scheme_eval_cond(void) ao_scheme_stack->state = eval_val; } else { ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car; - if (!ao_scheme_v || !AO_SCHEME_IS_CONS(ao_scheme_v)) { + if (!ao_scheme_is_pair(ao_scheme_v)) { ao_scheme_error(AO_SCHEME_INVALID, "invalid cond clause"); return 0; } @@ -492,7 +492,7 @@ ao_scheme_eval_macro(void) if (ao_scheme_v == AO_SCHEME_NIL) ao_scheme_abort(); - if (AO_SCHEME_IS_CONS(ao_scheme_v)) { + if (ao_scheme_is_cons(ao_scheme_v)) { *ao_scheme_poly_cons(ao_scheme_stack->sexprs) = *ao_scheme_poly_cons(ao_scheme_v); ao_scheme_v = ao_scheme_stack->sexprs; DBGI("sexprs rewritten to: "); DBG_POLY(ao_scheme_v); DBG("\n"); diff --git a/src/scheme/ao_scheme_make_const.c b/src/scheme/ao_scheme_make_const.c index 79ba1bf1..e34792c4 100644 --- a/src/scheme/ao_scheme_make_const.c +++ b/src/scheme/ao_scheme_make_const.c @@ -220,7 +220,7 @@ ao_has_macro(ao_poly p) list = cons->cdr; p = AO_SCHEME_NIL; - while (list != AO_SCHEME_NIL && AO_SCHEME_IS_CONS(list)) { + while (ao_scheme_is_pair(list)) { cons = ao_scheme_poly_cons(list); m = ao_has_macro(cons->car); if (m) { -- cgit v1.2.3 From 71fb79492cb955af4bd52e79f1fa69d17e084dbc Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 19 Dec 2017 12:16:24 -0800 Subject: altos/scheme: Replace memory pool macros with inlines AO_SCHEME_IS_CONST -> ao_scheme_is_const_addr AO_SCHEME_IS_POOL -> ao_scheme_is_pool_addr Provides better typechecking and avoids confusion with ao_scheme_is_const inline (which takes an ao_poly instead of a void *) Signed-off-by: Keith Packard --- src/scheme/ao_scheme.h | 13 +++++++++++-- src/scheme/ao_scheme_frame.c | 5 ----- src/scheme/ao_scheme_mem.c | 18 +++++++++--------- src/scheme/ao_scheme_poly.c | 2 +- 4 files changed, 21 insertions(+), 17 deletions(-) diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index b8e683fb..5cae0bda 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -155,8 +155,17 @@ ao_scheme_is_const(ao_poly poly) { return poly & AO_SCHEME_CONST; } -#define AO_SCHEME_IS_CONST(a) (ao_scheme_const <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_scheme_const + AO_SCHEME_POOL_CONST) -#define AO_SCHEME_IS_POOL(a) (ao_scheme_pool <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_scheme_pool + AO_SCHEME_POOL) +static inline int +ao_scheme_is_const_addr(const void *addr) { + const uint8_t *a = addr; + return (ao_scheme_const <= a) && (a < ao_scheme_const + AO_SCHEME_POOL_CONST); +} + +static inline int +ao_scheme_is_pool_addr(const void *addr) { + const uint8_t *a = addr; + return (ao_scheme_pool <= a) && (a < ao_scheme_pool + AO_SCHEME_POOL); +} void * ao_scheme_ref(ao_poly poly); diff --git a/src/scheme/ao_scheme_frame.c b/src/scheme/ao_scheme_frame.c index 46f941e6..a7e5153f 100644 --- a/src/scheme/ao_scheme_frame.c +++ b/src/scheme/ao_scheme_frame.c @@ -86,8 +86,6 @@ frame_mark(void *addr) struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); - if (!AO_SCHEME_IS_POOL(frame)) - break; if (!ao_scheme_mark_memory(&ao_scheme_frame_vals_type, vals)) frame_vals_mark(vals); frame = ao_scheme_poly_frame(frame->prev); @@ -110,9 +108,6 @@ frame_move(void *addr) int ret; MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); - if (!AO_SCHEME_IS_POOL(frame)) - break; - vals = ao_scheme_poly_frame_vals(frame->vals); if (!ao_scheme_move_memory(&ao_scheme_frame_vals_type, (void **) &vals)) frame_vals_move(vals); diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c index a336fdfe..55872b62 100644 --- a/src/scheme/ao_scheme_mem.c +++ b/src/scheme/ao_scheme_mem.c @@ -313,7 +313,7 @@ static struct ao_scheme_chunk ao_scheme_chunk[AO_SCHEME_NCHUNK]; /* Offset of an address within the pool. */ static inline uint16_t pool_offset(void *addr) { #if DBG_MEM - if (!AO_SCHEME_IS_POOL(addr)) + if (!ao_scheme_is_pool_addr(addr)) ao_scheme_abort(); #endif return ((uint8_t *) addr) - ao_scheme_pool; @@ -723,7 +723,7 @@ ao_scheme_cons_check(struct ao_scheme_cons *cons) reset_chunks(); walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); while (cons) { - if (!AO_SCHEME_IS_POOL(cons)) + if (!ao_scheme_is_pool_addr(cons)) break; offset = pool_offset(cons); if (busy(ao_scheme_busy, offset)) { @@ -752,7 +752,7 @@ int ao_scheme_mark_memory(const struct ao_scheme_type *type, void *addr) { int offset; - if (!AO_SCHEME_IS_POOL(addr)) + if (!ao_scheme_is_pool_addr(addr)) return 1; offset = pool_offset(addr); @@ -804,7 +804,7 @@ ao_scheme_poly_mark(ao_poly p, uint8_t do_note_cons) return 1; addr = ao_scheme_ref(p); - if (!AO_SCHEME_IS_POOL(addr)) + if (!ao_scheme_is_pool_addr(addr)) return 1; if (type == AO_SCHEME_CONS && do_note_cons) { @@ -864,7 +864,7 @@ ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref) void *addr = *ref; uint16_t offset, orig_offset; - if (!AO_SCHEME_IS_POOL(addr)) + if (!ao_scheme_is_pool_addr(addr)) return 1; (void) type; @@ -874,7 +874,7 @@ ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref) offset = move_map(orig_offset); if (offset != orig_offset) { MDBG_MOVE("update ref %d %d -> %d\n", - AO_SCHEME_IS_POOL(ref) ? MDBG_OFFSET(ref) : -1, + ao_scheme_is_pool_addr(ref) ? MDBG_OFFSET(ref) : -1, orig_offset, offset); *ref = ao_scheme_pool + offset; } @@ -914,7 +914,7 @@ ao_scheme_poly_move(ao_poly *ref, uint8_t do_note_cons) return 1; addr = ao_scheme_ref(p); - if (!AO_SCHEME_IS_POOL(addr)) + if (!ao_scheme_is_pool_addr(addr)) return 1; orig_offset = pool_offset(addr); @@ -1060,7 +1060,7 @@ ao_scheme_print_mark_addr(void *addr) ao_scheme_abort(); #endif - if (!AO_SCHEME_IS_POOL(addr)) + if (!ao_scheme_is_pool_addr(addr)) return 0; if (!ao_scheme_print_cleared) { @@ -1084,7 +1084,7 @@ ao_scheme_print_clear_addr(void *addr) ao_scheme_abort(); #endif - if (!AO_SCHEME_IS_POOL(addr)) + if (!ao_scheme_is_pool_addr(addr)) return; if (!ao_scheme_print_cleared) diff --git a/src/scheme/ao_scheme_poly.c b/src/scheme/ao_scheme_poly.c index 25ac6d67..0cffc196 100644 --- a/src/scheme/ao_scheme_poly.c +++ b/src/scheme/ao_scheme_poly.c @@ -65,7 +65,7 @@ ao_scheme_poly(const void *addr, ao_poly type) { const uint8_t *a = addr; if (a == NULL) return AO_SCHEME_NIL; - if (AO_SCHEME_IS_CONST(a)) + if (ao_scheme_is_const_addr(a)) return AO_SCHEME_CONST | (a - ao_scheme_const + 4) | type; return (a - ao_scheme_pool + 4) | type; } -- cgit v1.2.3 From ed1f7b79abc7400a54b35fbf62c9db6855f9129a Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 19 Dec 2017 12:39:20 -0800 Subject: altos/scheme: Replace per-type indexed stash with poly stash heap Instead of having a random set of stash arrays with explicit indices used by callers, just have a general heap. Less error prone, and less code. Signed-off-by: Keith Packard --- src/scheme/ao_scheme.h | 72 +++++++++++++++++++++++--------- src/scheme/ao_scheme_atom.c | 4 +- src/scheme/ao_scheme_builtin.c | 16 ++++---- src/scheme/ao_scheme_cons.c | 20 ++++----- src/scheme/ao_scheme_frame.c | 16 ++++---- src/scheme/ao_scheme_lambda.c | 8 ++-- src/scheme/ao_scheme_mem.c | 93 ++++++++++-------------------------------- src/scheme/ao_scheme_stack.c | 12 +++--- src/scheme/ao_scheme_string.c | 32 +++++++-------- src/scheme/ao_scheme_vector.c | 8 ++-- 10 files changed, 132 insertions(+), 149 deletions(-) diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index 5cae0bda..d4c9bc05 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -595,38 +595,72 @@ ao_scheme_cons_check(struct ao_scheme_cons *cons); #endif void -ao_scheme_cons_stash(int id, struct ao_scheme_cons *cons); +ao_scheme_poly_stash(ao_poly poly); -struct ao_scheme_cons * -ao_scheme_cons_fetch(int id); +ao_poly +ao_scheme_poly_fetch(void); -void -ao_scheme_poly_stash(int id, ao_poly poly); +static inline void +ao_scheme_cons_stash(struct ao_scheme_cons *cons) { + ao_scheme_poly_stash(ao_scheme_cons_poly(cons)); +} -ao_poly -ao_scheme_poly_fetch(int id); +static inline struct ao_scheme_cons * +ao_scheme_cons_fetch(void) { + return ao_scheme_poly_cons(ao_scheme_poly_fetch()); +} -void -ao_scheme_string_stash(int id, struct ao_scheme_string *string); +static inline void +ao_scheme_atom_stash(struct ao_scheme_atom *atom) { + ao_scheme_poly_stash(ao_scheme_atom_poly(atom)); +} -struct ao_scheme_string * -ao_scheme_string_fetch(int id); +static inline struct ao_scheme_atom * +ao_scheme_atom_fetch(void) { + return ao_scheme_poly_atom(ao_scheme_poly_fetch()); +} + +static inline void +ao_scheme_string_stash(struct ao_scheme_string *string) { + ao_scheme_poly_stash(ao_scheme_string_poly(string)); +} +static inline struct ao_scheme_string * +ao_scheme_string_fetch(void) { + return ao_scheme_poly_string(ao_scheme_poly_fetch()); +} + +#ifdef AO_SCHEME_FEATURE_VECTOR static inline void -ao_scheme_stack_stash(int id, struct ao_scheme_stack *stack) { - ao_scheme_poly_stash(id, ao_scheme_stack_poly(stack)); +ao_scheme_vector_stash(struct ao_scheme_vector *vector) { + ao_scheme_poly_stash(ao_scheme_vector_poly(vector)); +} + +static inline struct ao_scheme_vector * +ao_scheme_vector_fetch(void) { + return ao_scheme_poly_vector(ao_scheme_poly_fetch()); +} +#endif + +static inline void +ao_scheme_stack_stash(struct ao_scheme_stack *stack) { + ao_scheme_poly_stash(ao_scheme_stack_poly(stack)); } static inline struct ao_scheme_stack * -ao_scheme_stack_fetch(int id) { - return ao_scheme_poly_stack(ao_scheme_poly_fetch(id)); +ao_scheme_stack_fetch(void) { + return ao_scheme_poly_stack(ao_scheme_poly_fetch()); } -void -ao_scheme_frame_stash(int id, struct ao_scheme_frame *frame); +static inline void +ao_scheme_frame_stash(struct ao_scheme_frame *frame) { + ao_scheme_poly_stash(ao_scheme_frame_poly(frame)); +} -struct ao_scheme_frame * -ao_scheme_frame_fetch(int id); +static inline struct ao_scheme_frame * +ao_scheme_frame_fetch(void) { + return ao_scheme_poly_frame(ao_scheme_poly_fetch()); +} /* bool */ diff --git a/src/scheme/ao_scheme_atom.c b/src/scheme/ao_scheme_atom.c index 8989cefd..c72a2b27 100644 --- a/src/scheme/ao_scheme_atom.c +++ b/src/scheme/ao_scheme_atom.c @@ -107,9 +107,9 @@ ao_scheme_string_to_atom(struct ao_scheme_string *string) if (atom) return atom; - ao_scheme_string_stash(0, string); + ao_scheme_string_stash(string); atom = ao_scheme_alloc(name_size(string->val)); - string = ao_scheme_string_fetch(0); + string = ao_scheme_string_fetch(); ao_scheme_atom_init(atom, string->val); return atom; } diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index 84382434..81fd9010 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -321,7 +321,7 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) if (cons == orig_cons) { ret = car; - ao_scheme_cons_stash(0, cons); + ao_scheme_cons_stash(cons); if (cons->cdr == AO_SCHEME_NIL) { switch (op) { case builtin_minus: @@ -349,7 +349,7 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) break; } } - cons = ao_scheme_cons_fetch(0); + cons = ao_scheme_cons_fetch(); } else if (ao_scheme_integer_typep(rt) && ao_scheme_integer_typep(ct)) { int32_t r = ao_scheme_poly_integer(ret, NULL); int32_t c = ao_scheme_poly_integer(car, NULL); @@ -413,9 +413,9 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) default: break; } - ao_scheme_cons_stash(0, cons); + ao_scheme_cons_stash(cons); ret = ao_scheme_integer_poly(r); - cons = ao_scheme_cons_fetch(0); + cons = ao_scheme_cons_fetch(); #ifdef AO_SCHEME_FEATURE_FLOAT } else if (ao_scheme_number_typep(rt) && ao_scheme_number_typep(ct)) { float r, c; @@ -442,16 +442,16 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) default: break; } - ao_scheme_cons_stash(0, cons); + ao_scheme_cons_stash(cons); ret = ao_scheme_float_get(r); - cons = ao_scheme_cons_fetch(0); + cons = ao_scheme_cons_fetch(); #endif } else if (rt == AO_SCHEME_STRING && ct == AO_SCHEME_STRING && op == builtin_plus) { - ao_scheme_cons_stash(0, cons); + ao_scheme_cons_stash(cons); ret = ao_scheme_string_poly(ao_scheme_string_cat(ao_scheme_poly_string(ret), ao_scheme_poly_string(car))); - cons = ao_scheme_cons_fetch(0); + cons = ao_scheme_cons_fetch(); if (!ret) return ret; } diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c index 1a2de823..a9ff5acd 100644 --- a/src/scheme/ao_scheme_cons.c +++ b/src/scheme/ao_scheme_cons.c @@ -92,11 +92,11 @@ ao_scheme_cons_cons(ao_poly car, ao_poly cdr) cons = ao_scheme_cons_free_list; ao_scheme_cons_free_list = ao_scheme_poly_cons(cons->cdr); } else { - ao_scheme_poly_stash(0, car); - ao_scheme_poly_stash(1, cdr); + ao_scheme_poly_stash(car); + ao_scheme_poly_stash(cdr); cons = ao_scheme_alloc(sizeof (struct ao_scheme_cons)); - cdr = ao_scheme_poly_fetch(1); - car = ao_scheme_poly_fetch(0); + cdr = ao_scheme_poly_fetch(); + car = ao_scheme_poly_fetch(); if (!cons) return NULL; } @@ -134,13 +134,13 @@ ao_scheme_cons_copy(struct ao_scheme_cons *cons) struct ao_scheme_cons *new; ao_poly cdr; - ao_scheme_cons_stash(0, cons); - ao_scheme_cons_stash(1, head); - ao_scheme_poly_stash(0, ao_scheme_cons_poly(tail)); + ao_scheme_cons_stash(cons); + ao_scheme_cons_stash(head); + ao_scheme_cons_stash(tail); new = ao_scheme_alloc(sizeof (struct ao_scheme_cons)); - cons = ao_scheme_cons_fetch(0); - head = ao_scheme_cons_fetch(1); - tail = ao_scheme_poly_cons(ao_scheme_poly_fetch(0)); + tail = ao_scheme_cons_fetch(); + head = ao_scheme_cons_fetch(); + cons = ao_scheme_cons_fetch(); if (!new) return AO_SCHEME_NIL; new->car = cons->car; diff --git a/src/scheme/ao_scheme_frame.c b/src/scheme/ao_scheme_frame.c index a7e5153f..16da62fb 100644 --- a/src/scheme/ao_scheme_frame.c +++ b/src/scheme/ao_scheme_frame.c @@ -250,9 +250,9 @@ ao_scheme_frame_new(int num) frame->num = 0; frame->prev = AO_SCHEME_NIL; frame->vals = AO_SCHEME_NIL; - ao_scheme_frame_stash(0, frame); + ao_scheme_frame_stash(frame); vals = ao_scheme_frame_vals_new(num); - frame = ao_scheme_frame_fetch(0); + frame = ao_scheme_frame_fetch(); if (!vals) return NULL; frame->vals = ao_scheme_frame_vals_poly(vals); @@ -296,9 +296,9 @@ ao_scheme_frame_realloc(struct ao_scheme_frame *frame, int new_num) if (new_num == frame->num) return frame; - ao_scheme_frame_stash(0, frame); + ao_scheme_frame_stash(frame); new_vals = ao_scheme_frame_vals_new(new_num); - frame = ao_scheme_frame_fetch(0); + frame = ao_scheme_frame_fetch(); if (!new_vals) return NULL; vals = ao_scheme_poly_frame_vals(frame->vals); @@ -331,11 +331,11 @@ ao_scheme_frame_add(struct ao_scheme_frame *frame, ao_poly atom, ao_poly val) if (!ref) { int f = frame->num; - ao_scheme_poly_stash(0, atom); - ao_scheme_poly_stash(1, val); + ao_scheme_poly_stash(atom); + ao_scheme_poly_stash(val); frame = ao_scheme_frame_realloc(frame, f + 1); - val = ao_scheme_poly_fetch(1); - atom = ao_scheme_poly_fetch(0); + val = ao_scheme_poly_fetch(); + atom = ao_scheme_poly_fetch(); if (!frame) return AO_SCHEME_NIL; ao_scheme_frame_bind(frame, frame->num - 1, atom, val); diff --git a/src/scheme/ao_scheme_lambda.c b/src/scheme/ao_scheme_lambda.c index e8ce0710..e818d7b0 100644 --- a/src/scheme/ao_scheme_lambda.c +++ b/src/scheme/ao_scheme_lambda.c @@ -89,9 +89,9 @@ ao_scheme_lambda_alloc(struct ao_scheme_cons *code, int args) } } - ao_scheme_cons_stash(0, code); + ao_scheme_cons_stash(code); lambda = ao_scheme_alloc(sizeof (struct ao_scheme_lambda)); - code = ao_scheme_cons_fetch(0); + code = ao_scheme_cons_fetch(); if (!lambda) return AO_SCHEME_NIL; @@ -160,9 +160,9 @@ ao_scheme_lambda_eval(void) return ao_scheme_error(AO_SCHEME_INVALID, "need at least %d args, got %d", args_wanted, args_provided); } - ao_scheme_poly_stash(1, varargs); + ao_scheme_poly_stash(varargs); next_frame = ao_scheme_frame_new(args_wanted + (varargs != AO_SCHEME_NIL)); - varargs = ao_scheme_poly_fetch(1); + varargs = ao_scheme_poly_fetch(); if (!next_frame) return AO_SCHEME_NIL; diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c index 55872b62..c9215072 100644 --- a/src/scheme/ao_scheme_mem.c +++ b/src/scheme/ao_scheme_mem.c @@ -184,43 +184,34 @@ struct ao_scheme_root { void **addr; }; -static struct ao_scheme_cons *save_cons[2]; -static struct ao_scheme_string *save_string[2]; -static struct ao_scheme_frame *save_frame[1]; -static ao_poly save_poly[3]; +#define AO_SCHEME_NUM_STASH 6 +static ao_poly stash_poly[AO_SCHEME_NUM_STASH]; +static int stash_poly_ptr; static const struct ao_scheme_root ao_scheme_root[] = { { - .type = &ao_scheme_cons_type, - .addr = (void **) &save_cons[0], - }, - { - .type = &ao_scheme_cons_type, - .addr = (void **) &save_cons[1], - }, - { - .type = &ao_scheme_string_type, - .addr = (void **) &save_string[0], + .type = NULL, + .addr = (void **) (void *) &stash_poly[0] }, { - .type = &ao_scheme_string_type, - .addr = (void **) &save_string[1], + .type = NULL, + .addr = (void **) (void *) &stash_poly[1] }, { - .type = &ao_scheme_frame_type, - .addr = (void **) &save_frame[0], + .type = NULL, + .addr = (void **) (void *) &stash_poly[2] }, { .type = NULL, - .addr = (void **) (void *) &save_poly[0] + .addr = (void **) (void *) &stash_poly[3] }, { .type = NULL, - .addr = (void **) (void *) &save_poly[1] + .addr = (void **) (void *) &stash_poly[4] }, { .type = NULL, - .addr = (void **) (void *) &save_poly[2] + .addr = (void **) (void *) &stash_poly[5] }, { .type = &ao_scheme_atom_type, @@ -991,63 +982,21 @@ ao_scheme_alloc(int size) } void -ao_scheme_cons_stash(int id, struct ao_scheme_cons *cons) -{ - assert(save_cons[id] == 0); - save_cons[id] = cons; -} - -struct ao_scheme_cons * -ao_scheme_cons_fetch(int id) -{ - struct ao_scheme_cons *cons = save_cons[id]; - save_cons[id] = NULL; - return cons; -} - -void -ao_scheme_poly_stash(int id, ao_poly poly) +ao_scheme_poly_stash(ao_poly p) { - assert(save_poly[id] == AO_SCHEME_NIL); - save_poly[id] = poly; + assert(stash_poly_ptr < AO_SCHEME_NUM_STASH); + stash_poly[stash_poly_ptr++] = p; } ao_poly -ao_scheme_poly_fetch(int id) -{ - ao_poly poly = save_poly[id]; - save_poly[id] = AO_SCHEME_NIL; - return poly; -} - -void -ao_scheme_string_stash(int id, struct ao_scheme_string *string) +ao_scheme_poly_fetch(void) { - assert(save_string[id] == NULL); - save_string[id] = string; -} + ao_poly p; -struct ao_scheme_string * -ao_scheme_string_fetch(int id) -{ - struct ao_scheme_string *string = save_string[id]; - save_string[id] = NULL; - return string; -} - -void -ao_scheme_frame_stash(int id, struct ao_scheme_frame *frame) -{ - assert(save_frame[id] == NULL); - save_frame[id] = frame; -} - -struct ao_scheme_frame * -ao_scheme_frame_fetch(int id) -{ - struct ao_scheme_frame *frame = save_frame[id]; - save_frame[id] = NULL; - return frame; + assert (stash_poly_ptr > 0); + p = stash_poly[--stash_poly_ptr]; + stash_poly[stash_poly_ptr] = AO_SCHEME_NIL; + return p; } int diff --git a/src/scheme/ao_scheme_stack.c b/src/scheme/ao_scheme_stack.c index e29e2b68..863df3ca 100644 --- a/src/scheme/ao_scheme_stack.c +++ b/src/scheme/ao_scheme_stack.c @@ -199,13 +199,13 @@ ao_scheme_stack_copy(struct ao_scheme_stack *old) struct ao_scheme_stack *n, *prev = NULL; while (old) { - ao_scheme_stack_stash(0, old); - ao_scheme_stack_stash(1, new); - ao_scheme_stack_stash(2, prev); + ao_scheme_stack_stash(old); + ao_scheme_stack_stash(new); + ao_scheme_stack_stash(prev); n = ao_scheme_stack_new(); - prev = ao_scheme_stack_fetch(2); - new = ao_scheme_stack_fetch(1); - old = ao_scheme_stack_fetch(0); + prev = ao_scheme_stack_fetch(); + new = ao_scheme_stack_fetch(); + old = ao_scheme_stack_fetch(); if (!n) return NULL; diff --git a/src/scheme/ao_scheme_string.c b/src/scheme/ao_scheme_string.c index b00ef276..dfc74966 100644 --- a/src/scheme/ao_scheme_string.c +++ b/src/scheme/ao_scheme_string.c @@ -60,9 +60,9 @@ ao_scheme_string_copy(struct ao_scheme_string *a) int alen = strlen(a->val); struct ao_scheme_string *r; - ao_scheme_string_stash(0, a); + ao_scheme_string_stash(a); r = ao_scheme_string_alloc(alen); - a = ao_scheme_string_fetch(0); + a = ao_scheme_string_fetch(); if (!r) return NULL; strcpy(r->val, a->val); @@ -87,9 +87,9 @@ ao_scheme_atom_to_string(struct ao_scheme_atom *a) int alen = strlen(a->name); struct ao_scheme_string *r; - ao_scheme_poly_stash(0, ao_scheme_atom_poly(a)); + ao_scheme_atom_stash(a); r = ao_scheme_string_alloc(alen); - a = ao_scheme_poly_atom(ao_scheme_poly_fetch(0)); + a = ao_scheme_atom_fetch(); if (!r) return NULL; strcpy(r->val, a->name); @@ -103,11 +103,11 @@ ao_scheme_string_cat(struct ao_scheme_string *a, struct ao_scheme_string *b) int blen = strlen(b->val); struct ao_scheme_string *r; - ao_scheme_string_stash(0, a); - ao_scheme_string_stash(1, b); + ao_scheme_string_stash(a); + ao_scheme_string_stash(b); r = ao_scheme_string_alloc(alen + blen); - a = ao_scheme_string_fetch(0); - b = ao_scheme_string_fetch(1); + b = ao_scheme_string_fetch(); + a = ao_scheme_string_fetch(); if (!r) return NULL; strcpy(r->val, a->val); @@ -123,9 +123,9 @@ ao_scheme_string_pack(struct ao_scheme_cons *cons) int len; len = ao_scheme_cons_length(cons); - ao_scheme_cons_stash(0, cons); + ao_scheme_cons_stash(cons); r = ao_scheme_string_alloc(len); - cons = ao_scheme_cons_fetch(0); + cons = ao_scheme_cons_fetch(); if (!r) return AO_SCHEME_NIL; rval = r->val; @@ -151,13 +151,13 @@ ao_scheme_string_unpack(struct ao_scheme_string *a) for (i = 0; (c = a->val[i]); i++) { struct ao_scheme_cons *n; - ao_scheme_cons_stash(0, cons); - ao_scheme_cons_stash(1, tail); - ao_scheme_string_stash(0, a); + ao_scheme_cons_stash(cons); + ao_scheme_cons_stash(tail); + ao_scheme_string_stash(a); n = ao_scheme_cons_cons(ao_scheme_int_poly(c), AO_SCHEME_NIL); - a = ao_scheme_string_fetch(0); - cons = ao_scheme_cons_fetch(0); - tail = ao_scheme_cons_fetch(1); + a = ao_scheme_string_fetch(); + tail = ao_scheme_cons_fetch(); + cons = ao_scheme_cons_fetch(); if (!n) { cons = NULL; diff --git a/src/scheme/ao_scheme_vector.c b/src/scheme/ao_scheme_vector.c index 419d6765..afdc89a8 100644 --- a/src/scheme/ao_scheme_vector.c +++ b/src/scheme/ao_scheme_vector.c @@ -145,9 +145,9 @@ ao_scheme_list_to_vector(struct ao_scheme_cons *cons) if (ao_scheme_exception) return NULL; - ao_scheme_cons_stash(0, cons); + ao_scheme_cons_stash(cons); vector = ao_scheme_vector_alloc(length, AO_SCHEME_NIL); - cons = ao_scheme_cons_fetch(0); + cons = ao_scheme_cons_fetch(); if (!vector) return NULL; i = 0; @@ -166,9 +166,9 @@ ao_scheme_vector_to_list(struct ao_scheme_vector *vector) struct ao_scheme_cons *cons = NULL; for (i = length; i-- > 0;) { - ao_scheme_poly_stash(2, ao_scheme_vector_poly(vector)); + ao_scheme_vector_stash(vector); cons = ao_scheme_cons_cons(vector->vals[i], ao_scheme_cons_poly(cons)); - vector = ao_scheme_poly_vector(ao_scheme_poly_fetch(2)); + vector = ao_scheme_vector_fetch(); if (!cons) return NULL; } -- cgit v1.2.3 From 9826845f952abe898f029e31cc0f7080708e2eae Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 19 Dec 2017 13:09:24 -0800 Subject: altos/lambdakey-v1.0: Add back and/or macros With scheme shrinking a bit, there's now space for these useful macros. Signed-off-by: Keith Packard --- src/lambdakey-v1.0/ao_lambdakey_const.scheme | 127 ++++++++++++++++++++------- 1 file changed, 93 insertions(+), 34 deletions(-) diff --git a/src/lambdakey-v1.0/ao_lambdakey_const.scheme b/src/lambdakey-v1.0/ao_lambdakey_const.scheme index 50373272..a912b8ae 100644 --- a/src/lambdakey-v1.0/ao_lambdakey_const.scheme +++ b/src/lambdakey-v1.0/ao_lambdakey_const.scheme @@ -49,7 +49,7 @@ ) 'append) -(append '(a b c) '(d e f) '(g h i)) +(append '(a) '(b)) ; ; Define a variable without returning the value @@ -66,7 +66,7 @@ (macro (a . b) ; check for alternate lambda definition form - (cond ((list? a) + (cond ((pair? a) (set! b (cons lambda (cons (cdr a) b))) (set! a (car a)) @@ -92,26 +92,86 @@ 'define ) + ; boolean operators + +(begin + (def! or + (macro a + (def! _or + (lambda (a) + (cond ((null? a) #f) + ((null? (cdr a)) + (car a)) + (else + (list + cond + (list + (car a)) + (list + 'else + (_or (cdr a)) + ) + ) + ) + ) + ) + ) + (_or a))) + 'or) + + ; execute to resolve macros + +(or #f #t) + +(begin + (def! and + (macro a + (def! _and + (lambda (a) + (cond ((null? a) #t) + ((null? (cdr a)) + (car a)) + (else + (list + cond + (list + (car a) + (_and (cdr a)) + ) + ) + ) + ) + ) + ) + (_and a) + ) + ) + 'and) + + ; execute to resolve macros + +(and #t #f) + ; basic list accessors -(define (caar l) (car (car l))) +(define (caar a) (car (car a))) -(define (cadr l) (car (cdr l))) +(define (cadr a) (car (cdr a))) -(define (cdar l) (cdr (car l))) +; (define (cdar a) (cdr (car a))) ; (if ) ; (if Date: Tue, 19 Dec 2017 16:19:40 -0800 Subject: altos/easymini-v2.0: Adapt to final hardware pin assignment changes Beeper moved from PB0 to PB1 (Tim3 CH4) Drogue fire moved from PB6 to PB3 Bootloader moved from PB1 to PB6 Signed-off-by: Keith Packard --- src/easymini-v2.0/ao_pins.h | 10 +++++----- src/easymini-v2.0/flash-loader/ao_pins.h | 4 ++-- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/easymini-v2.0/ao_pins.h b/src/easymini-v2.0/ao_pins.h index 2ec0e90b..47eb577e 100644 --- a/src/easymini-v2.0/ao_pins.h +++ b/src/easymini-v2.0/ao_pins.h @@ -60,11 +60,11 @@ #define HAS_IGNITE 1 #define HAS_IGNITE_REPORT 1 -/* Beeper is on Tim3 CH3 */ +/* Beeper is on Tim3 CH4 */ #define BEEPER_TIMER 3 -#define BEEPER_CHANNEL 3 +#define BEEPER_CHANNEL 4 #define BEEPER_PORT (&stm_gpiob) -#define BEEPER_PIN 0 +#define BEEPER_PIN 1 #define BEEPER_AFR STM_AFR_AF1 /* SPI */ @@ -130,8 +130,8 @@ struct ao_adc { #define AO_IGNITER_CLOSED 400 #define AO_IGNITER_OPEN 60 -#define AO_IGNITER_DROGUE_PORT (&stm_gpiob) -#define AO_IGNITER_DROGUE_PIN 6 +#define AO_IGNITER_DROGUE_PORT (&stm_gpioa) +#define AO_IGNITER_DROGUE_PIN 3 #define AO_IGNITER_SET_DROGUE(v) ao_gpio_set(AO_IGNITER_DROGUE_PORT, AO_IGNITER_DROGUE_PIN, AO_IGNITER_DROGUE, v) #define AO_IGNITER_MAIN_PORT (&stm_gpiob) diff --git a/src/easymini-v2.0/flash-loader/ao_pins.h b/src/easymini-v2.0/flash-loader/ao_pins.h index 3098fc22..9cba43e5 100644 --- a/src/easymini-v2.0/flash-loader/ao_pins.h +++ b/src/easymini-v2.0/flash-loader/ao_pins.h @@ -21,11 +21,11 @@ #include -/* pin 5 (PB1) on debug header to gnd for boot mode */ +/* pin 27 (PB6) on debug header to gnd for boot mode */ #define AO_BOOT_PIN 1 #define AO_BOOT_APPLICATION_GPIO stm_gpiob -#define AO_BOOT_APPLICATION_PIN 1 +#define AO_BOOT_APPLICATION_PIN 6 #define AO_BOOT_APPLICATION_VALUE 1 #define AO_BOOT_APPLICATION_MODE AO_EXTI_MODE_PULL_UP -- cgit v1.2.3 From 342132a8869d530b6893bb84becf03cb30490600 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 19 Dec 2017 16:21:23 -0800 Subject: ao-bringup: turnon_easymini was left with dfu_util disabled This was presumably changed for some test and left in the wrong state. Signed-off-by: Keith Packard --- ao-bringup/turnon_easymini | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ao-bringup/turnon_easymini b/ao-bringup/turnon_easymini index 9b66dc5e..7db72665 100755 --- a/ao-bringup/turnon_easymini +++ b/ao-bringup/turnon_easymini @@ -54,7 +54,7 @@ ALTOS_FILE=~/altusmetrumllc/Binaries/easymini-v2.0-*.elf echo $DFU_UTIL -a 0 -s 0x08000000:leave -D $FLASH_FILE -#$DFU_UTIL -a 0 -s 0x08000000:leave -D $FLASH_FILE || exit 1 +$DFU_UTIL -a 0 -s 0x08000000:leave -D $FLASH_FILE || exit 1 sleep 2 -- cgit v1.2.3 From 99299986e194337b05ee81cfb7c4aa1cb9e9a74e Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 19 Dec 2017 16:56:33 -0800 Subject: altos/attiny: Add ADC implementation It's primitive, but might serve to read ADC values. Untested. Signed-off-by: Keith Packard --- src/attiny/ao_adc_attiny.c | 48 ++++++++++++++++++++++++++++++++++++++++++++++ src/attiny/ao_arch.h | 3 +++ 2 files changed, 51 insertions(+) create mode 100644 src/attiny/ao_adc_attiny.c diff --git a/src/attiny/ao_adc_attiny.c b/src/attiny/ao_adc_attiny.c new file mode 100644 index 00000000..3a835d13 --- /dev/null +++ b/src/attiny/ao_adc_attiny.c @@ -0,0 +1,48 @@ +/* + * Copyright © 2017 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include + +/* + * ATtiny ADC interface + */ + +uint16_t +ao_adc_read(uint8_t mux) +{ + uint8_t low, high; + + /* Set the mux */ + ADMUX = mux; + + /* Start conversion */ + ADCSRA = ((1 << ADEN) | + (1 << ADSC) | + (0 << ADATE) | + (0 << ADIF) | + (0 << ADIE) | + (0 << ADPS2) | + (0 << ADPS1) | + (0 << ADPS0)); + + /* Await conversion complete */ + while ((ADCSRA & (1 << ADSC)) != 0) + ; + + /* Read low first */ + low = ADCL; + high = ADCH; + + return (((uint16_t) high) << 8) | low; +} diff --git a/src/attiny/ao_arch.h b/src/attiny/ao_arch.h index 3a34f417..68f5702d 100644 --- a/src/attiny/ao_arch.h +++ b/src/attiny/ao_arch.h @@ -85,4 +85,7 @@ ao_eeprom_read(uint16_t addr, void *buf, uint16_t len); void ao_eeprom_write(uint16_t addr, void *buf, uint16_t len); +uint16_t +ao_adc_read(uint8_t mux); + #endif /* _AO_ARCH_H_ */ -- cgit v1.2.3 From 46304aa257635d14afc4d8567eedba0f93a5742f Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 19 Dec 2017 16:57:33 -0800 Subject: altos/micropeak: Remove all compiler results Not just the current version. Signed-off-by: Keith Packard --- src/micropeak/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/micropeak/Makefile b/src/micropeak/Makefile index ac00f635..6e8cae14 100644 --- a/src/micropeak/Makefile +++ b/src/micropeak/Makefile @@ -103,7 +103,7 @@ ao_product.o: ao_product.c ao_product.h distclean: clean clean: - rm -f *.o $(PROG) $(HEX) $(SCRIPT) + rm -f *.o *.elf *.ihx $(SCRIPT) rm -f ao_product.h publish: $(PUBLISH_HEX) $(PUBLISH_SCRIPT) -- cgit v1.2.3 From 4bcdc106df2c5e8572570e57b4d97121df94799a Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 21 Dec 2017 17:36:24 -0800 Subject: Doc updates for version 1.8.4 Signed-off-by: Keith Packard --- doc/Makefile | 1 + doc/RELNOTES | 6 ++---- doc/altusmetrum-docinfo.xml | 7 +++++++ doc/easymini-docinfo.xml | 7 +++++++ doc/easymini-release-notes.inc | 4 ++++ doc/release-notes-1.8.4.inc | 9 +++++++++ doc/release-notes.inc | 5 +++++ doc/telegps-release-notes.inc | 5 +++++ 8 files changed, 40 insertions(+), 4 deletions(-) create mode 100644 doc/release-notes-1.8.4.inc diff --git a/doc/Makefile b/doc/Makefile index aa266e75..7d33149d 100644 --- a/doc/Makefile +++ b/doc/Makefile @@ -3,6 +3,7 @@ # RELNOTES_INC=\ + release-notes-1.8.4.inc \ release-notes-1.8.3.inc \ release-notes-1.8.2.inc \ release-notes-1.8.1.inc \ diff --git a/doc/RELNOTES b/doc/RELNOTES index 8f7d2540..c3980882 100644 --- a/doc/RELNOTES +++ b/doc/RELNOTES @@ -1,7 +1,6 @@ Creating documentation for a new release of AltOS -* Write release notes in release-notes-${version}.inc. Write docinfo - for release notes in release-notes-${version}-docinfo.xml. Add to +* Write release notes in release-notes-${version}.inc. Add to Makefile * Add references to that as appropriate from each of the @@ -30,5 +29,4 @@ Creating documentation for a new release of AltOS telegps-docinfo.xml telemetry-docinfo.xml -* Add release-notes-${version}.inc and - release-notes-${version}-docinfo.xml to git +* Add release-notes-${version}.inc to git diff --git a/doc/altusmetrum-docinfo.xml b/doc/altusmetrum-docinfo.xml index 3b0793b8..235111fc 100644 --- a/doc/altusmetrum-docinfo.xml +++ b/doc/altusmetrum-docinfo.xml @@ -46,6 +46,13 @@ + + 1.8.4 + 20 Dec 2017 + + Support EasyMini v2.0 hardware. + + 1.8.3 11 Dec 2017 diff --git a/doc/easymini-docinfo.xml b/doc/easymini-docinfo.xml index cf3f27d2..85baba1e 100644 --- a/doc/easymini-docinfo.xml +++ b/doc/easymini-docinfo.xml @@ -38,6 +38,13 @@ + + 1.8.4 + 20 Dec 2017 + + Support EasyMini v2.0 hardware. + + 1.6.3 21 April 2016 diff --git a/doc/easymini-release-notes.inc b/doc/easymini-release-notes.inc index f4f45fd7..dae928a6 100644 --- a/doc/easymini-release-notes.inc +++ b/doc/easymini-release-notes.inc @@ -1,5 +1,9 @@ [appendix] == Release Notes + :leveloffset: 2 + include::release-notes-1.8.4.raw[] + + <<<< :leveloffset: 2 include::release-notes-1.8.3.raw[] diff --git a/doc/release-notes-1.8.4.inc b/doc/release-notes-1.8.4.inc new file mode 100644 index 00000000..f8cb4f11 --- /dev/null +++ b/doc/release-notes-1.8.4.inc @@ -0,0 +1,9 @@ += Release Notes for Version 1.8.4 +:toc!: +:doctype: article + + Version 1.8.4 includes support for EasyMini version 2.0 + + == AltOS + + * Support for EasyMini version 2.0 hardware. diff --git a/doc/release-notes.inc b/doc/release-notes.inc index 1c177afa..50b27ab5 100644 --- a/doc/release-notes.inc +++ b/doc/release-notes.inc @@ -1,6 +1,11 @@ [appendix] == Release Notes + :leveloffset: 2 + include::release-notes-1.8.4.raw[] + + <<<< + :leveloffset: 2 include::release-notes-1.8.3.raw[] diff --git a/doc/telegps-release-notes.inc b/doc/telegps-release-notes.inc index 0c506c28..5c5da8f6 100644 --- a/doc/telegps-release-notes.inc +++ b/doc/telegps-release-notes.inc @@ -1,6 +1,11 @@ [appendix] == Release Notes + :leveloffset: 2 + include::release-notes-1.8.4.raw[] + + <<<< + :leveloffset: 2 include::release-notes-1.8.3.raw[] -- cgit v1.2.3 From 87aab99521dc44d1d29fbb0b7f227f868f074836 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 21 Dec 2017 17:37:10 -0800 Subject: Bump for version 1.8.4 Signed-off-by: Keith Packard --- configure.ac | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/configure.ac b/configure.ac index 02fca439..7f27dfad 100644 --- a/configure.ac +++ b/configure.ac @@ -18,13 +18,13 @@ dnl dnl Process this file with autoconf to create configure. AC_PREREQ(2.57) -AC_INIT([altos], 1.8.3) +AC_INIT([altos], 1.8.4) ANDROID_VERSION=16 AC_CONFIG_SRCDIR([src/kernel/ao.h]) AM_INIT_AUTOMAKE([foreign dist-bzip2]) AM_MAINTAINER_MODE -RELEASE_DATE=2017-12-11 +RELEASE_DATE=2017-12-21 AC_SUBST(RELEASE_DATE) VERSION_DASH=`echo $VERSION | sed 's/\./-/g'` -- cgit v1.2.3