diff options
89 files changed, 773 insertions, 10091 deletions
@@ -32,6 +32,8 @@ These are Bdale's notes on how to do a release. - make sure build environment is up to date sudo cowbuilder --update + - make sure ~/web/altusmetrum has no pending pullable commits + git checkout master - update the version in configure.ac if Keith hasn't already @@ -120,7 +122,7 @@ These are Bdale's notes on how to do a release. src/telebt-v4.0/flash-loader/{*.elf,*.bin} \ src/teledongle-v3.0/flash-loader/*.elf \ src/telegps-v1.0/flash-loader/*.elf \ - src/telegps-v2.0/flash-loader/*.elf \ + src/telegps-v2.0/flash-loader/{*.elf,*.bin} \ src/telemega-v1.0/flash-loader/*.elf \ src/telemega-v2.0/flash-loader/*.elf \ src/telemega-v3.0/flash-loader/*.elf \ diff --git a/altoslib/AltosFlash.java b/altoslib/AltosFlash.java index c8db1f77..9bf0da25 100644 --- a/altoslib/AltosFlash.java +++ b/altoslib/AltosFlash.java @@ -254,7 +254,7 @@ public class AltosFlash extends AltosProgrammer { clock_init(); int remain = image.data.length; - int flash_addr = image.address; + int flash_addr = (int) image.address; int image_start = 0; action("start", 0); @@ -295,7 +295,7 @@ public class AltosFlash extends AltosProgrammer { if (!aborted) { action("done", 100); if (debug != null) { - debug.set_pc(image.address); + debug.set_pc((int) image.address); debug.resume(); } } @@ -331,12 +331,16 @@ public class AltosFlash extends AltosProgrammer { rom_config = romconfig; } - public AltosRomconfig romconfig() throws InterruptedException { + public AltosRomconfig target_romconfig() throws InterruptedException { if (!check_rom_config()) return null; return rom_config; } + public AltosRomconfig image_romconfig() { + return new AltosRomconfig(image); + } + public AltosFlash(File file, AltosLink link, AltosFlashListener listener) throws IOException, FileNotFoundException, InterruptedException { this.file = file; diff --git a/altoslib/AltosHexfile.java b/altoslib/AltosHexfile.java index 7ab121ad..6aa98383 100644 --- a/altoslib/AltosHexfile.java +++ b/altoslib/AltosHexfile.java @@ -46,7 +46,7 @@ class HexFileInputStream extends PushbackInputStream { } class HexRecord implements Comparable<Object> { - public int address; + public long address; public int type; public byte checksum; public byte[] data; @@ -110,7 +110,14 @@ class HexRecord implements Comparable<Object> { public int compareTo(Object other) { HexRecord o = (HexRecord) other; - return address - o.address; + + long diff = address - o.address; + + if (diff > 0) + return 1; + if (diff < 0) + return -1; + return 0; } public String toString() { @@ -119,8 +126,8 @@ class HexRecord implements Comparable<Object> { public HexRecord(HexFileInputStream input) throws IOException, EOFException { read_state state = read_state.marker; - int nhexbytes = 0; - int hex = 0; + long nhexbytes = 0; + long hex = 0; int ndata = 0; byte got_checksum; @@ -154,7 +161,7 @@ class HexRecord implements Comparable<Object> { switch (state) { case length: - data = new byte[hex]; + data = new byte[(int) hex]; state = read_state.address; nhexbytes = 4; break; @@ -164,7 +171,7 @@ class HexRecord implements Comparable<Object> { nhexbytes = 2; break; case type: - type = hex; + type = (int) hex; if (data.length > 0) state = read_state.data; else @@ -211,12 +218,21 @@ class HexRecord implements Comparable<Object> { } public class AltosHexfile { - public int address; + public long address; + public long max_address; public byte[] data; LinkedList<AltosHexsym> symlist = new LinkedList<AltosHexsym>(); - public byte get_byte(int a) { - return data[a - address]; + public byte get_byte(long a) { + return data[(int) (a - address)]; + } + + public int get_u8(long a) { + return ((int) get_byte(a)) & 0xff; + } + + public int get_u16(long a) { + return get_u8(a) | (get_u8(a+1) << 8); } /* CC1111-based products have the romconfig stuff located @@ -237,6 +253,15 @@ public class AltosHexfile { new AltosHexsym("ao_usb_descriptors", ao_usb_descriptors_addr) }; + static final int AO_USB_DESC_DEVICE = 1; + static final int AO_USB_DESC_STRING = 3; + + static final int AO_ROMCONFIG_VERSION_INDEX = 0; + static final int AO_ROMCONFIG_CHECK_INDEX = 1; + static final int AO_SERIAL_NUMBER_INDEX = 2; + static final int AO_RADIO_CAL_INDEX = 3; + static final int AO_USB_DESCRIPTORS_INDEX = 4; + private void add_cc_symbols() { for (int i = 0; i < cc_symbols.length; i++) symlist.add(cc_symbols[i]); @@ -262,6 +287,92 @@ public class AltosHexfile { return null; } + private long find_usb_descriptors() { + AltosHexsym usb_descriptors = lookup_symbol("ao_usb_descriptors"); + long a; + + if (usb_descriptors == null) + return -1; + + /* Walk the descriptors looking for the device */ + a = usb_descriptors.address; + while (get_u8(a+1) != AO_USB_DESC_DEVICE) { + int delta = get_u8(a); + a += delta; + if (delta == 0 || a >= max_address) + return -1; + } + return a; + } + + public AltosUsbId find_usb_id() { + long a = find_usb_descriptors(); + + if (a == -1) + return null; + + /* Walk the descriptors looking for the device */ + while (get_u8(a+1) != AO_USB_DESC_DEVICE) { + int delta = get_u8(a); + a += delta; + if (delta == 0 || a >= max_address) + return null; + } + + return new AltosUsbId(get_u16(a + 8), + get_u16(a + 10)); + } + + public String find_usb_product() { + long a = find_usb_descriptors(); + int num_strings; + int product_string; + + if (a == -1) + return null; + + product_string = get_u8(a+15); + + /* Walk the descriptors looking for the device */ + num_strings = 0; + for (;;) { + if (get_u8(a+1) == AO_USB_DESC_STRING) { + ++num_strings; + if (num_strings == product_string + 1) + break; + } + + int delta = get_u8(a); + a += delta; + if (delta == 0 || a >= max_address) + return null; + } + + int product_len = get_u8(a); + + System.out.printf("Product is at %x length %d\n", a, product_len); + + for (int i = 0; i < product_len; i++) + System.out.printf(" %2d: %02x\n", i, get_u8(a+i)); + + if (product_len <= 0) + return null; + + String product = ""; + + for (int i = 0; i < product_len - 2; i += 2) { + int c = get_u16(a + 2 + i); + + System.out.printf("character %x\n", c); + + product += Character.toString((char) c); + } + + System.out.printf("product %s\n", product); + + return product; + } + private String make_string(byte[] data, int start, int length) { String s = ""; for (int i = 0; i < length; i++) @@ -269,9 +380,10 @@ public class AltosHexfile { return s; } - public AltosHexfile(byte[] bytes, int offset) { + public AltosHexfile(byte[] bytes, long offset) { data = bytes; address = offset; + max_address = address + bytes.length; } public AltosHexfile(FileInputStream file) throws IOException { @@ -335,7 +447,8 @@ public class AltosHexfile { throw new IOException("hex file too large"); data = new byte[(int) (bound - base)]; - address = (int) base; + address = base; + max_address = bound; Arrays.fill(data, (byte) 0xff); /* Paint the records into the new array */ @@ -366,4 +479,4 @@ public class AltosHexfile { } } } -}
\ No newline at end of file +} diff --git a/altoslib/AltosProgrammer.java b/altoslib/AltosProgrammer.java index 0a828a32..e4f57578 100644 --- a/altoslib/AltosProgrammer.java +++ b/altoslib/AltosProgrammer.java @@ -28,7 +28,9 @@ public abstract class AltosProgrammer { abstract public void abort(); - abstract public AltosRomconfig romconfig() throws InterruptedException; + abstract public AltosRomconfig target_romconfig() throws InterruptedException; + + abstract public AltosRomconfig image_romconfig(); abstract public void set_romconfig(AltosRomconfig config); -}
\ No newline at end of file +} diff --git a/altoslib/AltosRomconfig.java b/altoslib/AltosRomconfig.java index 46ee2b6e..1fbb4115 100644 --- a/altoslib/AltosRomconfig.java +++ b/altoslib/AltosRomconfig.java @@ -26,20 +26,31 @@ public class AltosRomconfig { public int check; public int serial_number; public int radio_calibration; + public AltosUsbId usb_id; + public String usb_product; - static private int find_offset(AltosHexfile hexfile, String name, int len) throws AltosNoSymbol { + static private long find_address(AltosHexfile hexfile, String name, int len) throws AltosNoSymbol { AltosHexsym symbol = hexfile.lookup_symbol(name); - if (symbol == null) - throw new AltosNoSymbol(name); - int offset = (int) symbol.address - hexfile.address; - if (offset < 0 || hexfile.data.length < offset + len) + if (symbol == null) { + System.out.printf("no symbol %s\n", name); throw new AltosNoSymbol(name); - return offset; + } + if (hexfile.address <= symbol.address && symbol.address + len < hexfile.max_address) { + System.out.printf("%s: %x\n", name, symbol.address); + return symbol.address; + } + System.out.printf("invalid symbol addr %x range is %x - %x\n", + symbol.address, hexfile.address, hexfile.max_address); + throw new AltosNoSymbol(name); + } + + static private int find_offset(AltosHexfile hexfile, String name, int len) throws AltosNoSymbol { + return (int) (find_address(hexfile, name, len) - hexfile.address); } static int get_int(AltosHexfile hexfile, String name, int len) throws AltosNoSymbol { byte[] bytes = hexfile.data; - int start = find_offset(hexfile, name, len); + int start = (int) find_offset(hexfile, name, len); int v = 0; int o = 0; @@ -112,13 +123,17 @@ public class AltosRomconfig { public AltosRomconfig(AltosHexfile hexfile) { try { + System.out.printf("Attempting symbols\n"); version = get_int(hexfile, ao_romconfig_version, 2); + System.out.printf("version %d\n", version); check = get_int(hexfile, ao_romconfig_check, 2); + System.out.printf("check %d\n", check); if (check == (~version & 0xffff)) { switch (version) { case 2: case 1: serial_number = get_int(hexfile, ao_serial_number, 2); + System.out.printf("serial %d\n", serial_number); try { radio_calibration = get_int(hexfile, ao_radio_cal, 4); } catch (AltosNoSymbol missing) { @@ -128,6 +143,19 @@ public class AltosRomconfig { break; } } + System.out.printf("attempting usbid\n"); + usb_id = hexfile.find_usb_id(); + if (usb_id == null) + System.out.printf("No usb id\n"); + else + System.out.printf("usb id: %04x:%04x\n", + usb_id.vid, usb_id.pid); + usb_product = hexfile.find_usb_product(); + if (usb_product == null) + System.out.printf("No usb product\n"); + else + System.out.printf("usb product: %s\n", usb_product); + } catch (AltosNoSymbol missing) { valid = false; } @@ -137,9 +165,16 @@ public class AltosRomconfig { ao_romconfig_version, ao_romconfig_check, ao_serial_number, - ao_radio_cal + ao_radio_cal, + ao_usb_descriptors, }; + private static int fetch_len(String name) { + if (name.equals(ao_usb_descriptors)) + return 256; + return 2; + } + private final static String[] required_names = { ao_romconfig_version, ao_romconfig_check, @@ -153,13 +188,16 @@ public class AltosRomconfig { return false; } - public static int fetch_base(AltosHexfile hexfile) throws AltosNoSymbol { - int base = 0x7fffffff; + public static long fetch_base(AltosHexfile hexfile) throws AltosNoSymbol { + long base = 0xffffffffL; for (String name : fetch_names) { try { - int addr = find_offset(hexfile, name, 2) + hexfile.address; + int len = fetch_len(name); + long addr = find_address(hexfile, name, len); + if (addr < base) base = addr; + System.out.printf("symbol %s at %x base %x\n", name, addr, base); } catch (AltosNoSymbol ns) { if (name_required(name)) throw (ns); @@ -168,19 +206,22 @@ public class AltosRomconfig { return base; } - public static int fetch_bounds(AltosHexfile hexfile) throws AltosNoSymbol { - int bounds = 0; + public static long fetch_bounds(AltosHexfile hexfile) throws AltosNoSymbol { + long bounds = 0; for (String name : fetch_names) { try { - int addr = find_offset(hexfile, name, 2) + hexfile.address; + int len = fetch_len(name); + long addr = find_address(hexfile, name, len) + len; if (addr > bounds) bounds = addr; + System.out.printf("symbol %s at %x bounds %x\n", name, addr, bounds); } catch (AltosNoSymbol ns) { if (name_required(name)) throw (ns); } } - return bounds + 2; + + return bounds; } public void write (AltosHexfile hexfile) throws IOException { diff --git a/altoslib/AltosSelfFlash.java b/altoslib/AltosSelfFlash.java index 53782172..c7ea147f 100644 --- a/altoslib/AltosSelfFlash.java +++ b/altoslib/AltosSelfFlash.java @@ -45,18 +45,33 @@ public class AltosSelfFlash extends AltosProgrammer { int b; byte[] data = new byte[len]; + System.out.printf("read_memory %x %d\n", addr, len); for (int offset = 0; offset < len; offset += 0x100) { link.printf("R %x\n", addr + offset); byte[] reply = link.get_binary_reply(5000, 0x100); if (reply == null) throw new IOException("Read device memory timeout"); - for (b = 0; b < len; b++) + for (b = 0; b < 0x100 && b + offset < len; b++) data[b+offset] = reply[b]; } return data; } + AltosHexfile read_hexfile(long addr, int len) throws InterruptedException { + try { + byte[] mem = read_memory(addr, len); + + AltosHexfile hexfile = new AltosHexfile(mem, addr); + + if (image != null) + hexfile.add_symbols(image); + return hexfile; + } catch (IOException ie) { + return null; + } + } + void write_memory(long addr, byte[] data, int start, int len) { int b; link.printf("W %x\n", addr); @@ -143,18 +158,14 @@ public class AltosSelfFlash extends AltosProgrammer { private AltosHexfile get_rom() throws InterruptedException { try { - int base = AltosRomconfig.fetch_base(image); - int bounds = AltosRomconfig.fetch_bounds(image); - byte[] data = read_memory(base, bounds - base); - AltosHexfile hexfile = new AltosHexfile(data, base); - hexfile.add_symbols(image); - return hexfile; - } catch (AltosNoSymbol none) { - return null; - } catch (IOException ie) { + long base = AltosRomconfig.fetch_base(image); + long bounds = AltosRomconfig.fetch_bounds(image); + + System.out.printf("rom base %x bounds %x\n", base, bounds); + return read_hexfile(base, (int) (bounds - base)); + } catch (AltosNoSymbol ns) { return null; } - } public boolean check_rom_config() throws InterruptedException { @@ -173,12 +184,16 @@ public class AltosSelfFlash extends AltosProgrammer { rom_config = romconfig; } - public AltosRomconfig romconfig() throws InterruptedException { + public AltosRomconfig target_romconfig() throws InterruptedException { if (!check_rom_config()) return null; return rom_config; } + public AltosRomconfig image_romconfig() { + return new AltosRomconfig(image); + } + public AltosSelfFlash(File file, AltosLink link, AltosFlashListener listener) throws IOException, FileNotFoundException, InterruptedException { this.file = file; @@ -187,4 +202,4 @@ public class AltosSelfFlash extends AltosProgrammer { input = new FileInputStream(file); image = new AltosHexfile(input); } -}
\ No newline at end of file +} diff --git a/src/scheme/ao_scheme_lex.c b/altoslib/AltosUsbId.java index 266b1fc0..e3794304 100644 --- a/src/scheme/ao_scheme_lex.c +++ b/altoslib/AltosUsbId.java @@ -1,5 +1,5 @@ /* - * Copyright © 2016 Keith Packard <keithp@keithp.com> + * Copyright © 2018 Keith Packard <keithp@keithp.com> * * 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 @@ -12,5 +12,15 @@ * General Public License for more details. */ -#include "ao_scheme.h" +package org.altusmetrum.altoslib_12; +public class AltosUsbId { + public int vid; + public int pid; + + + public AltosUsbId(int vid, int pid) { + this.vid = vid; + this.pid = pid; + } +} diff --git a/altoslib/Makefile.am b/altoslib/Makefile.am index 2a1cb8e4..7c5d767d 100644 --- a/altoslib/Makefile.am +++ b/altoslib/Makefile.am @@ -99,6 +99,7 @@ altoslib_JAVA = \ AltosRomconfig.java \ AltosSavedState.java \ AltosSelfFlash.java \ + AltosUsbId.java \ AltosSensorMM.java \ AltosSensorEMini.java \ AltosSensorTM.java \ diff --git a/altosui/Makefile.am b/altosui/Makefile.am index 6f206c3d..805c5550 100644 --- a/altosui/Makefile.am +++ b/altosui/Makefile.am @@ -150,7 +150,8 @@ FIRMWARE_EMEGA_1_0=$(top_srcdir)/src/easymega-v1.0/easymega-v1.0-$(VERSION).ihx FIRMWARE_EMEGA=$(FIRMWARE_EMEGA_1_0) FIRMWARE_TGPS_1_0=$(top_srcdir)/src/telegps-v1.0/telegps-v1.0-$(VERSION).ihx -FIRMWARE_TGPS=$(FIRMWARE_TGPS_1_0) +FIRMWARE_TGPS_2_0=$(top_srcdir)/src/telegps-v2.0/telegps-v2.0-$(VERSION).ihx +FIRMWARE_TGPS=$(FIRMWARE_TGPS_1_0) $(FIRMWARE_TGPS_2_0) FIRMWARE=$(FIRMWARE_TM) $(FIRMWARE_TELEMINI) $(FIRMWARE_TD) $(FIRMWARE_TBT) $(FIRMWARE_TMEGA) $(FIRMWARE_EMINI) $(FIRMWARE_TGPS) $(FIRMWARE_EMEGA) diff --git a/altosui/altos-windows.nsi.in b/altosui/altos-windows.nsi.in index 31139513..23d6f6bd 100644 --- a/altosui/altos-windows.nsi.in +++ b/altosui/altos-windows.nsi.in @@ -128,6 +128,7 @@ Section "Firmware" File "../src/telemini-v1.0/telemini-v1.0-${VERSION}.ihx" File "../src/telemini-v3.0/telemini-v3.0-${VERSION}.ihx" File "../src/telegps-v1.0/telegps-v1.0-${VERSION}.ihx" + File "../src/telegps-v2.0/telegps-v2.0-${VERSION}.ihx" File "../src/teledongle-v0.2/teledongle-v0.2-${VERSION}.ihx" File "../src/teledongle-v3.0/teledongle-v3.0-${VERSION}.ihx" File "../src/telebt-v1.0/telebt-v1.0-${VERSION}.ihx" diff --git a/altosuilib/AltosFlashUI.java b/altosuilib/AltosFlashUI.java index ca089ca8..c717e47c 100644 --- a/altosuilib/AltosFlashUI.java +++ b/altosuilib/AltosFlashUI.java @@ -276,8 +276,37 @@ public class AltosFlashUI return true; } - boolean update_rom_config_info(AltosRomconfig existing_config) { + boolean rom_config_matches (AltosRomconfig a, AltosRomconfig b) { + if (a.usb_id != null && b.usb_id != null && + (a.usb_id.vid != b.usb_id.vid || + a.usb_id.pid != b.usb_id.pid)) + return false; + + if (a.usb_product != null && b.usb_product != null && + !a.usb_product.equals(b.usb_product)) + return false; + + return true; + } + + boolean update_rom_config_info(AltosRomconfig existing_config, AltosRomconfig image_config) { AltosRomconfig new_config; + + if (!rom_config_matches(existing_config, image_config)) { + int ret = JOptionPane.showConfirmDialog(this, + String.format("Device is %04x:%04x %s\nImage is %04x:%04x %s\nFlash anyways?", + existing_config.usb_id.vid, + existing_config.usb_id.pid, + existing_config.usb_product, + image_config.usb_id.vid, + image_config.usb_id.pid, + image_config.usb_product), + "Image doesn't match Device", + JOptionPane.YES_NO_OPTION); + if (ret != JOptionPane.YES_OPTION) + return false; + } + new_config = AltosRomconfigUI.show(frame, existing_config); if (new_config == null) return false; @@ -335,13 +364,15 @@ public class AltosFlashUI else programmer = new AltosSelfFlash(ui.file, link, this); - final AltosRomconfig current_config = programmer.romconfig(); + final AltosRomconfig current_config = programmer.target_romconfig(); + + final AltosRomconfig image_config = programmer.image_romconfig(); final Semaphore await_rom_config = new Semaphore(0); SwingUtilities.invokeLater(new Runnable() { public void run() { ui.programmer = programmer; - ui.update_rom_config_info(current_config); + ui.update_rom_config_info(current_config, image_config); await_rom_config.release(); } }); diff --git a/ao-bringup/test-easymini b/ao-bringup/test-easymini index 7850b550..ddcfcd54 100755 --- a/ao-bringup/test-easymini +++ b/ao-bringup/test-easymini @@ -21,7 +21,7 @@ while [ $found -eq 0 ]; do echo -e '\e[34m'Testing $product $serial $dev'\e[39m' echo "" - ./test-igniters "$dev" drogue main + ./test-igniters-nowait "$dev" drogue main echo "" echo "Testing baro sensor" diff --git a/ao-bringup/test-igniters-nowait b/ao-bringup/test-igniters-nowait new file mode 100755 index 00000000..849f91de --- /dev/null +++ b/ao-bringup/test-igniters-nowait @@ -0,0 +1,26 @@ +#!/bin/sh + +dev="$1" +shift + +for igniter in "$@"; do + pass="n" + while [ $pass != "y" ]; do + + echo "Testing $igniter igniter." + ../ao-tools/ao-test-igniter/ao-test-igniter --tty="$dev" $igniter + + case $? in + 0) + echo "pass" + pass="y" + ;; + *) + echo -n "Failed. Try again. Press enter to continue..." + read foo < /dev/tty + ;; + esac + done +done + +exit 0 diff --git a/ao-bringup/turnon_chaoskey b/ao-bringup/turnon_chaoskey index 4a255bff..d710e5ff 100755 --- a/ao-bringup/turnon_chaoskey +++ b/ao-bringup/turnon_chaoskey @@ -24,14 +24,14 @@ echo "Expectations:" echo "\tChaosKey v$VERSION powered from USB" echo -FLASH_FILE=~/altusmetrumllc/Binaries/loaders/chaoskey-v1.0-altos-flash-*.bin -ALTOS_FILE=~/altusmetrumllc/Binaries/chaoskey-v1.0-*.elf +FLASH_FILE=~/altusmetrumllc/Binaries/chaoskey-v1.0-all-*.bin +#ALTOS_FILE=~/altusmetrumllc/Binaries/chaoskey-v1.0-*.elf $DFU_UTIL -a 0 -s 0x08000000:leave -D $FLASH_FILE || true -sleep 2 +#sleep 2 -$USBLOAD --serial=1 $ALTOS_FILE || exit 1 +#$USBLOAD --serial=1 $ALTOS_FILE || exit 1 sleep 1 diff --git a/ao-bringup/turnon_easymini b/ao-bringup/turnon_easymini index 7db72665..3bef3145 100755 --- a/ao-bringup/turnon_easymini +++ b/ao-bringup/turnon_easymini @@ -52,11 +52,13 @@ ALTOS_FILE=~/altusmetrumllc/Binaries/easymini-v2.0-*.elf #FLASH_FILE=../src/$BASE-v$VERSION/flash-loader/$BASE-v$VERSION-altos-flash-*.elf #ALTOS_FILE=../src/$BASE-v$VERSION/*.ihx -echo $DFU_UTIL -a 0 -s 0x08000000:leave -D $FLASH_FILE +if lsusb -d 0483:df11 | grep -q STM; then + echo $DFU_UTIL -v -v -R -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 -sleep 2 + sleep 2 +fi echo $USBLOAD $ALTOS_FILE diff --git a/ao-tools/ao-chaosread/ao-chaosread.1 b/ao-tools/ao-chaosread/ao-chaosread.1 index ead8afb2..e6ed2fac 100644 --- a/ao-tools/ao-chaosread/ao-chaosread.1 +++ b/ao-tools/ao-chaosread/ao-chaosread.1 @@ -33,6 +33,20 @@ one found. \-l length | --length length Set the amount of data to read. Suffixes 'k', 'M' and 'G' are supported. The default is 1k. +.TP +\-i | --infinite +Read an unlimited amount of data. +.TP +\-b | --bytes +For each 16-bit value read, output bits 1-8 as a byte, don't output +bit 0 or bits 9-15 at all. +.TP +\-c | --cooked +Read whitened data from the device. The default is to read raw data +from the noise source. +.TP +\-r | --raw +Read raw data from the noise source. This is the default. .SH USAGE .I ao-chaosread reads noise data. diff --git a/ao-tools/ao-chaosread/ao-chaosread.c b/ao-tools/ao-chaosread/ao-chaosread.c index 6d860139..8a814a00 100644 --- a/ao-tools/ao-chaosread/ao-chaosread.c +++ b/ao-tools/ao-chaosread/ao-chaosread.c @@ -172,10 +172,11 @@ chaoskey_close(struct chaoskey *ck) free(ck); } -#define ENDPOINT 0x86 +#define COOKED_ENDPOINT 0x85 +#define RAW_ENDPOINT 0x86 int -chaoskey_read(struct chaoskey *ck, void *buffer, int len) +chaoskey_read(struct chaoskey *ck, int endpoint, void *buffer, int len) { uint8_t *buf = buffer; int total = 0; @@ -184,7 +185,7 @@ chaoskey_read(struct chaoskey *ck, void *buffer, int len) int ret; int transferred; - ret = libusb_bulk_transfer(ck->handle, ENDPOINT, buf, len, &transferred, 10000); + ret = libusb_bulk_transfer(ck->handle, endpoint, buf, len, &transferred, 10000); if (ret) { if (total) return total; @@ -205,12 +206,14 @@ static const struct option options[] = { { .name = "length", .has_arg = 1, .val = 'l' }, { .name = "infinite", .has_arg = 0, .val = 'i' }, { .name = "bytes", .has_arg = 0, .val = 'b' }, + { .name = "cooked", .has_arg = 0, .val = 'c' }, + { .name = "raw", .has_arg = 0, .val = 'r' }, { 0, 0, 0, 0}, }; static void usage(char *program) { - fprintf(stderr, "usage: %s [--serial=<serial>] [--length=<length>[kMG]] [--infinite] [--bytes]\n", program); + fprintf(stderr, "usage: %s [--serial=<serial>] [--length=<length>[kMG]] [--infinite] [--bytes] [--cooked] [--raw]\n", program); exit(1); } @@ -228,8 +231,9 @@ main (int argc, char **argv) int this_time; int infinite = 0; int bytes = 0; + int endpoint = RAW_ENDPOINT; - while ((c = getopt_long(argc, argv, "s:l:ib", options, NULL)) != -1) { + while ((c = getopt_long(argc, argv, "s:l:ibcr", options, NULL)) != -1) { switch (c) { case 's': serial = optarg; @@ -252,6 +256,12 @@ main (int argc, char **argv) case 'b': bytes = 1; break; + case 'c': + endpoint = COOKED_ENDPOINT; + break; + case 'r': + endpoint = RAW_ENDPOINT; + break; default: usage(argv[0]); break; @@ -269,7 +279,7 @@ main (int argc, char **argv) this_time = sizeof(buf); if (!infinite && length < sizeof(buf)) this_time = (int) length; - got = chaoskey_read(ck, buf, this_time); + got = chaoskey_read(ck, endpoint, buf, this_time); if (got < 0) { perror("read"); exit(1); diff --git a/ao-tools/ao-usbload/ao-usbload.c b/ao-tools/ao-usbload/ao-usbload.c index 758eb696..31ee138a 100644 --- a/ao-tools/ao-usbload/ao-usbload.c +++ b/ao-tools/ao-usbload/ao-usbload.c @@ -402,9 +402,9 @@ main (int argc, char **argv) old_len = ucs2len(old_product); if (new_len != old_len || memcmp(new_product, old_product, new_len * 2) != 0) { fprintf(stderr, "USB product mismatch (device is "); - putucs2str(new_product, stderr); - fprintf(stderr, ", image is "); putucs2str(old_product, stderr); + fprintf(stderr, ", image is "); + putucs2str(new_product, stderr); fprintf(stderr, ")\n"); done(cc, 1); } diff --git a/configure.ac b/configure.ac index 7f27dfad..82e0f3d0 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.4) -ANDROID_VERSION=16 +AC_INIT([altos], 1.8.5) +ANDROID_VERSION=17 AC_CONFIG_SRCDIR([src/kernel/ao.h]) AM_INIT_AUTOMAKE([foreign dist-bzip2]) AM_MAINTAINER_MODE -RELEASE_DATE=2017-12-21 +RELEASE_DATE=2018-03-17 AC_SUBST(RELEASE_DATE) VERSION_DASH=`echo $VERSION | sed 's/\./-/g'` diff --git a/doc/Makefile b/doc/Makefile index 7d33149d..efa7f9d3 100644 --- a/doc/Makefile +++ b/doc/Makefile @@ -3,6 +3,7 @@ # RELNOTES_INC=\ + release-notes-1.8.5.inc \ release-notes-1.8.4.inc \ release-notes-1.8.3.inc \ release-notes-1.8.2.inc \ diff --git a/doc/altusmetrum-docinfo.xml b/doc/altusmetrum-docinfo.xml index 235111fc..3ea79f8b 100644 --- a/doc/altusmetrum-docinfo.xml +++ b/doc/altusmetrum-docinfo.xml @@ -18,7 +18,7 @@ <surname>Towns</surname> </author> <copyright> - <year>2017</year> + <year>2018</year> <holder>Bdale Garbee and Keith Packard</holder> </copyright> <mediaobject> diff --git a/doc/easymini-release-notes.inc b/doc/easymini-release-notes.inc index dae928a6..2d289b12 100644 --- a/doc/easymini-release-notes.inc +++ b/doc/easymini-release-notes.inc @@ -1,6 +1,10 @@ [appendix] == Release Notes :leveloffset: 2 + include::release-notes-1.8.5.raw[] + + <<<< + :leveloffset: 2 include::release-notes-1.8.4.raw[] <<<< diff --git a/doc/release-notes-1.8.5.inc b/doc/release-notes-1.8.5.inc new file mode 100644 index 00000000..5b940efd --- /dev/null +++ b/doc/release-notes-1.8.5.inc @@ -0,0 +1,18 @@ += Release Notes for Version 1.8.5 +:toc!: +:doctype: article + + Version 1.8.5 includes fixes to the ground software support + for TeleBT v4, along with a few other minor updates. + + == AltOS + + * Fix startup beeps that indicate sensor failures. + + == AltosUI, TeleGPS + + * When updating device firmware, make sure selected firmware + matches target device. + + * Correct Bluetooth device matching when looking for TeleBT + devices. diff --git a/doc/release-notes.inc b/doc/release-notes.inc index 50b27ab5..b7c7f5a7 100644 --- a/doc/release-notes.inc +++ b/doc/release-notes.inc @@ -1,6 +1,9 @@ [appendix] == Release Notes + :leveloffset: 2 + include::release-notes-1.8.5.raw[] + <<<< :leveloffset: 2 include::release-notes-1.8.4.raw[] diff --git a/doc/telegps-release-notes.inc b/doc/telegps-release-notes.inc index 5c5da8f6..f451c2c8 100644 --- a/doc/telegps-release-notes.inc +++ b/doc/telegps-release-notes.inc @@ -2,10 +2,13 @@ == Release Notes :leveloffset: 2 - include::release-notes-1.8.4.raw[] + include::release-notes-1.8.5.raw[] <<<< + :leveloffset: 2 + include::release-notes-1.8.4.raw[] + <<<< :leveloffset: 2 include::release-notes-1.8.3.raw[] diff --git a/libaltos/libaltos_common.c b/libaltos/libaltos_common.c index f577de02..713a775c 100644 --- a/libaltos/libaltos_common.c +++ b/libaltos/libaltos_common.c @@ -76,24 +76,39 @@ altos_putchar(struct altos_file *file, char c) } struct bt_vendor_map { - char vendor[10]; - int port; + const char vendor[10]; + int port; }; static const struct bt_vendor_map altos_bt_vendor_map[] = { { .vendor = "00:12:6f:", 1 }, /* Rayson */ - { .vendor = "8C:DE:52:", 6 }, /* ISSC */ - { .vendor = "D8:80:39:", 6 }, /* Microchip */ + { .vendor = "8c:de:52:", 6 }, /* ISSC */ + { .vendor = "d8:80:39:", 6 }, /* Microchip */ }; #define NUM_BT_VENDOR_MAP (sizeof altos_bt_vendor_map / sizeof altos_bt_vendor_map[0]) #define BT_PORT_DEFAULT 1 +static inline int +ao_tolower(int c) { + if ('A' <= c && c <= 'Z') + return c + 'a' - 'A'; + return c; +} + int altos_bt_port(struct altos_bt_device *device) { - unsigned i; - for (i = 0; i < NUM_BT_VENDOR_MAP; i++) - if (strncmp (device->addr, altos_bt_vendor_map[i].vendor, strlen(altos_bt_vendor_map[i].vendor)) == 0) - return altos_bt_vendor_map[i].port; + unsigned i, j; + for (i = 0; i < NUM_BT_VENDOR_MAP; i++) { + const char *vendor = altos_bt_vendor_map[i].vendor; + for (j = 0; ; j++) { + if (vendor[j] == '\0') + return altos_bt_vendor_map[i].port; + if (device->addr[j] == '\0') + break; + if (ao_tolower(device->addr[j]) != vendor[j]) + break; + } + } return BT_PORT_DEFAULT; } diff --git a/libaltos/libaltos_windows.c b/libaltos/libaltos_windows.c index 4f9f1807..846e2217 100644 --- a/libaltos/libaltos_windows.c +++ b/libaltos/libaltos_windows.c @@ -639,7 +639,7 @@ static void ba2str(BTH_ADDR ba, char *str) { - sprintf(str, "%02x:%02x:%02x:%02x:%02x:%02x", + sprintf(str, "%02X:%02X:%02X:%02X:%02X:%02X", get_byte(ba, 0), get_byte(ba, 1), get_byte(ba, 2), @@ -755,8 +755,8 @@ altos_bt_open(struct altos_bt_device *device) altos_set_last_winsock_error(); closesocket(file->socket); free(file); + log_message("Connection attempted to address %s port %d\n", device->addr, sockaddr_bth.port); return NULL; } return &file->file; } - diff --git a/src/chaoskey-v1.0/Makefile b/src/chaoskey-v1.0/Makefile index f2c168ba..dea5b483 100644 --- a/src/chaoskey-v1.0/Makefile +++ b/src/chaoskey-v1.0/Makefile @@ -51,12 +51,13 @@ CFLAGS = $(PRODUCT_DEF) $(STMF0_CFLAGS) -g -Os PROGNAME=chaoskey-v1.0 PROG=$(PROGNAME)-$(VERSION).elf HEX=$(PROGNAME)-$(VERSION).ihx +BIN=$(PROGNAME)-all-$(VERSION).bin METAINFO=org.altusmetrum.ChaosKey.metainfo.xml SRC=$(ALTOS_SRC) ao_chaoskey.c OBJ=$(SRC:.c=.o) -all: $(PROG) $(HEX) +all: $(PROG) $(HEX) $(BIN) $(PROG): Makefile $(OBJ) altos.ld $(call quiet,CC) $(LDFLAGS) $(CFLAGS) -o $(PROG) $(OBJ) $(LIBS) @@ -66,6 +67,12 @@ ao_product.h: ao-make-product.5c ../Version $(OBJ): $(INC) +$(BIN): $(PROG) $(LOADER) + $(MAKEBIN) --output=$@ --base=$(FLASH_ADDR) $(LOADER) $(PROG) + +$(LOADER): + +cd flash-loader && make + %.cab: $(PROG) $(HEX) $(METAINFO) gcab --create --nopath $@ $(PROG) $(HEX) $(METAINFO) diff --git a/src/drivers/ao_trng_send.c b/src/drivers/ao_trng_send.c index 7cda053d..4e02c0ce 100644 --- a/src/drivers/ao_trng_send.c +++ b/src/drivers/ao_trng_send.c @@ -31,6 +31,29 @@ static AO_TICK_TYPE trng_power_time; static uint8_t random_mutex; +static void +ao_trng_start(void) +{ + if (!trng_running) { + ao_mutex_get(&random_mutex); + if (!trng_running) { + AO_TICK_TYPE delay; + + delay = trng_power_time + TRNG_ENABLE_DELAY - ao_time(); + if (delay > TRNG_ENABLE_DELAY) + delay = TRNG_ENABLE_DELAY; + + /* Delay long enough for the HV power supply + * to stabilize so that the first bits we read + * aren't of poor quality + */ + ao_delay(delay); + trng_running = TRUE; + } + ao_mutex_put(&random_mutex); + } +} + #if AO_USB_HAS_IN2 static struct ao_task ao_trng_send_raw_task; @@ -54,34 +77,13 @@ ao_trng_get_raw(uint16_t *buf) static void ao_trng_send_raw(void) { - static uint16_t *buffer[2]; + uint16_t *buffer[2]; int usb_buf_id; - if (!buffer[0]) { - buffer[0] = ao_usb_alloc(); - buffer[1] = ao_usb_alloc(); - if (!buffer[0]) - ao_exit(); - } - - usb_buf_id = 0; + usb_buf_id = ao_usb_alloc2(buffer); for (;;) { - ao_mutex_get(&random_mutex); - if (!trng_running) { - AO_TICK_TYPE delay; - - delay = trng_power_time + TRNG_ENABLE_DELAY - ao_time(); - if (delay > TRNG_ENABLE_DELAY) - delay = TRNG_ENABLE_DELAY; - - /* Delay long enough for the HV power supply - * to stabilize so that the first bits we read - * aren't of poor quality - */ - ao_delay(delay); - trng_running = TRUE; - } + ao_trng_start(); #ifdef AO_LED_TRNG_RAW ao_led_on(AO_LED_TRNG_RAW); #endif @@ -89,9 +91,7 @@ ao_trng_send_raw(void) #ifdef AO_LED_TRNG_RAW ao_led_off(AO_LED_TRNG_RAW); #endif - ao_mutex_put(&random_mutex); - ao_usb_write2(buffer[usb_buf_id], AO_USB_IN_SIZE); - usb_buf_id = 1-usb_buf_id; + usb_buf_id = ao_usb_write2(AO_USB_IN_SIZE); } } @@ -105,7 +105,7 @@ ao_trng_get_cooked(uint16_t *buf) uint16_t i; uint16_t t; uint32_t *rnd = (uint32_t *) (void *) ao_adc_ring; - uint8_t mismatch = 0; + uint8_t mismatch = 1; t = ao_adc_get(AO_USB_IN_SIZE) >> 1; /* one 16-bit value per output byte */ for (i = 0; i < AO_USB_IN_SIZE / sizeof (uint16_t); i++) { @@ -131,20 +131,13 @@ ao_trng_get_cooked(uint16_t *buf) static void ao_trng_send(void) { - static uint16_t *buffer[2]; - int usb_buf_id; - int good_bits; - int failed; - int s; - - if (!buffer[0]) { - buffer[0] = ao_usb_alloc(); - buffer[1] = ao_usb_alloc(); - if (!buffer[0]) - ao_exit(); - } + uint16_t *buffer[2]; + int usb_buf_id; + int good_bits; + int failed; + int s; - usb_buf_id = 0; + usb_buf_id = ao_usb_alloc(buffer); #ifdef AO_TRNG_ENABLE_PORT ao_gpio_set(AO_TRNG_ENABLE_PORT, AO_TRNG_ENABLE_BIT, AO_TRNG_ENABLE_PIN, 1); @@ -191,21 +184,7 @@ ao_trng_send(void) #endif for (;;) { - ao_mutex_get(&random_mutex); - if (!trng_running) { - AO_TICK_TYPE delay; - - delay = trng_power_time + TRNG_ENABLE_DELAY - ao_time(); - if (delay > TRNG_ENABLE_DELAY) - delay = TRNG_ENABLE_DELAY; - - /* Delay long enough for the HV power supply - * to stabilize so that the first bits we read - * aren't of poor quality - */ - ao_delay(delay); - trng_running = TRUE; - } + ao_trng_start(); #ifdef AO_LED_TRNG_COOKED ao_led_on(AO_LED_TRNG_COOKED); #endif @@ -213,14 +192,11 @@ ao_trng_send(void) #ifdef AO_LED_TRNG_COOKED ao_led_off(AO_LED_TRNG_COOKED); #endif - ao_mutex_put(&random_mutex); if (good_bits) { - ao_usb_write(buffer[usb_buf_id], AO_USB_IN_SIZE); - usb_buf_id = 1-usb_buf_id; + usb_buf_id = ao_usb_write(AO_USB_IN_SIZE); failed = 0; } else { failed++; - ao_delay(AO_MS_TO_TICKS(10)); if (failed > 10) { ao_usb_disable(); ao_panic(AO_PANIC_DMA); diff --git a/src/kernel/ao_beep.h b/src/kernel/ao_beep.h index 085dd5b1..1306af62 100644 --- a/src/kernel/ao_beep.h +++ b/src/kernel/ao_beep.h @@ -42,9 +42,15 @@ #else #define AO_BEEP_MID AO_BEEP_MID_DEFAULT #endif + +#define AO_BEEP_MID_PANIC AO_BEEP_MID_DEFAULT + #define AO_BEEP_LOW AO_BEEP_MID * 150 / 94 /* 2500Hz */ #define AO_BEEP_HIGH AO_BEEP_MID * 75 / 94 /* 5000Hz */ +#define AO_BEEP_LOW_PANIC (AO_BEEP_MID_PANIC * 150 / 94) +#define AO_BEEP_HIGH_PANIC (AO_BEEP_MID_PANIC * 75 / 94) + #define AO_BEEP_OFF 0 /* off */ #define AO_BEEP_g 240 /* 1562.5Hz */ diff --git a/src/kernel/ao_cmd.c b/src/kernel/ao_cmd.c index 405fd126..7bb4654e 100644 --- a/src/kernel/ao_cmd.c +++ b/src/kernel/ao_cmd.c @@ -355,7 +355,7 @@ report(void) switch(ao_cmd_status) { case ao_cmd_lex_error: case ao_cmd_syntax_error: - puts("Syntax error"); + ao_put_string("Syntax error\n"); ao_cmd_status = 0; default: break; diff --git a/src/kernel/ao_panic.c b/src/kernel/ao_panic.c index 3feecd5a..bd55eb9c 100644 --- a/src/kernel/ao_panic.c +++ b/src/kernel/ao_panic.c @@ -64,9 +64,9 @@ ao_panic(uint8_t reason) ao_panic_delay(20); #if HAS_BEEP for (n = 0; n < 5; n++) { - ao_beep(AO_BEEP_HIGH); + ao_beep(AO_BEEP_HIGH_PANIC); ao_panic_delay(1); - ao_beep(AO_BEEP_LOW); + ao_beep(AO_BEEP_LOW_PANIC); ao_panic_delay(1); } ao_beep(AO_BEEP_OFF); @@ -78,7 +78,7 @@ ao_panic(uint8_t reason) #endif if (reason & 0x40) { ao_led_on(AO_LED_PANIC); - ao_beep(AO_BEEP_HIGH); + ao_beep(AO_BEEP_HIGH_PANIC); ao_panic_delay(40); ao_led_off(AO_LED_PANIC); ao_beep(AO_BEEP_OFF); @@ -86,7 +86,7 @@ ao_panic(uint8_t reason) } for (n = 0; n < (reason & 0x3f); n++) { ao_led_on(AO_LED_PANIC); - ao_beep(AO_BEEP_MID); + ao_beep(AO_BEEP_MID_PANIC); ao_panic_delay(10); ao_led_off(AO_LED_PANIC); ao_beep(AO_BEEP_OFF); diff --git a/src/lambdakey-v1.0/Makefile b/src/lambdakey-v1.0/Makefile index bffe7d4f..33c68cf5 100644 --- a/src/lambdakey-v1.0/Makefile +++ b/src/lambdakey-v1.0/Makefile @@ -5,7 +5,9 @@ include ../stmf0/Makefile.defs -include ../scheme/Makefile-inc +aoschemelib=$(shell pkg-config --variable=aoschemelib ao-scheme) + +include $(aoschemelib)/Makefile-scheme NEWLIB_FULL=-lm -lc -lgcc @@ -29,8 +31,8 @@ ALTOS_SRC = \ ao_interrupt.c \ ao_product.c \ ao_cmd.c \ - ao_notask.c \ ao_led.c \ + ao_notask.c \ ao_stdio.c \ ao_stdio_newlib.c \ ao_panic.c \ @@ -49,9 +51,9 @@ LDFLAGS=$(CFLAGS) -L$(TOPDIR)/stmf0 -Wl,-Tlambda.ld MAP=$(PROG).map NEWLIB=/local/newlib-mini -MAPFILE=-Wl,-M=$(MAP) +MAPFILE=-Wl,-Map=$(MAP) LDFLAGS=-L../stmf0 -L$(NEWLIB)/arm-none-eabi/lib/thumb/v6-m/ -Wl,-Tlambda.ld $(MAPFILE) -nostartfiles -AO_CFLAGS=-I. -I../stmf0 -I../kernel -I../drivers -I.. -I../scheme -isystem $(NEWLIB)/arm-none-eabi/include -DNEWLIB +AO_CFLAGS=-I. -I../stmf0 -I../kernel -I../drivers -I.. -I$(aoschemelib) -isystem $(NEWLIB)/arm-none-eabi/include -DNEWLIB PROGNAME=lambdakey-v1.0 PROG=$(PROGNAME)-$(VERSION).elf @@ -60,6 +62,9 @@ HEX=$(PROGNAME)-$(VERSION).ihx SRC=$(ALTOS_SRC) ao_lambdakey.c OBJ=$(SRC:.c=.o) +bletch: + echo lib is $(aoschemelib) + all: $(PROG) $(HEX) $(PROG): Makefile $(OBJ) lambda.ld @@ -70,8 +75,8 @@ $(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 +ao_scheme_const.h: ao-scheme-make-const ao_scheme_basic_syntax.scheme + $^ -o $@ -d FLOAT,VECTOR,QUASI,BIGINT,POSIX,PORT,SAVE,UNDEF load: $(PROG) stm-load $(PROG) diff --git a/src/lambdakey-v1.0/ao_lambdakey.c b/src/lambdakey-v1.0/ao_lambdakey.c index 73962e29..f1a2aa38 100644 --- a/src/lambdakey-v1.0/ao_lambdakey.c +++ b/src/lambdakey-v1.0/ao_lambdakey.c @@ -16,7 +16,7 @@ #include <ao_scheme.h> static void scheme_cmd() { - ao_scheme_read_eval_print(); + ao_scheme_read_eval_print(stdin, stdout, false); } static const struct ao_cmds blink_cmds[] = { @@ -27,7 +27,9 @@ static const struct ao_cmds blink_cmds[] = { void main(void) { +#ifdef LEDS_AVAILABLE ao_led_init(LEDS_AVAILABLE); +#endif ao_clock_init(); ao_timer_init(); ao_usb_init(); diff --git a/src/lambdakey-v1.0/ao_lambdakey_const.scheme b/src/lambdakey-v1.0/ao_lambdakey_const.scheme index a912b8ae..a37e1a2b 100644 --- a/src/lambdakey-v1.0/ao_lambdakey_const.scheme +++ b/src/lambdakey-v1.0/ao_lambdakey_const.scheme @@ -185,7 +185,7 @@ ; simple math operators -(define zero? (macro (value) (list eqv? value 0))) +(define zero? (macro (value) (list eq? value 0))) (zero? 1) (zero? 0) @@ -247,13 +247,6 @@ (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)) ) @@ -280,7 +273,7 @@ ; ; (let* ((x 1) (y)) (set! y (+ x 1)) y) -(define let* +(define letrec (macro (a . b) ; @@ -301,7 +294,8 @@ ; expressions to evaluate (define (_v a b) - (cond ((null? a) b) (else + (cond ((null? a) b) + (else (cons (list set (list quote @@ -330,9 +324,10 @@ ) ) -(let* ((a 1) (y a)) (+ a y)) +(letrec ((a 1) (y a)) (+ a y)) -(define let let*) +(define let letrec) +(define let* letrec) ; recursive equality (define (equal? a b) @@ -376,18 +371,21 @@ (memq '(2) '((1) (2) (3))) -(define (_as a b t?) +(define (assoc a b . t?) + (if (null? t?) + (set! t? equal?) + (set! t? (car t?)) + ) (if (null? b) #f (if (t? a (caar b)) (car b) - (_as a (cdr b) t?) + (assoc a (cdr b) t?) ) ) ) -(define (assq a b) (_as a b eq?)) -(define (assoc a b) (_as a b equal?)) +(define (assq a b) (assoc a b eq?)) (assq 'a '((a 1) (b 2) (c 3))) (assoc '(c) '((a 1) (b 2) ((c) 3))) diff --git a/src/lambdakey-v1.0/ao_pins.h b/src/lambdakey-v1.0/ao_pins.h index 48b9db16..58a75080 100644 --- a/src/lambdakey-v1.0/ao_pins.h +++ b/src/lambdakey-v1.0/ao_pins.h @@ -19,23 +19,34 @@ #ifndef _AO_PINS_H_ #define _AO_PINS_H_ +#define fprintf(file, ...) ({ (void) (file); printf(__VA_ARGS__); }) +#undef putc +#define putc(c,file) ({ (void) (file); putchar(c); }) +#define fputs(s,file) ({ (void) (file); ao_put_string(s); }) +#undef getc +#define getc(file) ({ (void) (file); getchar(); }) +#define fflush(file) ({ (void) (file); flush(); }) + #define HAS_TASK 0 #define HAS_AO_DELAY 1 +#if 1 #define LED_PORT_ENABLE STM_RCC_AHBENR_IOPBEN #define LED_PORT (&stm_gpiob) #define LED_PIN_RED 4 #define AO_LED_RED (1 << LED_PIN_RED) #define AO_LED_PANIC AO_LED_RED +#define LEDS_AVAILABLE (AO_LED_RED) +#endif + #define AO_CMD_LEN 128 -#define AO_LISP_POOL_TOTAL 3072 -#define AO_LISP_SAVE 1 +#define AO_LISP_POOL 5120 #define AO_STACK_SIZE 1024 +#if 0 /* need HSI active to write to flash */ #define AO_NEED_HSI 1 - -#define LEDS_AVAILABLE (AO_LED_RED) +#endif #define AO_POWER_MANAGEMENT 0 diff --git a/src/lambdakey-v1.0/ao_scheme_os.h b/src/lambdakey-v1.0/ao_scheme_os.h index b3080f31..8af199c2 100644 --- a/src/lambdakey-v1.0/ao_scheme_os.h +++ b/src/lambdakey-v1.0/ao_scheme_os.h @@ -20,7 +20,7 @@ #include "ao.h" -#define AO_SCHEME_POOL 3584 +#define AO_SCHEME_POOL 3792 #define AO_SCHEME_TOKEN_MAX 64 #ifndef __BYTE_ORDER @@ -30,7 +30,7 @@ #endif static inline int -ao_scheme_getc() { +_ao_scheme_getc() { static uint8_t at_eol; int c; @@ -44,11 +44,7 @@ ao_scheme_getc() { return c; } -static inline void -ao_scheme_os_flush(void) -{ - flush(); -} +#define ao_scheme_getc(f) ({ (void) (f); _ao_scheme_getc(); }) static inline void ao_scheme_abort(void) @@ -56,11 +52,13 @@ ao_scheme_abort(void) ao_panic(1); } +#ifdef LEDS_AVAILABLE static inline void ao_scheme_os_led(int led) { ao_led_set(led); } +#endif #define AO_SCHEME_JIFFIES_PER_SECOND AO_HERTZ diff --git a/src/scheme/.gitignore b/src/scheme/.gitignore deleted file mode 100644 index ee72cb9d..00000000 --- a/src/scheme/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -ao_scheme_const.h -ao_scheme_builtin.h diff --git a/src/scheme/Makefile b/src/scheme/Makefile deleted file mode 100644 index e600d5f7..00000000 --- a/src/scheme/Makefile +++ /dev/null @@ -1,21 +0,0 @@ -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 - +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 > $@ - -make-const/ao_scheme_make_const: FRC ao_scheme_builtin.h - +cd make-const && make ao_scheme_make_const - -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/Makefile-inc b/src/scheme/Makefile-inc deleted file mode 100644 index 1a080a4e..00000000 --- a/src/scheme/Makefile-inc +++ /dev/null @@ -1,25 +0,0 @@ -SCHEME_SRCS=\ - ao_scheme_mem.c \ - ao_scheme_cons.c \ - ao_scheme_string.c \ - ao_scheme_atom.c \ - ao_scheme_int.c \ - ao_scheme_poly.c \ - ao_scheme_bool.c \ - ao_scheme_float.c \ - ao_scheme_builtin.c \ - ao_scheme_read.c \ - ao_scheme_frame.c \ - ao_scheme_lambda.c \ - ao_scheme_eval.c \ - ao_scheme_rep.c \ - ao_scheme_save.c \ - ao_scheme_stack.c \ - ao_scheme_error.c \ - ao_scheme_vector.c - -SCHEME_HDRS=\ - ao_scheme.h \ - ao_scheme_os.h \ - ao_scheme_read.h \ - ao_scheme_builtin.h diff --git a/src/scheme/Makefile-scheme b/src/scheme/Makefile-scheme deleted file mode 100644 index b9018e19..00000000 --- a/src/scheme/Makefile-scheme +++ /dev/null @@ -1,4 +0,0 @@ -include ../scheme/Makefile-inc - -ao_scheme_const.h: $(SCHEME_SRCS) $(SCHEME_HDRS) - +cd ../scheme && make $@ diff --git a/src/scheme/README b/src/scheme/README deleted file mode 100644 index a18457fd..00000000 --- a/src/scheme/README +++ /dev/null @@ -1,10 +0,0 @@ -This follows the R7RS with the following known exceptions: - -* No vectors or bytevectors -* Characters are just numbers -* No dynamic-wind or exceptions -* No environments -* No ports -* No syntax-rules -* No record types -* No libraries diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h deleted file mode 100644 index d4c9bc05..00000000 --- a/src/scheme/ao_scheme.h +++ /dev/null @@ -1,1083 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * 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. - */ - -#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 <stdint.h> -#include <string.h> -#include <stdbool.h> -#define AO_SCHEME_BUILTIN_FEATURES -#include "ao_scheme_builtin.h" -#undef AO_SCHEME_BUILTIN_FEATURES -#include <ao_scheme_os.h> -#ifndef __BYTE_ORDER -#include <endian.h> -#endif - -typedef uint16_t ao_poly; -typedef int16_t ao_signed_poly; - -#if AO_SCHEME_SAVE - -struct ao_scheme_os_save { - ao_poly atoms; - ao_poly globals; - uint16_t const_checksum; - 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)) - -int -ao_scheme_os_save(void); - -int -ao_scheme_os_restore_save(struct ao_scheme_os_save *save, int offset); - -int -ao_scheme_os_restore(void); - -#endif - -#ifdef AO_SCHEME_MAKE_CONST -#define AO_SCHEME_POOL_CONST 16384 -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((char *) n)) -#define _bool(v) ao_scheme_bool_poly(ao_scheme_bool_get(v)) - -#define _ao_scheme_bool_true _bool(1) -#define _ao_scheme_bool_false _bool(0) - -#define _ao_scheme_atom_eof _atom("eof") -#define _ao_scheme_atom_else _atom("else") - -#define AO_SCHEME_BUILTIN_ATOMS -#include "ao_scheme_builtin.h" - -#else -#include "ao_scheme_const.h" -#ifndef AO_SCHEME_POOL -#error Must define AO_SCHEME_POOL -#endif -#ifndef AO_SCHEME_POOL_EXTRA -#define AO_SCHEME_POOL_EXTRA 0 -#endif -extern uint8_t ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribute__((aligned(4))); -#endif - -/* Primitive types */ -#define AO_SCHEME_CONS 0 -#define AO_SCHEME_INT 1 -#define AO_SCHEME_BIGINT 2 -#define AO_SCHEME_OTHER 3 - -#define AO_SCHEME_TYPE_MASK 0x0003 -#define AO_SCHEME_TYPE_SHIFT 2 -#define AO_SCHEME_REF_MASK 0x7ffc -#define AO_SCHEME_CONST 0x8000 - -/* These have a type value at the start of the struct */ -#define AO_SCHEME_ATOM 4 -#define AO_SCHEME_BUILTIN 5 -#define AO_SCHEME_FRAME 6 -#define AO_SCHEME_FRAME_VALS 7 -#define AO_SCHEME_LAMBDA 8 -#define AO_SCHEME_STACK 9 -#define AO_SCHEME_BOOL 10 -#define AO_SCHEME_STRING 11 -#ifdef AO_SCHEME_FEATURE_FLOAT -#define AO_SCHEME_FLOAT 12 -#define _AO_SCHEME_FLOAT AO_SCHEME_FLOAT -#else -#define _AO_SCHEME_FLOAT 12 -#endif -#ifdef AO_SCHEME_FEATURE_VECTOR -#define AO_SCHEME_VECTOR 13 -#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 - -#define AO_SCHEME_NIL 0 - -extern uint16_t ao_scheme_top; - -#define AO_SCHEME_OOM 0x01 -#define AO_SCHEME_DIVIDE_BY_ZERO 0x02 -#define AO_SCHEME_INVALID 0x04 -#define AO_SCHEME_UNDEFINED 0x08 -#define AO_SCHEME_REDEFINED 0x10 -#define AO_SCHEME_EOF 0x20 -#define AO_SCHEME_EXIT 0x40 - -extern uint8_t ao_scheme_exception; - -static inline int -ao_scheme_is_const(ao_poly poly) { - return poly & AO_SCHEME_CONST; -} - -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); - -ao_poly -ao_scheme_poly(const void *addr, ao_poly type); - -struct ao_scheme_type { - int (*size)(void *addr); - void (*mark)(void *addr); - void (*move)(void *addr); - char name[]; -}; - -struct ao_scheme_cons { - ao_poly car; - ao_poly cdr; -}; - -struct ao_scheme_atom { - uint8_t type; - uint8_t pad[1]; - ao_poly next; - char name[]; -}; - -struct ao_scheme_string { - uint8_t type; - char val[]; -}; - -struct ao_scheme_val { - ao_poly atom; - ao_poly val; -}; - -struct ao_scheme_frame_vals { - uint8_t type; - uint8_t size; - struct ao_scheme_val vals[]; -}; - -struct ao_scheme_frame { - uint8_t type; - uint8_t num; - ao_poly prev; - ao_poly vals; -}; - -struct ao_scheme_bool { - uint8_t type; - uint8_t value; - uint16_t pad; -}; - - -#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 INT32_MIN -#define AO_SCHEME_MAX_BIGINT INT32_MAX - -#endif /* AO_SCHEME_FEATURE_BIGINT */ - -/* Set on type when the frame escapes the lambda */ -#define AO_SCHEME_FRAME_MARK 0x80 - -static inline int ao_scheme_frame_marked(struct ao_scheme_frame *f) { - return f->type & AO_SCHEME_FRAME_MARK; -} - -static inline struct ao_scheme_frame * -ao_scheme_poly_frame(ao_poly poly) { - return ao_scheme_ref(poly); -} - -static inline ao_poly -ao_scheme_frame_poly(struct ao_scheme_frame *frame) { - return ao_scheme_poly(frame, AO_SCHEME_OTHER); -} - -static inline struct ao_scheme_frame_vals * -ao_scheme_poly_frame_vals(ao_poly poly) { - return ao_scheme_ref(poly); -} - -static inline ao_poly -ao_scheme_frame_vals_poly(struct ao_scheme_frame_vals *vals) { - return ao_scheme_poly(vals, AO_SCHEME_OTHER); -} - -enum eval_state { - eval_sexpr, /* Evaluate an sexpr */ - eval_val, /* Value computed */ - eval_formal, /* Formal computed */ - eval_exec, /* Start a lambda evaluation */ - eval_apply, /* Execute apply */ - eval_cond, /* Start next cond clause */ - eval_cond_test, /* Check cond condition */ - eval_begin, /* Start next begin entry */ - eval_while, /* Start while condition */ - eval_while_test, /* Check while condition */ - eval_macro, /* Finished with macro generation */ -}; - -struct ao_scheme_stack { - uint8_t type; /* AO_SCHEME_STACK */ - uint8_t state; /* enum eval_state */ - ao_poly prev; /* previous stack frame */ - ao_poly sexprs; /* expressions to evaluate */ - ao_poly values; /* values computed */ - ao_poly values_tail; /* end of the values list for easy appending */ - ao_poly frame; /* current lookup frame */ - ao_poly list; /* most recent function call */ -}; - -#define AO_SCHEME_STACK_MARK 0x80 /* set on type when a reference has been taken */ - -static inline int ao_scheme_stack_marked(struct ao_scheme_stack *s) { - return s->type & AO_SCHEME_STACK_MARK; -} - -static inline void ao_scheme_stack_mark(struct ao_scheme_stack *s) { - s->type |= AO_SCHEME_STACK_MARK; -} - -static inline struct ao_scheme_stack * -ao_scheme_poly_stack(ao_poly p) -{ - return ao_scheme_ref(p); -} - -static inline ao_poly -ao_scheme_stack_poly(struct ao_scheme_stack *stack) -{ - return ao_scheme_poly(stack, AO_SCHEME_OTHER); -} - -extern ao_poly ao_scheme_v; - -#define AO_SCHEME_FUNC_LAMBDA 0 -#define AO_SCHEME_FUNC_NLAMBDA 1 -#define AO_SCHEME_FUNC_MACRO 2 - -#define AO_SCHEME_FUNC_FREE_ARGS 0x80 -#define AO_SCHEME_FUNC_MASK 0x7f - -#define AO_SCHEME_FUNC_F_LAMBDA (AO_SCHEME_FUNC_FREE_ARGS | AO_SCHEME_FUNC_LAMBDA) -#define AO_SCHEME_FUNC_F_NLAMBDA (AO_SCHEME_FUNC_FREE_ARGS | AO_SCHEME_FUNC_NLAMBDA) -#define AO_SCHEME_FUNC_F_MACRO (AO_SCHEME_FUNC_FREE_ARGS | AO_SCHEME_FUNC_MACRO) - -struct ao_scheme_builtin { - uint8_t type; - uint8_t args; - uint16_t func; -}; - -#define AO_SCHEME_BUILTIN_ID -#include "ao_scheme_builtin.h" - -typedef ao_poly (*ao_scheme_func_t)(struct ao_scheme_cons *cons); - -extern const ao_scheme_func_t ao_scheme_builtins[]; - -static inline ao_scheme_func_t -ao_scheme_func(struct ao_scheme_builtin *b) -{ - return ao_scheme_builtins[b->func]; -} - -struct ao_scheme_lambda { - uint8_t type; - uint8_t args; - ao_poly code; - ao_poly frame; -}; - -static inline struct ao_scheme_lambda * -ao_scheme_poly_lambda(ao_poly poly) -{ - return ao_scheme_ref(poly); -} - -static inline ao_poly -ao_scheme_lambda_poly(struct ao_scheme_lambda *lambda) -{ - return ao_scheme_poly(lambda, AO_SCHEME_OTHER); -} - -static inline void * -ao_scheme_poly_other(ao_poly poly) { - return ao_scheme_ref(poly); -} - -static inline uint8_t -ao_scheme_other_type(void *other) { -#if DBG_MEM - if ((*((uint8_t *) other) & AO_SCHEME_OTHER_TYPE_MASK) >= AO_SCHEME_NUM_TYPE) - ao_scheme_abort(); -#endif - return *((uint8_t *) other) & AO_SCHEME_OTHER_TYPE_MASK; -} - -static inline ao_poly -ao_scheme_other_poly(const void *other) -{ - return ao_scheme_poly(other, AO_SCHEME_OTHER); -} - -static inline int -ao_scheme_size_round(int size) -{ - return (size + 3) & ~3; -} - -static inline int -ao_scheme_size(const struct ao_scheme_type *type, void *addr) -{ - return ao_scheme_size_round(type->size(addr)); -} - -#define AO_SCHEME_OTHER_POLY(other) ((ao_poly)(other) + AO_SCHEME_OTHER) - -static inline int ao_scheme_poly_base_type(ao_poly poly) { - return poly & AO_SCHEME_TYPE_MASK; -} - -static inline int ao_scheme_poly_type(ao_poly poly) { - int type = poly & AO_SCHEME_TYPE_MASK; - if (type == AO_SCHEME_OTHER) - return ao_scheme_other_type(ao_scheme_poly_other(poly)); - return type; -} - -static inline int -ao_scheme_is_cons(ao_poly poly) { - return (ao_scheme_poly_base_type(poly) == AO_SCHEME_CONS); -} - -static inline int -ao_scheme_is_pair(ao_poly poly) { - return poly != AO_SCHEME_NIL && (ao_scheme_poly_base_type(poly) == AO_SCHEME_CONS); -} - -static inline struct ao_scheme_cons * -ao_scheme_poly_cons(ao_poly poly) -{ - return ao_scheme_ref(poly); -} - -static inline ao_poly -ao_scheme_cons_poly(struct ao_scheme_cons *cons) -{ - return ao_scheme_poly(cons, AO_SCHEME_CONS); -} - -static inline int32_t -ao_scheme_poly_int(ao_poly poly) -{ - return (int32_t) ((ao_signed_poly) poly >> AO_SCHEME_TYPE_SHIFT); -} - -static inline ao_poly -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) -{ - return ao_scheme_ref(poly); -} - -static inline ao_poly -ao_scheme_bigint_poly(struct ao_scheme_bigint *bi) -{ - return ao_scheme_poly(bi, AO_SCHEME_BIGINT); -} -#endif /* AO_SCHEME_FEATURE_BIGINT */ - -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(struct ao_scheme_string *s) -{ - return ao_scheme_poly(s, AO_SCHEME_OTHER); -} - -static inline struct ao_scheme_atom * -ao_scheme_poly_atom(ao_poly poly) -{ - return ao_scheme_ref(poly); -} - -static inline ao_poly -ao_scheme_atom_poly(struct ao_scheme_atom *a) -{ - return ao_scheme_poly(a, AO_SCHEME_OTHER); -} - -static inline struct ao_scheme_builtin * -ao_scheme_poly_builtin(ao_poly poly) -{ - return ao_scheme_ref(poly); -} - -static inline ao_poly -ao_scheme_builtin_poly(struct ao_scheme_builtin *b) -{ - return ao_scheme_poly(b, AO_SCHEME_OTHER); -} - -static inline ao_poly -ao_scheme_bool_poly(struct ao_scheme_bool *b) -{ - return ao_scheme_poly(b, AO_SCHEME_OTHER); -} - -static inline struct ao_scheme_bool * -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) -{ - return ao_scheme_poly(f, AO_SCHEME_OTHER); -} - -static inline struct ao_scheme_float * -ao_scheme_poly_float(ao_poly poly) -{ - return ao_scheme_ref(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) -{ - return ao_scheme_poly(v, AO_SCHEME_OTHER); -} - -static inline struct ao_scheme_vector * -ao_scheme_poly_vector(ao_poly poly) -{ - return ao_scheme_ref(poly); -} -#endif - -/* memory functions */ - -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_memory(const struct ao_scheme_type *type, void *addr); - -/* returns 1 if the object was already moved */ -int -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); - -void -ao_scheme_print_clear_addr(void *addr); - -/* Notes that printing has started */ -void -ao_scheme_print_start(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 -#define AO_SCHEME_COLLECT_INCREMENTAL 0 - -int -ao_scheme_collect(uint8_t style); - -#if DBG_FREE_CONS -void -ao_scheme_cons_check(struct ao_scheme_cons *cons); -#endif - -void -ao_scheme_poly_stash(ao_poly poly); - -ao_poly -ao_scheme_poly_fetch(void); - -static inline void -ao_scheme_cons_stash(struct ao_scheme_cons *cons) { - ao_scheme_poly_stash(ao_scheme_cons_poly(cons)); -} - -static inline struct ao_scheme_cons * -ao_scheme_cons_fetch(void) { - return ao_scheme_poly_cons(ao_scheme_poly_fetch()); -} - -static inline void -ao_scheme_atom_stash(struct ao_scheme_atom *atom) { - ao_scheme_poly_stash(ao_scheme_atom_poly(atom)); -} - -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_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(void) { - return ao_scheme_poly_stack(ao_scheme_poly_fetch()); -} - -static inline void -ao_scheme_frame_stash(struct ao_scheme_frame *frame) { - ao_scheme_poly_stash(ao_scheme_frame_poly(frame)); -} - -static inline struct ao_scheme_frame * -ao_scheme_frame_fetch(void) { - return ao_scheme_poly_frame(ao_scheme_poly_fetch()); -} - -/* bool */ - -extern const struct ao_scheme_type ao_scheme_bool_type; - -void -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; - -struct ao_scheme_bool * -ao_scheme_bool_get(uint8_t value); -#endif - -/* cons */ -extern const struct ao_scheme_type ao_scheme_cons_type; - -struct ao_scheme_cons * -ao_scheme_cons_cons(ao_poly car, ao_poly cdr); - -/* Return a cons or NULL for a proper list, else error */ -struct ao_scheme_cons * -ao_scheme_cons_cdr(struct ao_scheme_cons *cons); - -ao_poly -ao_scheme_cons(ao_poly car, ao_poly cdr); - -extern struct ao_scheme_cons *ao_scheme_cons_free_list; - -void -ao_scheme_cons_free(struct ao_scheme_cons *cons); - -void -ao_scheme_cons_write(ao_poly, bool write); - -int -ao_scheme_cons_length(struct ao_scheme_cons *cons); - -struct ao_scheme_cons * -ao_scheme_cons_copy(struct ao_scheme_cons *cons); - -/* string */ -extern const struct ao_scheme_type ao_scheme_string_type; - -struct ao_scheme_string * -ao_scheme_string_copy(struct ao_scheme_string *a); - -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(struct ao_scheme_string *a); - -void -ao_scheme_string_write(ao_poly s, bool write); - -/* atom */ -extern const struct ao_scheme_type ao_scheme_atom_type; - -extern struct ao_scheme_atom *ao_scheme_atoms; -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, bool write); - -struct ao_scheme_atom * -ao_scheme_string_to_atom(struct ao_scheme_string *string); - -struct ao_scheme_atom * -ao_scheme_atom_intern(char *name); - -ao_poly * -ao_scheme_atom_ref(ao_poly atom, struct ao_scheme_frame **frame_ref); - -ao_poly -ao_scheme_atom_get(ao_poly atom); - -ao_poly -ao_scheme_atom_set(ao_poly atom, ao_poly val); - -ao_poly -ao_scheme_atom_def(ao_poly atom, ao_poly val); - -/* int */ -void -ao_scheme_int_write(ao_poly i, bool write); - -#ifdef AO_SCHEME_FEATURE_BIGINT -int32_t -ao_scheme_poly_integer(ao_poly p, bool *fail); - -ao_poly -ao_scheme_integer_poly(int32_t i); - -static inline int -ao_scheme_integer_typep(uint8_t t) -{ - return (t == AO_SCHEME_INT) || (t == AO_SCHEME_BIGINT); -} - -void -ao_scheme_bigint_write(ao_poly i, bool write); - -extern const struct ao_scheme_type ao_scheme_bigint_type; - -#else - -#define ao_scheme_poly_integer(a,b) ao_scheme_poly_int(a) -#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 -ao_scheme_vector_write(ao_poly v, bool write); - -struct ao_scheme_vector * -ao_scheme_vector_alloc(uint16_t length, ao_poly fill); - -ao_poly -ao_scheme_vector_get(ao_poly v, ao_poly i); - -ao_poly -ao_scheme_vector_set(ao_poly v, ao_poly i, ao_poly p); - -struct ao_scheme_vector * -ao_scheme_list_to_vector(struct ao_scheme_cons *cons); - -struct ao_scheme_cons * -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, bool write); - -static inline void -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); - -/* returns 1 if the object has already been moved */ -int -ao_scheme_poly_move(ao_poly *p, uint8_t note_cons); - -/* eval */ - -void -ao_scheme_eval_clear_globals(void); - -int -ao_scheme_eval_restart(void); - -ao_poly -ao_scheme_eval(ao_poly p); - -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 -ao_scheme_float_write(ao_poly p, bool write); - -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) -{ - return ao_scheme_integer_typep(t) || (t == AO_SCHEME_FLOAT); -} -#else -#define ao_scheme_number_typep ao_scheme_integer_typep -#endif - -/* builtin */ -void -ao_scheme_builtin_write(ao_poly b, bool write); - -extern const struct ao_scheme_type ao_scheme_builtin_type; - -/* Check argument count */ -ao_poly -ao_scheme_check_argc(ao_poly name, struct ao_scheme_cons *cons, int min, int max); - -/* Check argument type */ -ao_poly -ao_scheme_check_argt(ao_poly name, struct ao_scheme_cons *cons, int argc, int type, int nil_ok); - -/* Fetch an arg (nil if off the end) */ -ao_poly -ao_scheme_arg(struct ao_scheme_cons *cons, int argc); - -char * -ao_scheme_args_name(uint8_t args); - -/* read */ -extern int ao_scheme_read_list; -extern struct ao_scheme_cons *ao_scheme_read_cons; -extern struct ao_scheme_cons *ao_scheme_read_cons_tail; -extern struct ao_scheme_cons *ao_scheme_read_stack; - -ao_poly -ao_scheme_read(void); - -/* rep */ -ao_poly -ao_scheme_read_eval_print(void); - -/* frame */ -extern const struct ao_scheme_type ao_scheme_frame_type; -extern const struct ao_scheme_type ao_scheme_frame_vals_type; - -#define AO_SCHEME_FRAME_FREE 6 - -extern struct ao_scheme_frame *ao_scheme_frame_free_list[AO_SCHEME_FRAME_FREE]; - -ao_poly -ao_scheme_frame_mark(struct ao_scheme_frame *frame); - -ao_poly * -ao_scheme_frame_ref(struct ao_scheme_frame *frame, ao_poly atom); - -struct ao_scheme_frame * -ao_scheme_frame_new(int num); - -void -ao_scheme_frame_free(struct ao_scheme_frame *frame); - -void -ao_scheme_frame_bind(struct ao_scheme_frame *frame, int num, ao_poly atom, ao_poly val); - -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, bool write); - -void -ao_scheme_frame_init(void); - -/* lambda */ -extern const struct ao_scheme_type ao_scheme_lambda_type; - -extern const char * const ao_scheme_state_names[]; - -struct ao_scheme_lambda * -ao_scheme_lambda_new(ao_poly cons); - -void -ao_scheme_lambda_write(ao_poly lambda, bool write); - -ao_poly -ao_scheme_lambda_eval(void); - -/* stack */ - -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); - -int -ao_scheme_stack_push(void); - -void -ao_scheme_stack_pop(void); - -void -ao_scheme_stack_clear(void); - -void -ao_scheme_stack_write(ao_poly stack, bool write); - -ao_poly -ao_scheme_stack_eval(void); - -/* error */ - -void -ao_scheme_vprintf(const char *format, va_list args); - -void -ao_scheme_printf(const char *format, ...); - -ao_poly -ao_scheme_error(int error, const char *format, ...); - -/* builtins */ - -#define AO_SCHEME_BUILTIN_DECLS -#include "ao_scheme_builtin.h" - -/* debugging macros */ - -#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) -#define DBG_OUT() (--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), 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), true) -static inline void -ao_scheme_frames_dump(void) -{ - struct ao_scheme_stack *s; - DBGI(".. current frame: "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); - for (s = ao_scheme_stack; s; s = ao_scheme_poly_stack(s->prev)) { - DBGI(".. stack frame: "); DBG_POLY(s->frame); DBG("\n"); - } -} -#define DBG_FRAMES() ao_scheme_frames_dump() -#else -#define DBG_DO(a) -#define DBG_INDENT() -#define DBG_IN() -#define DBG_OUT() -#define DBG(...) -#define DBGI(...) -#define DBG_CONS(a) -#define DBG_POLY(a) -#define DBG_RESET() -#define DBG_STACK() -#define DBG_FRAMES() -#endif - -#if DBG_READ -#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 - -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 <assert.h> -extern int dbg_move_depth; -#define MDBG_DUMP 1 - -extern int dbg_mem; - -#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++) -#define MDBG_MOVE_OUT() (assert(--dbg_move_depth >= 0)) - -#else - -#define MDBG_DO(a) -#define MDBG_MOVE(...) -#define MDBG_MORE(...) -#define MDBG_MOVE_IN() -#define MDBG_MOVE_OUT() - -#endif - -#endif /* _AO_SCHEME_H_ */ diff --git a/src/scheme/ao_scheme_atom.c b/src/scheme/ao_scheme_atom.c deleted file mode 100644 index c72a2b27..00000000 --- a/src/scheme/ao_scheme_atom.c +++ /dev/null @@ -1,196 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * 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. - */ - -#include "ao_scheme.h" - -static int name_size(char *name) -{ - return sizeof(struct ao_scheme_atom) + strlen(name) + 1; -} - -static int atom_size(void *addr) -{ - struct ao_scheme_atom *atom = addr; - if (!atom) - return 0; - return name_size(atom->name); -} - -static void atom_mark(void *addr) -{ - struct ao_scheme_atom *atom = addr; - - for (;;) { - atom = ao_scheme_poly_atom(atom->next); - if (!atom) - break; - if (ao_scheme_mark_memory(&ao_scheme_atom_type, atom)) - break; - } -} - -static void atom_move(void *addr) -{ - struct ao_scheme_atom *atom = addr; - int ret; - - for (;;) { - struct ao_scheme_atom *next = ao_scheme_poly_atom(atom->next); - - if (!next) - break; - ret = ao_scheme_move_memory(&ao_scheme_atom_type, (void **) &next); - if (next != ao_scheme_poly_atom(atom->next)) - atom->next = ao_scheme_atom_poly(next); - if (ret) - break; - atom = next; - } -} - -const struct ao_scheme_type ao_scheme_atom_type = { - .mark = atom_mark, - .size = atom_size, - .move = atom_move, - .name = "atom" -}; - -struct ao_scheme_atom *ao_scheme_atoms; - -static struct ao_scheme_atom * -ao_scheme_atom_find(char *name) -{ - struct ao_scheme_atom *atom; - - for (atom = ao_scheme_atoms; atom; atom = ao_scheme_poly_atom(atom->next)) { - if (!strcmp(atom->name, name)) - return atom; - } -#ifdef ao_builtin_atoms - for (atom = ao_scheme_poly_atom(ao_builtin_atoms); atom; atom = ao_scheme_poly_atom(atom->next)) { - if (!strcmp(atom->name, name)) - return atom; - } -#endif - 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; - } -} - -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(string); - atom = ao_scheme_alloc(name_size(string->val)); - string = ao_scheme_string_fetch(); - 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; -} - -ao_poly * -ao_scheme_atom_ref(ao_poly atom, struct ao_scheme_frame **frame_ref) -{ - ao_poly *ref; - struct ao_scheme_frame *frame; - - for (frame = ao_scheme_frame_current; frame; frame = ao_scheme_poly_frame(frame->prev)) { - ref = ao_scheme_frame_ref(frame, atom); - if (ref) { - if (frame_ref) - *frame_ref = frame; - return ref; - } - } - ref = ao_scheme_frame_ref(ao_scheme_frame_global, atom); - if (ref) - if (frame_ref) - *frame_ref = ao_scheme_frame_global; - return ref; -} - -ao_poly -ao_scheme_atom_get(ao_poly atom) -{ - ao_poly *ref = ao_scheme_atom_ref(atom, NULL); - -#ifdef ao_builtin_frame - if (!ref) - ref = ao_scheme_frame_ref(ao_scheme_poly_frame(ao_builtin_frame), atom); -#endif - if (ref) - return *ref; - return ao_scheme_error(AO_SCHEME_UNDEFINED, "undefined atom %s", ao_scheme_poly_atom(atom)->name); -} - -ao_poly -ao_scheme_atom_set(ao_poly atom, ao_poly val) -{ - ao_poly *ref = ao_scheme_atom_ref(atom, NULL); - - if (!ref) - return ao_scheme_error(AO_SCHEME_UNDEFINED, "undefined atom %s", ao_scheme_poly_atom(atom)->name); - *ref = val; - return val; -} - -ao_poly -ao_scheme_atom_def(ao_poly atom, ao_poly val) -{ - struct ao_scheme_frame *frame; - ao_poly *ref = ao_scheme_atom_ref(atom, &frame); - - if (ref) { - if (frame == ao_scheme_frame_current) - return ao_scheme_error(AO_SCHEME_REDEFINED, "attempt to redefine atom %s", ao_scheme_poly_atom(atom)->name); - *ref = val; - return val; - } - return ao_scheme_frame_add(ao_scheme_frame_current ? ao_scheme_frame_current : ao_scheme_frame_global, atom, val); -} - -void -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 deleted file mode 100644 index 88970667..00000000 --- a/src/scheme/ao_scheme_bool.c +++ /dev/null @@ -1,74 +0,0 @@ -/* - * Copyright © 2017 Keith Packard <keithp@keithp.com> - * - * 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" - -static void bool_mark(void *addr) -{ - (void) addr; -} - -static int bool_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_scheme_bool); -} - -static void bool_move(void *addr) -{ - (void) addr; -} - -const struct ao_scheme_type ao_scheme_bool_type = { - .mark = bool_mark, - .size = bool_size, - .move = bool_move, - .name = "bool" -}; - -void -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 - printf("#f"); -} - -#ifdef AO_SCHEME_MAKE_CONST - -struct ao_scheme_bool *ao_scheme_true, *ao_scheme_false; - -struct ao_scheme_bool * -ao_scheme_bool_get(uint8_t value) -{ - struct ao_scheme_bool **b; - - if (value) - b = &ao_scheme_true; - else - b = &ao_scheme_false; - - if (!*b) { - *b = ao_scheme_alloc(sizeof (struct ao_scheme_bool)); - (*b)->type = AO_SCHEME_BOOL; - (*b)->value = value; - } - return *b; -} - -#endif diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c deleted file mode 100644 index 81fd9010..00000000 --- a/src/scheme/ao_scheme_builtin.c +++ /dev/null @@ -1,1137 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * 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 <limits.h> -#include <math.h> - -static int -builtin_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_scheme_builtin); -} - -static void -builtin_mark(void *addr) -{ - (void) addr; -} - -static void -builtin_move(void *addr) -{ - (void) addr; -} - -const struct ao_scheme_type ao_scheme_builtin_type = { - .size = builtin_size, - .mark = builtin_mark, - .move = builtin_move -}; - -#ifdef AO_SCHEME_MAKE_CONST - -#define AO_SCHEME_BUILTIN_CASENAME -#include "ao_scheme_builtin.h" - -char *ao_scheme_args_name(uint8_t args) { - args &= AO_SCHEME_FUNC_MASK; - switch (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 (char *) "???"; - } -} -#else - -#define AO_SCHEME_BUILTIN_ARRAYNAME -#include "ao_scheme_builtin.h" - -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 (char *) "???"; -} - -static const ao_poly ao_scheme_args_atoms[] = { - [AO_SCHEME_FUNC_LAMBDA] = _ao_scheme_atom_lambda, - [AO_SCHEME_FUNC_NLAMBDA] = _ao_scheme_atom_nlambda, - [AO_SCHEME_FUNC_MACRO] = _ao_scheme_atom_macro, -}; - -char * -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 (char *) "(unknown)"; -} -#endif - -void -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)); -} - -ao_poly -ao_scheme_check_argc(ao_poly name, struct ao_scheme_cons *cons, int min, int max) -{ - int argc = 0; - - while (cons && argc <= max) { - argc++; - cons = ao_scheme_cons_cdr(cons); - } - if (argc < min || argc > max) - return ao_scheme_error(AO_SCHEME_INVALID, "%s: invalid arg count", ao_scheme_poly_atom(name)->name); - return _ao_scheme_bool_true; -} - -ao_poly -ao_scheme_arg(struct ao_scheme_cons *cons, int argc) -{ - if (!cons) - return AO_SCHEME_NIL; - while (argc--) { - if (!cons) - return AO_SCHEME_NIL; - cons = ao_scheme_cons_cdr(cons); - } - return cons->car; -} - -ao_poly -ao_scheme_check_argt(ao_poly name, struct ao_scheme_cons *cons, int argc, int type, int nil_ok) -{ - ao_poly car = ao_scheme_arg(cons, argc); - - if ((!car && !nil_ok) || ao_scheme_poly_type(car) != type) - return ao_scheme_error(AO_SCHEME_INVALID, "%v: arg %d invalid type %v", name, argc, car); - return _ao_scheme_bool_true; -} - -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); - bool fail = false; - int32_t i = ao_scheme_poly_integer(p, &fail); - - if (fail) - (void) ao_scheme_error(AO_SCHEME_INVALID, "%v: arg %d invalid type %v", name, argc, p); - return i; -} - -ao_poly -ao_scheme_do_car(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_check_argc(_ao_scheme_atom_car, cons, 1, 1)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_car, cons, 0, AO_SCHEME_CONS, 0)) - return AO_SCHEME_NIL; - return ao_scheme_poly_cons(cons->car)->car; -} - -ao_poly -ao_scheme_do_cdr(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_check_argc(_ao_scheme_atom_cdr, cons, 1, 1)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_cdr, cons, 0, AO_SCHEME_CONS, 0)) - return AO_SCHEME_NIL; - return ao_scheme_poly_cons(cons->car)->cdr; -} - -ao_poly -ao_scheme_do_cons(struct ao_scheme_cons *cons) -{ - ao_poly car, cdr; - if(!ao_scheme_check_argc(_ao_scheme_atom_cons, cons, 2, 2)) - return AO_SCHEME_NIL; - car = ao_scheme_arg(cons, 0); - cdr = ao_scheme_arg(cons, 1); - return ao_scheme_cons(car, cdr); -} - -ao_poly -ao_scheme_do_last(struct ao_scheme_cons *cons) -{ - struct ao_scheme_cons *list; - if (!ao_scheme_check_argc(_ao_scheme_atom_last, cons, 1, 1)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_last, cons, 0, AO_SCHEME_CONS, 1)) - return AO_SCHEME_NIL; - for (list = ao_scheme_poly_cons(ao_scheme_arg(cons, 0)); - list; - list = ao_scheme_cons_cdr(list)) - { - if (!list->cdr) - return list->car; - } - return AO_SCHEME_NIL; -} - -ao_poly -ao_scheme_do_length(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_check_argc(_ao_scheme_atom_length, cons, 1, 1)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_length, cons, 0, AO_SCHEME_CONS, 1)) - return AO_SCHEME_NIL; - return ao_scheme_int_poly(ao_scheme_cons_length(ao_scheme_poly_cons(ao_scheme_arg(cons, 0)))); -} - -ao_poly -ao_scheme_do_list_copy(struct ao_scheme_cons *cons) -{ - struct ao_scheme_cons *new; - - if (!ao_scheme_check_argc(_ao_scheme_atom_length, cons, 1, 1)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_length, cons, 0, AO_SCHEME_CONS, 1)) - return AO_SCHEME_NIL; - new = ao_scheme_cons_copy(ao_scheme_poly_cons(ao_scheme_arg(cons, 0))); - return ao_scheme_cons_poly(new); -} - -ao_poly -ao_scheme_do_quote(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_check_argc(_ao_scheme_atom_quote, cons, 1, 1)) - return AO_SCHEME_NIL; - return ao_scheme_arg(cons, 0); -} - -ao_poly -ao_scheme_do_set(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_check_argc(_ao_scheme_atom_set, cons, 2, 2)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_set, cons, 0, AO_SCHEME_ATOM, 0)) - return AO_SCHEME_NIL; - - return ao_scheme_atom_set(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1)); -} - -ao_poly -ao_scheme_do_def(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_check_argc(_ao_scheme_atom_def, cons, 2, 2)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_def, cons, 0, AO_SCHEME_ATOM, 0)) - return AO_SCHEME_NIL; - - return ao_scheme_atom_def(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1)); -} - -ao_poly -ao_scheme_do_setq(struct ao_scheme_cons *cons) -{ - ao_poly name; - if (!ao_scheme_check_argc(_ao_scheme_atom_set21, cons, 2, 2)) - return AO_SCHEME_NIL; - name = cons->car; - if (ao_scheme_poly_type(name) != AO_SCHEME_ATOM) - 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)); -} - -ao_poly -ao_scheme_do_cond(struct ao_scheme_cons *cons) -{ - ao_scheme_set_cond(cons); - return AO_SCHEME_NIL; -} - -ao_poly -ao_scheme_do_begin(struct ao_scheme_cons *cons) -{ - ao_scheme_stack->state = eval_begin; - ao_scheme_stack->sexprs = ao_scheme_cons_poly(cons); - return AO_SCHEME_NIL; -} - -ao_poly -ao_scheme_do_while(struct ao_scheme_cons *cons) -{ - ao_scheme_stack->state = eval_while; - ao_scheme_stack->sexprs = ao_scheme_cons_poly(cons); - return AO_SCHEME_NIL; -} - -ao_poly -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, true); - cons = ao_scheme_cons_cdr(cons); - if (cons) - printf(" "); - } - return _ao_scheme_bool_true; -} - -ao_poly -ao_scheme_do_display(struct ao_scheme_cons *cons) -{ - ao_poly val = AO_SCHEME_NIL; - while (cons) { - val = cons->car; - ao_scheme_poly_write(val, false); - cons = ao_scheme_cons_cdr(cons); - } - return _ao_scheme_bool_true; -} - -static ao_poly -ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) -{ - struct ao_scheme_cons *cons; - ao_poly ret = AO_SCHEME_NIL; - - for (cons = orig_cons; cons; cons = ao_scheme_cons_cdr(cons)) { - ao_poly car = cons->car; - uint8_t rt = ao_scheme_poly_type(ret); - uint8_t ct = ao_scheme_poly_type(car); - - if (cons == orig_cons) { - ret = car; - ao_scheme_cons_stash(cons); - if (cons->cdr == AO_SCHEME_NIL) { - switch (op) { - case builtin_minus: - if (ao_scheme_integer_typep(ct)) - 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_poly_integer(ret, NULL) == 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: - break; - } - } - 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); -#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) - return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "quotient by zero"); - if (r % c != 0 && (c < 0) != (r < 0)) - r = r / c - 1; - else - r = r / c; - break; - case builtin_remainder: - if (c == 0) - return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "remainder by zero"); - r %= c; - break; - case builtin_modulo: - if (c == 0) - return ao_scheme_error(AO_SCHEME_DIVIDE_BY_ZERO, "modulo by zero"); - r %= c; - if ((r < 0) != (c < 0)) - r += c; - break; - default: - break; - } - ao_scheme_cons_stash(cons); - ret = ao_scheme_integer_poly(r); - 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; - inexact: - r = ao_scheme_poly_number(ret); - c = ao_scheme_poly_number(car); - switch(op) { - case builtin_plus: - r += c; - break; - case builtin_minus: - r -= c; - break; - case builtin_times: - r *= c; - break; - case builtin_divide: - r /= c; - break; - case builtin_quotient: - case builtin_remainder: - case builtin_modulo: - return ao_scheme_error(AO_SCHEME_INVALID, "non-integer value in integer divide"); - default: - break; - } - ao_scheme_cons_stash(cons); - ret = ao_scheme_float_get(r); - cons = ao_scheme_cons_fetch(); -#endif - } - else if (rt == AO_SCHEME_STRING && ct == AO_SCHEME_STRING && op == builtin_plus) { - 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(); - if (!ret) - return ret; - } - else - return ao_scheme_error(AO_SCHEME_INVALID, "invalid args"); - } - return ret; -} - -ao_poly -ao_scheme_do_plus(struct ao_scheme_cons *cons) -{ - return ao_scheme_math(cons, builtin_plus); -} - -ao_poly -ao_scheme_do_minus(struct ao_scheme_cons *cons) -{ - return ao_scheme_math(cons, builtin_minus); -} - -ao_poly -ao_scheme_do_times(struct ao_scheme_cons *cons) -{ - return ao_scheme_math(cons, builtin_times); -} - -ao_poly -ao_scheme_do_divide(struct ao_scheme_cons *cons) -{ - return ao_scheme_math(cons, builtin_divide); -} - -ao_poly -ao_scheme_do_quotient(struct ao_scheme_cons *cons) -{ - return ao_scheme_math(cons, builtin_quotient); -} - -ao_poly -ao_scheme_do_modulo(struct ao_scheme_cons *cons) -{ - return ao_scheme_math(cons, builtin_modulo); -} - -ao_poly -ao_scheme_do_remainder(struct ao_scheme_cons *cons) -{ - return ao_scheme_math(cons, builtin_remainder); -} - -static ao_poly -ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op) -{ - ao_poly left; - - if (!cons) - return _ao_scheme_bool_true; - - left = cons->car; - for (cons = ao_scheme_cons_cdr(cons); cons; cons = ao_scheme_cons_cdr(cons)) { - ao_poly right = cons->car; - - if (op == builtin_equal && left == right) { - ; - } else { - 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, NULL); - int32_t r = ao_scheme_poly_integer(right, NULL); - - switch (op) { - case builtin_less: - if (!(l < r)) - return _ao_scheme_bool_false; - break; - case builtin_greater: - if (!(l > r)) - return _ao_scheme_bool_false; - break; - case builtin_less_equal: - if (!(l <= r)) - return _ao_scheme_bool_false; - break; - case builtin_greater_equal: - if (!(l >= r)) - return _ao_scheme_bool_false; - break; - case builtin_equal: - if (!(l == r)) - return _ao_scheme_bool_false; - default: - break; - } -#ifdef AO_SCHEME_FEATURE_FLOAT - } else if (ao_scheme_number_typep(lt) && ao_scheme_number_typep(rt)) { - float l, r; - - l = ao_scheme_poly_number(left); - r = ao_scheme_poly_number(right); - - switch (op) { - case builtin_less: - if (!(l < r)) - return _ao_scheme_bool_false; - break; - case builtin_greater: - if (!(l > r)) - return _ao_scheme_bool_false; - break; - case builtin_less_equal: - if (!(l <= r)) - return _ao_scheme_bool_false; - break; - case builtin_greater_equal: - if (!(l >= r)) - return _ao_scheme_bool_false; - break; - case builtin_equal: - if (!(l == r)) - return _ao_scheme_bool_false; - 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)->val, - ao_scheme_poly_string(right)->val); - switch (op) { - case builtin_less: - if (!(c < 0)) - return _ao_scheme_bool_false; - break; - case builtin_greater: - if (!(c > 0)) - return _ao_scheme_bool_false; - break; - case builtin_less_equal: - if (!(c <= 0)) - return _ao_scheme_bool_false; - break; - case builtin_greater_equal: - if (!(c >= 0)) - return _ao_scheme_bool_false; - break; - case builtin_equal: - if (!(c == 0)) - return _ao_scheme_bool_false; - break; - default: - break; - } - } else - return _ao_scheme_bool_false; - } - left = right; - } - return _ao_scheme_bool_true; -} - -ao_poly -ao_scheme_do_equal(struct ao_scheme_cons *cons) -{ - return ao_scheme_compare(cons, builtin_equal); -} - -ao_poly -ao_scheme_do_less(struct ao_scheme_cons *cons) -{ - return ao_scheme_compare(cons, builtin_less); -} - -ao_poly -ao_scheme_do_greater(struct ao_scheme_cons *cons) -{ - return ao_scheme_compare(cons, builtin_greater); -} - -ao_poly -ao_scheme_do_less_equal(struct ao_scheme_cons *cons) -{ - return ao_scheme_compare(cons, builtin_less_equal); -} - -ao_poly -ao_scheme_do_greater_equal(struct ao_scheme_cons *cons) -{ - return ao_scheme_compare(cons, builtin_greater_equal); -} - -ao_poly -ao_scheme_do_list_to_string(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_check_argc(_ao_scheme_atom_list2d3estring, cons, 1, 1)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_list2d3estring, cons, 0, AO_SCHEME_CONS, 1)) - return AO_SCHEME_NIL; - return ao_scheme_string_pack(ao_scheme_poly_cons(ao_scheme_arg(cons, 0))); -} - -ao_poly -ao_scheme_do_string_to_list(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_check_argc(_ao_scheme_atom_string2d3elist, cons, 1, 1)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_string2d3elist, cons, 0, AO_SCHEME_STRING, 0)) - return AO_SCHEME_NIL; - return ao_scheme_string_unpack(ao_scheme_poly_string(ao_scheme_arg(cons, 0))); -} - -ao_poly -ao_scheme_do_string_ref(struct ao_scheme_cons *cons) -{ - 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 (ao_scheme_exception) - return AO_SCHEME_NIL; - string = ao_scheme_poly_string(ao_scheme_arg(cons, 0))->val; - while (*string && ref) { - ++string; - --ref; - } - if (!*string) - return ao_scheme_error(AO_SCHEME_INVALID, "%v: string %v ref %v invalid", - _ao_scheme_atom_string2dref, - ao_scheme_arg(cons, 0), - ao_scheme_arg(cons, 1)); - return ao_scheme_int_poly(*string); -} - -ao_poly -ao_scheme_do_string_length(struct ao_scheme_cons *cons) -{ - 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->val)); -} - -ao_poly -ao_scheme_do_string_copy(struct ao_scheme_cons *cons) -{ - struct ao_scheme_string *string; - - if (!ao_scheme_check_argc(_ao_scheme_atom_string2dcopy, cons, 1, 1)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_string2dcopy, cons, 0, AO_SCHEME_STRING, 0)) - return AO_SCHEME_NIL; - string = ao_scheme_poly_string(ao_scheme_arg(cons, 0)); - return ao_scheme_string_poly(ao_scheme_string_copy(string)); -} - -ao_poly -ao_scheme_do_string_set(struct ao_scheme_cons *cons) -{ - char *string; - int32_t ref; - int32_t val; - - if (!ao_scheme_check_argc(_ao_scheme_atom_string2dset21, cons, 3, 3)) - 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))->val; - ref = ao_scheme_arg_int(_ao_scheme_atom_string2dset21, cons, 1); - if (ao_scheme_exception) - return AO_SCHEME_NIL; - val = ao_scheme_arg_int(_ao_scheme_atom_string2dset21, cons, 2); - if (ao_scheme_exception) - return AO_SCHEME_NIL; - while (*string && ref) { - ++string; - --ref; - } - if (!*string) - return ao_scheme_error(AO_SCHEME_INVALID, "%v: string %v ref %v invalid", - _ao_scheme_atom_string2dset21, - ao_scheme_arg(cons, 0), - ao_scheme_arg(cons, 1)); - *string = val; - return ao_scheme_int_poly(*string); -} - -ao_poly -ao_scheme_do_flush_output(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_check_argc(_ao_scheme_atom_flush2doutput, cons, 0, 0)) - return AO_SCHEME_NIL; - ao_scheme_os_flush(); - return _ao_scheme_bool_true; -} - -ao_poly -ao_scheme_do_led(struct ao_scheme_cons *cons) -{ - int32_t led; - 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 (ao_scheme_exception) - return AO_SCHEME_NIL; - led = ao_scheme_arg(cons, 0); - ao_scheme_os_led(ao_scheme_poly_int(led)); - return led; -} - -ao_poly -ao_scheme_do_delay(struct ao_scheme_cons *cons) -{ - int32_t delay; - - 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 (ao_scheme_exception) - return AO_SCHEME_NIL; - ao_scheme_os_delay(delay); - return delay; -} - -ao_poly -ao_scheme_do_eval(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_check_argc(_ao_scheme_atom_eval, cons, 1, 1)) - return AO_SCHEME_NIL; - ao_scheme_stack->state = eval_sexpr; - return cons->car; -} - -ao_poly -ao_scheme_do_apply(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_check_argc(_ao_scheme_atom_apply, cons, 2, INT_MAX)) - return AO_SCHEME_NIL; - ao_scheme_stack->state = eval_apply; - return ao_scheme_cons_poly(cons); -} - -ao_poly -ao_scheme_do_read(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_check_argc(_ao_scheme_atom_read, cons, 0, 0)) - return AO_SCHEME_NIL; - return ao_scheme_read(); -} - -ao_poly -ao_scheme_do_collect(struct ao_scheme_cons *cons) -{ - int free; - (void) cons; - free = ao_scheme_collect(AO_SCHEME_COLLECT_FULL); - return ao_scheme_integer_poly(free); -} - -ao_poly -ao_scheme_do_nullp(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) - return AO_SCHEME_NIL; - if (ao_scheme_arg(cons, 0) == AO_SCHEME_NIL) - return _ao_scheme_bool_true; - else - return _ao_scheme_bool_false; -} - -ao_poly -ao_scheme_do_not(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) - return AO_SCHEME_NIL; - if (ao_scheme_arg(cons, 0) == _ao_scheme_bool_false) - return _ao_scheme_bool_true; - else - return _ao_scheme_bool_false; -} - -static ao_poly -ao_scheme_do_typep(int type, struct ao_scheme_cons *cons) -{ - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) - return AO_SCHEME_NIL; - if (ao_scheme_poly_type(ao_scheme_arg(cons, 0)) == type) - return _ao_scheme_bool_true; - return _ao_scheme_bool_false; -} - -ao_poly -ao_scheme_do_pairp(struct ao_scheme_cons *cons) -{ - ao_poly v; - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) - return AO_SCHEME_NIL; - v = ao_scheme_arg(cons, 0); - if (ao_scheme_is_pair(v)) - return _ao_scheme_bool_true; - return _ao_scheme_bool_false; -} - -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))) { - case AO_SCHEME_INT: - case AO_SCHEME_BIGINT: - return _ao_scheme_bool_true; - 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 -ao_scheme_do_stringp(struct ao_scheme_cons *cons) -{ - return ao_scheme_do_typep(AO_SCHEME_STRING, cons); -} - -ao_poly -ao_scheme_do_symbolp(struct ao_scheme_cons *cons) -{ - return ao_scheme_do_typep(AO_SCHEME_ATOM, cons); -} - -ao_poly -ao_scheme_do_booleanp(struct ao_scheme_cons *cons) -{ - return ao_scheme_do_typep(AO_SCHEME_BOOL, cons); -} - -ao_poly -ao_scheme_do_procedurep(struct ao_scheme_cons *cons) -{ - 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_BUILTIN: - case AO_SCHEME_LAMBDA: - return _ao_scheme_bool_true; - default: - return _ao_scheme_bool_false; - } -} - -/* This one is special -- a list is either nil or - * a 'proper' list with only cons cells - */ -ao_poly -ao_scheme_do_listp(struct ao_scheme_cons *cons) -{ - ao_poly v; - if (!ao_scheme_check_argc(_ao_scheme_atom_list3f, cons, 1, 1)) - return AO_SCHEME_NIL; - v = ao_scheme_arg(cons, 0); - for (;;) { - if (v == AO_SCHEME_NIL) - return _ao_scheme_bool_true; - if (!ao_scheme_is_cons(v)) - return _ao_scheme_bool_false; - v = ao_scheme_poly_cons(v)->cdr; - } -} - -ao_poly -ao_scheme_do_set_car(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 2, 2)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_CONS, 0)) - return AO_SCHEME_NIL; - return ao_scheme_poly_cons(ao_scheme_arg(cons, 0))->car = ao_scheme_arg(cons, 1); -} - -ao_poly -ao_scheme_do_set_cdr(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 2, 2)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_CONS, 0)) - return AO_SCHEME_NIL; - return ao_scheme_poly_cons(ao_scheme_arg(cons, 0))->cdr = ao_scheme_arg(cons, 1); -} - -ao_poly -ao_scheme_do_symbol_to_string(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) - 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_atom_to_string(ao_scheme_poly_atom(ao_scheme_arg(cons, 0)))); -} - -ao_poly -ao_scheme_do_string_to_symbol(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) - return AO_SCHEME_NIL; - 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_string_to_atom(ao_scheme_poly_string(ao_scheme_arg(cons, 0))));; -} - -ao_poly -ao_scheme_do_read_char(struct ao_scheme_cons *cons) -{ - int c; - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) - return AO_SCHEME_NIL; - c = getchar(); - return ao_scheme_int_poly(c); -} - -ao_poly -ao_scheme_do_write_char(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) - 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), NULL)); - return _ao_scheme_bool_true; -} - -ao_poly -ao_scheme_do_exit(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) - return AO_SCHEME_NIL; - ao_scheme_exception |= AO_SCHEME_EXIT; - return _ao_scheme_bool_true; -} - -ao_poly -ao_scheme_do_current_jiffy(struct ao_scheme_cons *cons) -{ - int jiffy; - - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) - return AO_SCHEME_NIL; - jiffy = ao_scheme_os_jiffy(); - return (ao_scheme_int_poly(jiffy)); -} - -ao_poly -ao_scheme_do_current_second(struct ao_scheme_cons *cons) -{ - int second; - - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) - return AO_SCHEME_NIL; - second = ao_scheme_os_jiffy() / AO_SCHEME_JIFFIES_PER_SECOND; - return (ao_scheme_int_poly(second)); -} - -ao_poly -ao_scheme_do_jiffies_per_second(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 0, 0)) - return AO_SCHEME_NIL; - 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) -{ - return ao_scheme_vector_poly(ao_scheme_list_to_vector(cons)); -} - -ao_poly -ao_scheme_do_make_vector(struct ao_scheme_cons *cons) -{ - int32_t k; - - 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 (ao_scheme_exception) - return AO_SCHEME_NIL; - return ao_scheme_vector_poly(ao_scheme_vector_alloc(k, ao_scheme_arg(cons, 1))); -} - -ao_poly -ao_scheme_do_vector_ref(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_check_argc(_ao_scheme_atom_vector2dref, cons, 2, 2)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_vector2dref, cons, 0, AO_SCHEME_VECTOR, 0)) - return AO_SCHEME_NIL; - return ao_scheme_vector_get(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1)); -} - -ao_poly -ao_scheme_do_vector_set(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_check_argc(_ao_scheme_atom_vector2dset21, cons, 3, 3)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_vector2dset21, cons, 0, AO_SCHEME_VECTOR, 0)) - return AO_SCHEME_NIL; - return ao_scheme_vector_set(ao_scheme_arg(cons, 0), ao_scheme_arg(cons, 1), ao_scheme_arg(cons, 2)); -} - -ao_poly -ao_scheme_do_list_to_vector(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_check_argc(_ao_scheme_atom_list2d3evector, cons, 1, 1)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_list2d3evector, cons, 0, AO_SCHEME_CONS, 0)) - return AO_SCHEME_NIL; - return ao_scheme_vector_poly(ao_scheme_list_to_vector(ao_scheme_poly_cons(ao_scheme_arg(cons, 0)))); -} - -ao_poly -ao_scheme_do_vector_to_list(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_check_argc(_ao_scheme_atom_vector2d3elist, cons, 1, 1)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_vector2d3elist, cons, 0, AO_SCHEME_VECTOR, 0)) - return AO_SCHEME_NIL; - return ao_scheme_cons_poly(ao_scheme_vector_to_list(ao_scheme_poly_vector(ao_scheme_arg(cons, 0)))); -} - -ao_poly -ao_scheme_do_vector_length(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_check_argc(_ao_scheme_atom_vector2d3elist, cons, 1, 1)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_vector2d3elist, cons, 0, AO_SCHEME_VECTOR, 0)) - return AO_SCHEME_NIL; - return ao_scheme_integer_poly(ao_scheme_poly_vector(ao_scheme_arg(cons, 0))->length); -} - -ao_poly -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 deleted file mode 100644 index 23adf6ed..00000000 --- a/src/scheme/ao_scheme_builtin.txt +++ /dev/null @@ -1,84 +0,0 @@ -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<? -all f_lambda greater > 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? -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! -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_cons.c b/src/scheme/ao_scheme_cons.c deleted file mode 100644 index a9ff5acd..00000000 --- a/src/scheme/ao_scheme_cons.c +++ /dev/null @@ -1,236 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * 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" - -static void cons_mark(void *addr) -{ - struct ao_scheme_cons *cons = addr; - - for (;;) { - ao_poly cdr = cons->cdr; - - ao_scheme_poly_mark(cons->car, 1); - if (!cdr) - break; - if (!ao_scheme_is_cons(cdr)) { - ao_scheme_poly_mark(cdr, 0); - break; - } - cons = ao_scheme_poly_cons(cdr); - if (ao_scheme_mark_memory(&ao_scheme_cons_type, cons)) - break; - } -} - -static int cons_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_scheme_cons); -} - -static void cons_move(void *addr) -{ - struct ao_scheme_cons *cons = addr; - - if (!cons) - return; - - for (;;) { - ao_poly cdr; - struct ao_scheme_cons *c; - int ret; - - MDBG_MOVE("cons_move start %d (%d, %d)\n", - MDBG_OFFSET(cons), MDBG_OFFSET(ao_scheme_ref(cons->car)), MDBG_OFFSET(ao_scheme_ref(cons->cdr))); - (void) ao_scheme_poly_move(&cons->car, 1); - cdr = cons->cdr; - if (!cdr) - break; - if (!ao_scheme_is_cons(cdr)) { - (void) ao_scheme_poly_move(&cons->cdr, 0); - break; - } - c = ao_scheme_poly_cons(cdr); - ret = ao_scheme_move_memory(&ao_scheme_cons_type, (void **) &c); - if (c != ao_scheme_poly_cons(cons->cdr)) - cons->cdr = ao_scheme_cons_poly(c); - MDBG_MOVE("cons_move end %d (%d, %d)\n", - MDBG_OFFSET(cons), MDBG_OFFSET(ao_scheme_ref(cons->car)), MDBG_OFFSET(ao_scheme_ref(cons->cdr))); - if (ret) - break; - cons = c; - } -} - -const struct ao_scheme_type ao_scheme_cons_type = { - .mark = cons_mark, - .size = cons_size, - .move = cons_move, - .name = "cons", -}; - -struct ao_scheme_cons *ao_scheme_cons_free_list; - -struct ao_scheme_cons * -ao_scheme_cons_cons(ao_poly car, ao_poly cdr) -{ - struct ao_scheme_cons *cons; - - if (ao_scheme_cons_free_list) { - cons = ao_scheme_cons_free_list; - ao_scheme_cons_free_list = ao_scheme_poly_cons(cons->cdr); - } else { - ao_scheme_poly_stash(car); - ao_scheme_poly_stash(cdr); - cons = ao_scheme_alloc(sizeof (struct ao_scheme_cons)); - cdr = ao_scheme_poly_fetch(); - car = ao_scheme_poly_fetch(); - if (!cons) - return NULL; - } - cons->car = car; - cons->cdr = cdr; - return cons; -} - -struct ao_scheme_cons * -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)) { - (void) ao_scheme_error(AO_SCHEME_INVALID, "improper cdr %v", cdr); - return NULL; - } - return ao_scheme_poly_cons(cdr); -} - -ao_poly -ao_scheme_cons(ao_poly car, ao_poly cdr) -{ - return ao_scheme_cons_poly(ao_scheme_cons_cons(car, cdr)); -} - -struct ao_scheme_cons * -ao_scheme_cons_copy(struct ao_scheme_cons *cons) -{ - struct ao_scheme_cons *head = NULL; - struct ao_scheme_cons *tail = NULL; - - while (cons) { - struct ao_scheme_cons *new; - ao_poly cdr; - - ao_scheme_cons_stash(cons); - ao_scheme_cons_stash(head); - ao_scheme_cons_stash(tail); - new = ao_scheme_alloc(sizeof (struct ao_scheme_cons)); - 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; - new->cdr = AO_SCHEME_NIL; - if (!head) - head = new; - else - tail->cdr = ao_scheme_cons_poly(new); - tail = new; - cdr = cons->cdr; - if (!ao_scheme_is_cons(cdr)) { - tail->cdr = cdr; - break; - } - cons = ao_scheme_poly_cons(cdr); - } - return head; -} - -void -ao_scheme_cons_free(struct ao_scheme_cons *cons) -{ -#if DBG_FREE_CONS - ao_scheme_cons_check(cons); -#endif - while (cons) { - ao_poly cdr = cons->cdr; - cons->cdr = ao_scheme_cons_poly(ao_scheme_cons_free_list); - ao_scheme_cons_free_list = cons; - cons = ao_scheme_poly_cons(cdr); - } -} - -void -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 written = 0; - - ao_scheme_print_start(); - printf("("); - while (cons) { - 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, write); - - /* keep track of how many pairs have been printed */ - written++; - - cdr = cons->cdr; - if (!ao_scheme_is_cons(cdr)) { - printf(" . "); - ao_scheme_poly_write(cdr, write); - break; - } - cons = ao_scheme_poly_cons(cdr); - } - printf(")"); - - if (ao_scheme_print_stop()) { - - /* 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); - } - } -} - -int -ao_scheme_cons_length(struct ao_scheme_cons *cons) -{ - int len = 0; - while (cons) { - len++; - cons = ao_scheme_cons_cdr(cons); - } - return len; -} diff --git a/src/scheme/ao_scheme_const.scheme b/src/scheme/ao_scheme_const.scheme deleted file mode 100644 index 4616477f..00000000 --- a/src/scheme/ao_scheme_const.scheme +++ /dev/null @@ -1,807 +0,0 @@ -; -; Copyright © 2016 Keith Packard <keithp@keithp.com> -; -; 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 (name value) - (list - def - (list quote name) - value) - ) - ) - -(begin - (def! append - (lambda args - (def! append-list - (lambda (a b) - (cond ((null? a) b) - (else (cons (car a) (append-list (cdr a) b))) - ) - ) - ) - - (def! append-lists - (lambda (lists) - (cond ((null? lists) lists) - ((null? (cdr lists)) (car lists)) - (else (append-list (car lists) (append-lists (cdr lists)))) - ) - ) - ) - (append-lists args) - ) - ) - 'append) - -(append '(a b c) '(d e f) '(g h i)) - - ; boolean operators - -(begin - (def! or - (macro l - (def! _or - (lambda (l) - (cond ((null? l) #f) - ((null? (cdr l)) - (car l)) - (else - (list - cond - (list - (car l)) - (list - 'else - (_or (cdr l)) - ) - ) - ) - ) - ) - ) - (_or l))) - 'or) - - ; execute to resolve macros - -(or #f #t) - -(begin - (def! and - (macro l - (def! _and - (lambda (l) - (cond ((null? l) #t) - ((null? (cdr l)) - (car l)) - (else - (list - cond - (list - (car l) - (_and (cdr l)) - ) - ) - ) - ) - ) - ) - (_and l) - ) - ) - 'and) - - ; execute to resolve macros - -(and #t #f) - -(begin - (def! quasiquote - (macro (x) - (def! constant? - ; A constant value is either a pair starting with quote, - ; or anything which is neither a pair nor a symbol - - (lambda (exp) - (cond ((pair? exp) - (eq? (car exp) 'quote) - ) - (else - (not (symbol? exp)) - ) - ) - ) - ) - (def! combine-skeletons - (lambda (left right exp) - (cond - ((and (constant? left) (constant? right)) - (cond ((and (eqv? (eval left) (car exp)) - (eqv? (eval right) (cdr exp))) - (list 'quote exp) - ) - (else - (list 'quote (cons (eval left) (eval right))) - ) - ) - ) - ((null? right) - (list 'list left) - ) - ((and (pair? right) (eq? (car right) 'list)) - (cons 'list (cons left (cdr right))) - ) - (else - (list 'cons left right) - ) - ) - ) - ) - - (def! expand-quasiquote - (lambda (exp nesting) - (cond - - ; non cons -- constants - ; themselves, others are - ; quoted - - ((not (pair? exp)) - (cond ((constant? exp) - exp - ) - (else - (list 'quote exp) - ) - ) - ) - - ; check for an unquote exp and - ; add the param unquoted - - ((and (eq? (car exp) 'unquote) (= (length exp) 2)) - (cond ((= nesting 0) - (car (cdr exp)) - ) - (else - (combine-skeletons ''unquote - (expand-quasiquote (cdr exp) (- nesting 1)) - exp)) - ) - ) - - ; nested quasi-quote -- - ; construct the right - ; expression - - ((and (eq? (car exp) 'quasiquote) (= (length exp) 2)) - (combine-skeletons ''quasiquote - (expand-quasiquote (cdr exp) (+ nesting 1)) - exp)) - - ; check for an - ; unquote-splicing member, - ; compute the expansion of the - ; value and append the rest of - ; the quasiquote result to it - - ((and (pair? (car exp)) - (eq? (car (car exp)) 'unquote-splicing) - (= (length (car exp)) 2)) - (cond ((= nesting 0) - (list 'append (car (cdr (car exp))) - (expand-quasiquote (cdr exp) nesting)) - ) - (else - (combine-skeletons (expand-quasiquote (car exp) (- nesting 1)) - (expand-quasiquote (cdr exp) nesting) - exp)) - ) - ) - - ; for other lists, just glue - ; the expansion of the first - ; element to the expansion of - ; the rest of the list - - (else (combine-skeletons (expand-quasiquote (car exp) nesting) - (expand-quasiquote (cdr exp) nesting) - exp) - ) - ) - ) - ) - (def! result (expand-quasiquote x 0)) - result - ) - ) - 'quasiquote) - - ; - ; 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 x y z) sexprs ...) - ; - -(begin - (def! define - (macro (first . rest) - ; check for alternate lambda definition form - - (cond ((pair? first) - (set! rest - (append - (list - 'lambda - (cdr first)) - rest)) - (set! first (car first)) - ) - (else - (set! rest (car rest)) - ) - ) - (def! result `(,begin - (,def (,quote ,first) ,rest) - (,quote ,first)) - ) - result - ) - ) - '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 <condition> <if-true>) - ; (if <condition> <if-true> <if-false) - -(define if - (macro (test . args) - (cond ((null? (cdr args)) - `(cond (,test ,(car args))) - ) - (else - `(cond (,test ,(car args)) - (else ,(cadr args))) - ) - ) - ) - ) - -(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) `(eq? ,value 0))) - -(zero? 1) -(zero? 0) -(zero? "hello") - -(define positive? (macro (value) `(> ,value 0))) - -(positive? 12) -(positive? -12) - -(define negative? (macro (value) `(< ,value 0))) - -(negative? 12) -(negative? -12) - -(define (abs x) (if (>= x 0) x (- x))) - -(abs 12) -(abs -12) - -(define max (lambda (first . rest) - (while (not (null? rest)) - (cond ((< first (car rest)) - (set! first (car rest))) - ) - (set! rest (cdr rest)) - ) - first) - ) - -(max 1 2 3) -(max 3 2 1) - -(define min (lambda (first . rest) - (while (not (null? rest)) - (cond ((> first (car rest)) - (set! first (car rest))) - ) - (set! rest (cdr rest)) - ) - first) - ) - -(min 1 2 3) -(min 3 2 1) - -(define (even? x) (zero? (% x 2))) - -(even? 2) -(even? -2) -(even? 3) -(even? -1) - -(define (odd? x) (not (even? x))) - -(odd? 2) -(odd? -2) -(odd? 3) -(odd? -1) - - -(define (list-tail x k) - (if (zero? k) - x - (list-tail (cdr x (- k 1))) - ) - ) - -(define (list-ref x k) - (car (list-tail x k)) - ) - - ; define a set of local - ; variables all at once 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 (vars . exprs) - (define (make-names vars) - (cond ((not (null? vars)) - (cons (car (car vars)) - (make-names (cdr vars)))) - (else ()) - ) - ) - - ; the parameters to the lambda is a list - ; of nils of the right length - - (define (make-vals vars) - (cond ((not (null? vars)) - (cons (cond ((null? (cdr (car vars))) ()) - (else - (car (cdr (car vars)))) - ) - (make-vals (cdr vars)))) - (else ()) - ) - ) - ; prepend the set operations - ; to the expressions - - ; build the lambda. - - `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars)) - ) - ) - - -(let ((x 1) (y)) (set! y 2) (+ x y)) - - ; 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 (vars . exprs) - - ; - ; make the list of names in the let - ; - - (define (make-names vars) - (cond ((not (null? vars)) - (cons (car (car vars)) - (make-names (cdr vars)))) - (else ()) - ) - ) - - ; the set of expressions is - ; the list of set expressions - ; pre-pended to the - ; expressions to evaluate - - (define (make-exprs vars exprs) - (cond ((null? vars) exprs) - (else - (cons - (list set - (list quote - (car (car vars)) - ) - (cond ((null? (cdr (car vars))) ()) - (else (cadr (car vars)))) - ) - (make-exprs (cdr vars) exprs) - ) - ) - ) - ) - - ; the parameters to the lambda is a list - ; of nils of the right length - - (define (make-nils vars) - (cond ((null? vars) ()) - (else (cons () (make-nils (cdr vars)))) - ) - ) - ; build the lambda. - - `((lambda ,(make-names vars) ,@(make-exprs vars exprs)) ,@(make-nils vars)) - ) - ) - -(let* ((x 1) (y x)) (+ x y)) - -(define when (macro (test . l) `(cond (,test ,@l)))) - -(when #t (write 'when)) - -(define unless (macro (test . l) `(cond ((not ,test) ,@l)))) - -(unless #f (write 'unless)) - -(define (reverse list) - (let ((result ())) - (while (not (null? list)) - (set! result (cons (car list) result)) - (set! list (cdr list)) - ) - result) - ) - -(reverse '(1 2 3)) - -(define (list-tail x k) - (if (zero? k) - x - (list-tail (cdr x) (- k 1)))) - -(list-tail '(1 2 3) 2) - -(define (list-ref x k) (car (list-tail x k))) - -(list-ref '(1 2 3) 2) - - ; recursive equality - -(define (equal? a b) - (cond ((eq? a b) #t) - ((and (pair? a) (pair? b)) - (and (equal? (car a) (car b)) - (equal? (cdr a) (cdr b))) - ) - (else #f) - ) - ) - -(equal? '(a b c) '(a b c)) -(equal? '(a b c) '(a b b)) - -(define member (lambda (obj list . test?) - (cond ((null? list) - #f - ) - (else - (if (null? test?) (set! test? equal?) (set! test? (car test?))) - (if (test? obj (car list)) - list - (member obj (cdr list) test?)) - ) - ) - ) - ) - -(member '(2) '((1) (2) (3))) - -(member '(4) '((1) (2) (3))) - -(define (memq obj list) (member obj list eq?)) - -(memq 2 '(1 2 3)) - -(memq 4 '(1 2 3)) - -(memq '(2) '((1) (2) (3))) - -(define (memv obj list) (member obj list eqv?)) - -(memv 2 '(1 2 3)) - -(memv 4 '(1 2 3)) - -(memv '(2) '((1) (2) (3))) - -(define (_assoc obj list test?) - (if (null? list) - #f - (if (test? obj (caar list)) - (car list) - (_assoc obj (cdr list) test?) - ) - ) - ) - -(define (assq obj list) (_assoc obj list eq?)) -(define (assv obj list) (_assoc obj list eqv?)) -(define (assoc obj list) (_assoc obj list equal?)) - -(assq 'a '((a 1) (b 2) (c 3))) -(assv 'b '((a 1) (b 2) (c 3))) -(assoc '(c) '((a 1) (b 2) ((c) 3))) - -(define char? integer?) - -(char? #\q) -(char? "h") - -(define (char-upper-case? c) (<= #\A c #\Z)) - -(char-upper-case? #\a) -(char-upper-case? #\B) -(char-upper-case? #\0) -(char-upper-case? #\space) - -(define (char-lower-case? c) (<= #\a c #\a)) - -(char-lower-case? #\a) -(char-lower-case? #\B) -(char-lower-case? #\0) -(char-lower-case? #\space) - -(define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c))) - -(char-alphabetic? #\a) -(char-alphabetic? #\B) -(char-alphabetic? #\0) -(char-alphabetic? #\space) - -(define (char-numeric? c) (<= #\0 c #\9)) - -(char-numeric? #\a) -(char-numeric? #\B) -(char-numeric? #\0) -(char-numeric? #\space) - -(define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c))) - -(char-whitespace? #\a) -(char-whitespace? #\B) -(char-whitespace? #\0) -(char-whitespace? #\space) - -(define char->integer (macro (v) v)) -(define integer->char char->integer) - -(define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c)) - -(char-upcase #\a) -(char-upcase #\B) -(char-upcase #\0) -(char-upcase #\space) - -(define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c)) - -(char-downcase #\a) -(char-downcase #\B) -(char-downcase #\0) -(char-downcase #\space) - -(define string (lambda chars (list->string chars))) - -(display "apply\n") -(apply cons '(a b)) - -(define map - (lambda (proc . lists) - (define (args lists) - (cond ((null? lists) ()) - (else - (cons (caar lists) (args (cdr lists))) - ) - ) - ) - (define (next lists) - (cond ((null? lists) ()) - (else - (cons (cdr (car lists)) (next (cdr lists))) - ) - ) - ) - (define (domap lists) - (cond ((null? (car lists)) ()) - (else - (cons (apply proc (args lists)) (domap (next lists))) - ) - ) - ) - (domap lists) - ) - ) - -(map cadr '((a b) (d e) (g h))) - -(define for-each (lambda (proc . lists) - (apply map proc lists) - #t)) - -(for-each display '("hello" " " "world" "\n")) - -(define (_string-ml strings) - (if (null? strings) () - (cons (string->list (car strings)) (_string-ml (cdr strings))) - ) - ) - -(define string-map (lambda (proc . strings) - (list->string (apply map proc (_string-ml strings)))))) - -(string-map (lambda (x) (+ 1 x)) "HAL") - -(define string-for-each (lambda (proc . strings) - (apply for-each proc (_string-ml strings)))) - -(string-for-each write-char "IBM\n") - -(define (newline) (write-char #\newline)) - -(newline) - -(call-with-current-continuation - (lambda (exit) - (for-each (lambda (x) - (write "test" x) - (if (negative? x) - (exit x))) - '(54 0 37 -3 245 19)) - #t)) - - - ; `q -> (quote q) - ; `(q) -> (append (quote (q))) - ; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2))) - ; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3)) - - - -`(hello ,(+ 1 2) ,@(list 1 2 3) `foo) - - -(define repeat - (macro (count . rest) - (define counter '__count__) - (cond ((pair? count) - (set! counter (car count)) - (set! count (cadr count)) - ) - ) - `(let ((,counter 0) - (__max__ ,count) - ) - (while (< ,counter __max__) - ,@rest - (set! ,counter (+ ,counter 1)) - ) - ) - ) - ) - -(repeat 2 (write 'hello)) -(repeat (x 3) (write 'goodbye x)) - -(define case - (macro (test . l) - ; construct the body of the - ; case, dealing with the - ; lambda version ( => lambda) - - (define (_unarrow l) - (cond ((null? l) l) - ((eq? (car l) '=>) `(( ,(cadr l) __key__))) - (else l)) - ) - - ; Build the case elements, which is - ; simply a list of cond clauses - - (define (_case l) - - (cond ((null? l) ()) - - ; else case - - ((eq? (caar l) 'else) - `((else ,@(_unarrow (cdr (car l)))))) - - ; regular case - - (else - (cons - `((eqv? ,(caar l) __key__) - ,@(_unarrow (cdr (car l)))) - (_case (cdr l))) - ) - ) - ) - - ; now construct the overall - ; expression, using a lambda - ; to hold the computed value - ; of the test expression - - `((lambda (__key__) - (cond ,@(_case l))) ,test) - ) - ) - -(case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) diff --git a/src/scheme/ao_scheme_error.c b/src/scheme/ao_scheme_error.c deleted file mode 100644 index 6a71ca51..00000000 --- a/src/scheme/ao_scheme_error.c +++ /dev/null @@ -1,75 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * 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 <stdarg.h> - -void -ao_scheme_vprintf(const char *format, va_list args) -{ - char c; - - while ((c = *format++) != '\0') { - if (c == '%') { - switch (c = *format++) { - case 'v': - 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 *)); - break; - case 'd': - printf("%d", va_arg(args, int)); - break; - case 's': - printf("%s", va_arg(args, char *)); - break; - default: - putchar(c); - break; - } - } else - putchar(c); - } -} - -void -ao_scheme_printf(const char *format, ...) -{ - va_list args; - va_start(args, format); - ao_scheme_vprintf(format, args); - va_end(args); -} - -ao_poly -ao_scheme_error(int error, const char *format, ...) -{ - va_list args; - - ao_scheme_exception |= error; - va_start(args, format); - ao_scheme_vprintf(format, args); - putchar('\n'); - va_end(args); - 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), 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_eval.c b/src/scheme/ao_scheme_eval.c deleted file mode 100644 index 91f6a84f..00000000 --- a/src/scheme/ao_scheme_eval.c +++ /dev/null @@ -1,570 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * 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 <assert.h> - -struct ao_scheme_stack *ao_scheme_stack; -ao_poly ao_scheme_v; - -ao_poly -ao_scheme_set_cond(struct ao_scheme_cons *c) -{ - ao_scheme_stack->state = eval_cond; - ao_scheme_stack->sexprs = ao_scheme_cons_poly(c); - return AO_SCHEME_NIL; -} - -static int -func_type(ao_poly func) -{ - if (func == AO_SCHEME_NIL) - return ao_scheme_error(AO_SCHEME_INVALID, "func is nil"); - switch (ao_scheme_poly_type(func)) { - case AO_SCHEME_BUILTIN: - return ao_scheme_poly_builtin(func)->args & AO_SCHEME_FUNC_MASK; - case AO_SCHEME_LAMBDA: - return ao_scheme_poly_lambda(func)->args; - case AO_SCHEME_STACK: - return AO_SCHEME_FUNC_LAMBDA; - default: - ao_scheme_error(AO_SCHEME_INVALID, "not a func"); - return -1; - } -} - -/* - * Flattened eval to avoid stack issues - */ - -/* - * Evaluate an s-expression - * - * For a list, evaluate all of the elements and - * then execute the resulting function call. - * - * Each element of the list is evaluated in - * a clean stack context. - * - * The current stack state is set to 'formal' so that - * when the evaluation is complete, the value - * will get appended to the values list. - * - * For other types, compute the value directly. - */ - -static int -ao_scheme_eval_sexpr(void) -{ - DBGI("sexpr: %v\n", ao_scheme_v); - switch (ao_scheme_poly_type(ao_scheme_v)) { - case AO_SCHEME_CONS: - if (ao_scheme_v == AO_SCHEME_NIL) { - if (!ao_scheme_stack->values) { - /* - * empty list evaluates to empty list - */ - ao_scheme_v = AO_SCHEME_NIL; - ao_scheme_stack->state = eval_val; - } else { - /* - * done with arguments, go execute it - */ - ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->values)->car; - ao_scheme_stack->state = eval_exec; - } - } else { - if (!ao_scheme_stack->values) - ao_scheme_stack->list = ao_scheme_v; - /* - * Evaluate another argument and then switch - * to 'formal' to add the value to the values - * list - */ - ao_scheme_stack->sexprs = ao_scheme_v; - ao_scheme_stack->state = eval_formal; - if (!ao_scheme_stack_push()) - return 0; - /* - * push will reset the state to 'sexpr', which - * will evaluate the expression - */ - ao_scheme_v = ao_scheme_poly_cons(ao_scheme_v)->car; - } - break; - case AO_SCHEME_ATOM: - DBGI("..frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); - ao_scheme_v = ao_scheme_atom_get(ao_scheme_v); - /* fall through */ - default: - ao_scheme_stack->state = eval_val; - break; - } - DBGI(".. result "); DBG_POLY(ao_scheme_v); DBG("\n"); - return 1; -} - -/* - * A value has been computed. - * - * If the value was computed from a macro, - * then we want to reset the current context - * to evaluate the macro result again. - * - * If not a macro, then pop the stack. - * If the stack is empty, we're done. - * Otherwise, the stack will contain - * the next state. - */ - -static int -ao_scheme_eval_val(void) -{ - DBGI("val: "); DBG_POLY(ao_scheme_v); DBG("\n"); - /* - * Value computed, pop the stack - * to figure out what to do with the value - */ - ao_scheme_stack_pop(); - DBGI("..state %d\n", ao_scheme_stack ? ao_scheme_stack->state : -1); - return 1; -} - -/* - * A formal has been computed. - * - * If this is the first formal, then check to see if we've got a - * lamda, macro or nlambda. - * - * For lambda, go compute another formal. This will terminate - * when the sexpr state sees nil. - * - * For macro/nlambda, we're done, so move the sexprs into the values - * and go execute it. - * - * Macros have an additional step of saving a stack frame holding the - * macro value execution context, which then gets the result of the - * macro to run - */ - -static int -ao_scheme_eval_formal(void) -{ - ao_poly formal; - struct ao_scheme_stack *prev; - - DBGI("formal: "); DBG_POLY(ao_scheme_v); DBG("\n"); - - /* Check what kind of function we've got */ - if (!ao_scheme_stack->values) { - switch (func_type(ao_scheme_v)) { - case AO_SCHEME_FUNC_LAMBDA: - DBGI(".. lambda\n"); - break; - case AO_SCHEME_FUNC_MACRO: - /* Evaluate the result once more */ - ao_scheme_stack->state = eval_macro; - if (!ao_scheme_stack_push()) - return 0; - - /* After the function returns, take that - * value and re-evaluate it - */ - prev = ao_scheme_poly_stack(ao_scheme_stack->prev); - ao_scheme_stack->sexprs = prev->sexprs; - - DBGI(".. start macro\n"); - DBGI("\t.. sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); - DBGI("\t.. values "); DBG_POLY(ao_scheme_stack->values); DBG("\n"); - DBG_FRAMES(); - - /* fall through ... */ - case AO_SCHEME_FUNC_NLAMBDA: - DBGI(".. nlambda or macro\n"); - - /* use the raw sexprs as values */ - ao_scheme_stack->values = ao_scheme_stack->sexprs; - ao_scheme_stack->values_tail = AO_SCHEME_NIL; - ao_scheme_stack->state = eval_exec; - - /* ready to execute now */ - return 1; - case -1: - return 0; - } - } - - /* Append formal to list of values */ - formal = ao_scheme_cons(ao_scheme_v, AO_SCHEME_NIL); - if (!formal) - return 0; - - if (ao_scheme_stack->values_tail) - ao_scheme_poly_cons(ao_scheme_stack->values_tail)->cdr = formal; - else - ao_scheme_stack->values = formal; - ao_scheme_stack->values_tail = formal; - - DBGI(".. values "); DBG_POLY(ao_scheme_stack->values); DBG("\n"); - - /* - * Step to the next argument, if this is last, then - * 'sexpr' will end up switching to 'exec' - */ - ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; - - ao_scheme_stack->state = eval_sexpr; - - DBGI(".. "); DBG_POLY(ao_scheme_v); DBG("\n"); - return 1; -} - -/* - * Start executing a function call - * - * Most builtins are easy, just call the function. - * 'cond' is magic; it sticks the list of clauses - * in 'sexprs' and switches to 'cond' state. That - * bit of magic is done in ao_scheme_set_cond. - * - * Lambdas build a new frame to hold the locals and - * then re-use the current stack context to evaluate - * the s-expression from the lambda. - */ - -static int -ao_scheme_eval_exec(void) -{ - ao_poly v; - struct ao_scheme_builtin *builtin; - - DBGI("exec: "); DBG_POLY(ao_scheme_v); DBG(" values "); DBG_POLY(ao_scheme_stack->values); DBG ("\n"); - ao_scheme_stack->sexprs = AO_SCHEME_NIL; - switch (ao_scheme_poly_type(ao_scheme_v)) { - case AO_SCHEME_BUILTIN: - ao_scheme_stack->state = eval_val; - builtin = ao_scheme_poly_builtin(ao_scheme_v); - v = ao_scheme_func(builtin) ( - ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->values)->cdr)); - DBG_DO(if (!ao_scheme_exception && ao_scheme_poly_builtin(ao_scheme_v)->func == builtin_set) { - struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_stack->values); - ao_poly atom = ao_scheme_arg(cons, 1); - ao_poly val = ao_scheme_arg(cons, 2); - 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)) { - 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); - } - - ao_scheme_v = v; - ao_scheme_stack->values = AO_SCHEME_NIL; - ao_scheme_stack->values_tail = AO_SCHEME_NIL; - DBGI(".. result "); DBG_POLY(ao_scheme_v); DBG ("\n"); - DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); - break; - case AO_SCHEME_LAMBDA: - DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); - ao_scheme_stack->state = eval_begin; - v = ao_scheme_lambda_eval(); - ao_scheme_stack->sexprs = v; - ao_scheme_stack->values = AO_SCHEME_NIL; - ao_scheme_stack->values_tail = AO_SCHEME_NIL; - DBGI(".. sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); - break; - case AO_SCHEME_STACK: - DBGI(".. stack "); DBG_POLY(ao_scheme_v); DBG("\n"); - ao_scheme_v = ao_scheme_stack_eval(); - DBGI(".. value "); DBG_POLY(ao_scheme_v); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); - break; - } - return 1; -} - -/* - * Finish setting up the apply evaluation - * - * The value is the list to execute - */ -static int -ao_scheme_eval_apply(void) -{ - struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_v); - struct ao_scheme_cons *cdr, *prev; - - /* Glue the arguments into the right shape. That's all but the last - * concatenated onto the last - */ - cdr = cons; - for (;;) { - prev = cdr; - cdr = ao_scheme_poly_cons(prev->cdr); - if (cdr->cdr == AO_SCHEME_NIL) - break; - } - DBGI("before mangling: "); DBG_POLY(ao_scheme_v); DBG("\n"); - prev->cdr = cdr->car; - ao_scheme_stack->values = ao_scheme_v; - 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_stack_mark(ao_scheme_stack); - return 1; -} - -/* - * Start evaluating the next cond clause - * - * If the list of clauses is empty, then - * the result of the cond is nil. - * - * Otherwise, set the current stack state to 'cond_test' and create a - * new stack context to evaluate the test s-expression. Once that's - * complete, we'll land in 'cond_test' to finish the clause. - */ -static int -ao_scheme_eval_cond(void) -{ - DBGI("cond: "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); - if (!ao_scheme_stack->sexprs) { - ao_scheme_v = _ao_scheme_bool_false; - ao_scheme_stack->state = eval_val; - } else { - ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car; - if (!ao_scheme_is_pair(ao_scheme_v)) { - ao_scheme_error(AO_SCHEME_INVALID, "invalid cond clause"); - return 0; - } - ao_scheme_v = ao_scheme_poly_cons(ao_scheme_v)->car; - if (ao_scheme_v == _ao_scheme_atom_else) - ao_scheme_v = _ao_scheme_bool_true; - ao_scheme_stack->state = eval_cond_test; - if (!ao_scheme_stack_push()) - return 0; - } - return 1; -} - -/* - * Finish a cond clause. - * - * Check the value from the test expression, if - * non-nil, then set up to evaluate the value expression. - * - * Otherwise, step to the next clause and go back to the 'cond' - * state - */ -static int -ao_scheme_eval_cond_test(void) -{ - DBGI("cond_test: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); - if (ao_scheme_v != _ao_scheme_bool_false) { - struct ao_scheme_cons *car = ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car); - ao_poly c = car->cdr; - - if (c) { - ao_scheme_stack->state = eval_begin; - ao_scheme_stack->sexprs = c; - } else - ao_scheme_stack->state = eval_val; - } else { - ao_scheme_stack->sexprs = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; - DBGI("next cond: "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); - ao_scheme_stack->state = eval_cond; - } - return 1; -} - -/* - * Evaluate a list of sexprs, returning the value from the last one. - * - * ao_scheme_begin records the list in stack->sexprs, so we just need to - * walk that list. Set ao_scheme_v to the car of the list and jump to - * eval_sexpr. When that's done, it will land in eval_val. For all but - * the last, leave a stack frame with eval_begin set so that we come - * back here. For the last, don't add a stack frame so that we can - * just continue on. - */ -static int -ao_scheme_eval_begin(void) -{ - DBGI("begin: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); - - if (!ao_scheme_stack->sexprs) { - ao_scheme_v = AO_SCHEME_NIL; - ao_scheme_stack->state = eval_val; - } else { - ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car; - ao_scheme_stack->sexprs = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; - - /* If there are more sexprs to do, then come back here, otherwise - * return the value of the last one by just landing in eval_sexpr - */ - if (ao_scheme_stack->sexprs) { - ao_scheme_stack->state = eval_begin; - if (!ao_scheme_stack_push()) - return 0; - } - ao_scheme_stack->state = eval_sexpr; - } - return 1; -} - -/* - * Conditionally execute a list of sexprs while the first is true - */ -static int -ao_scheme_eval_while(void) -{ - DBGI("while: "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); - - ao_scheme_stack->values = ao_scheme_v; - if (!ao_scheme_stack->sexprs) { - ao_scheme_v = AO_SCHEME_NIL; - ao_scheme_stack->state = eval_val; - } else { - ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->car; - ao_scheme_stack->state = eval_while_test; - if (!ao_scheme_stack_push()) - return 0; - } - return 1; -} - -/* - * Check the while condition, terminate the loop if nil. Otherwise keep going - */ -static int -ao_scheme_eval_while_test(void) -{ - DBGI("while_test: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_scheme_stack->frame); DBG("\n"); - - if (ao_scheme_v != _ao_scheme_bool_false) { - ao_scheme_stack->values = ao_scheme_v; - ao_scheme_v = ao_scheme_poly_cons(ao_scheme_stack->sexprs)->cdr; - ao_scheme_stack->state = eval_while; - if (!ao_scheme_stack_push()) - return 0; - ao_scheme_stack->state = eval_begin; - ao_scheme_stack->sexprs = ao_scheme_v; - } - else - { - ao_scheme_stack->state = eval_val; - ao_scheme_v = ao_scheme_stack->values; - } - return 1; -} - -/* - * Replace the original sexpr with the macro expansion, then - * execute that - */ -static int -ao_scheme_eval_macro(void) -{ - DBGI("macro: "); DBG_POLY(ao_scheme_v); DBG(" sexprs "); DBG_POLY(ao_scheme_stack->sexprs); DBG("\n"); - - if (ao_scheme_v == AO_SCHEME_NIL) - ao_scheme_abort(); - 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"); - } - ao_scheme_stack->sexprs = AO_SCHEME_NIL; - ao_scheme_stack->state = eval_sexpr; - return 1; -} - -static int (*const evals[])(void) = { - [eval_sexpr] = ao_scheme_eval_sexpr, - [eval_val] = ao_scheme_eval_val, - [eval_formal] = ao_scheme_eval_formal, - [eval_exec] = ao_scheme_eval_exec, - [eval_apply] = ao_scheme_eval_apply, - [eval_cond] = ao_scheme_eval_cond, - [eval_cond_test] = ao_scheme_eval_cond_test, - [eval_begin] = ao_scheme_eval_begin, - [eval_while] = ao_scheme_eval_while, - [eval_while_test] = ao_scheme_eval_while_test, - [eval_macro] = ao_scheme_eval_macro, -}; - -const char * const ao_scheme_state_names[] = { - [eval_sexpr] = "sexpr", - [eval_val] = "val", - [eval_formal] = "formal", - [eval_exec] = "exec", - [eval_apply] = "apply", - [eval_cond] = "cond", - [eval_cond_test] = "cond_test", - [eval_begin] = "begin", - [eval_while] = "while", - [eval_while_test] = "while_test", - [eval_macro] = "macro", -}; - -/* - * Called at restore time to reset all execution state - */ - -void -ao_scheme_eval_clear_globals(void) -{ - ao_scheme_stack = NULL; - ao_scheme_frame_current = NULL; - ao_scheme_v = AO_SCHEME_NIL; -} - -int -ao_scheme_eval_restart(void) -{ - return ao_scheme_stack_push(); -} - -ao_poly -ao_scheme_eval(ao_poly _v) -{ - ao_scheme_v = _v; - - ao_scheme_frame_init(); - - if (!ao_scheme_stack_push()) - return AO_SCHEME_NIL; - - while (ao_scheme_stack) { - if (!(*evals[ao_scheme_stack->state])() || ao_scheme_exception) { - ao_scheme_stack_clear(); - return AO_SCHEME_NIL; - } - } - DBG_DO(if (ao_scheme_frame_current) {DBGI("frame left as "); DBG_POLY(ao_scheme_frame_poly(ao_scheme_frame_current)); DBG("\n");}); - ao_scheme_frame_current = NULL; - return ao_scheme_v; -} diff --git a/src/scheme/ao_scheme_float.c b/src/scheme/ao_scheme_float.c deleted file mode 100644 index d8501548..00000000 --- a/src/scheme/ao_scheme_float.c +++ /dev/null @@ -1,156 +0,0 @@ -/* - * Copyright © 2017 Keith Packard <keithp@keithp.com> - * - * 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 <math.h> - -#ifdef AO_SCHEME_FEATURE_FLOAT - -static void float_mark(void *addr) -{ - (void) addr; -} - -static int float_size(void *addr) -{ - if (!addr) - return 0; - return sizeof (struct ao_scheme_float); -} - -static void float_move(void *addr) -{ - (void) addr; -} - -const struct ao_scheme_type ao_scheme_float_type = { - .mark = float_mark, - .size = float_size, - .move = float_move, - .name = "float", -}; - -#ifndef FLOAT_FORMAT -#define FLOAT_FORMAT "%g" -#endif - -void -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)) { - if (v < 0) - printf("-"); - else - printf("+"); - printf("inf.0"); - } else - printf (FLOAT_FORMAT, v); -} - -float -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_FLOAT: - return ao_scheme_poly_float(p)->value; - } - } - return NAN; -} - -ao_poly -ao_scheme_float_get(float value) -{ - struct ao_scheme_float *f; - - f = ao_scheme_alloc(sizeof (struct ao_scheme_float)); - f->type = AO_SCHEME_FLOAT; - f->value = value; - return ao_scheme_float_poly(f); -} - -ao_poly -ao_scheme_do_inexactp(struct ao_scheme_cons *cons) -{ - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) - return AO_SCHEME_NIL; - if (ao_scheme_poly_type(ao_scheme_arg(cons, 0)) == AO_SCHEME_FLOAT) - return _ao_scheme_bool_true; - return _ao_scheme_bool_false; -} - -ao_poly -ao_scheme_do_finitep(struct ao_scheme_cons *cons) -{ - ao_poly value; - float f; - - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) - return AO_SCHEME_NIL; - value = ao_scheme_arg(cons, 0); - switch (ao_scheme_poly_type(value)) { - case AO_SCHEME_INT: - case AO_SCHEME_BIGINT: - return _ao_scheme_bool_true; - case AO_SCHEME_FLOAT: - f = ao_scheme_poly_float(value)->value; - if (!isnan(f) && !isinf(f)) - return _ao_scheme_bool_true; - } - return _ao_scheme_bool_false; -} - -ao_poly -ao_scheme_do_infinitep(struct ao_scheme_cons *cons) -{ - ao_poly value; - float f; - - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) - return AO_SCHEME_NIL; - value = ao_scheme_arg(cons, 0); - switch (ao_scheme_poly_type(value)) { - case AO_SCHEME_FLOAT: - f = ao_scheme_poly_float(value)->value; - if (isinf(f)) - return _ao_scheme_bool_true; - } - return _ao_scheme_bool_false; -} - -ao_poly -ao_scheme_do_sqrt(struct ao_scheme_cons *cons) -{ - ao_poly value; - - if (!ao_scheme_check_argc(_ao_scheme_atom_sqrt, cons, 1, 1)) - return AO_SCHEME_NIL; - value = ao_scheme_arg(cons, 0); - if (!ao_scheme_number_typep(ao_scheme_poly_type(value))) - 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_frame.c b/src/scheme/ao_scheme_frame.c deleted file mode 100644 index 16da62fb..00000000 --- a/src/scheme/ao_scheme_frame.c +++ /dev/null @@ -1,355 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * 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" - -static inline int -frame_vals_num_size(int num) -{ - return sizeof (struct ao_scheme_frame_vals) + num * sizeof (struct ao_scheme_val); -} - -static int -frame_vals_size(void *addr) -{ - struct ao_scheme_frame_vals *vals = addr; - return frame_vals_num_size(vals->size); -} - -static void -frame_vals_mark(void *addr) -{ - struct ao_scheme_frame_vals *vals = addr; - int f; - - for (f = 0; f < vals->size; f++) { - struct ao_scheme_val *v = &vals->vals[f]; - - ao_scheme_poly_mark(v->val, 0); - MDBG_MOVE("frame mark atom %s %d val %d at %d ", - ao_scheme_poly_atom(v->atom)->name, - MDBG_OFFSET(ao_scheme_ref(v->atom)), - MDBG_OFFSET(ao_scheme_ref(v->val)), f); - MDBG_DO(printf("\n")); - } -} - -static void -frame_vals_move(void *addr) -{ - struct ao_scheme_frame_vals *vals = addr; - int f; - - for (f = 0; f < vals->size; f++) { - struct ao_scheme_val *v = &vals->vals[f]; - - ao_scheme_poly_move(&v->atom, 0); - ao_scheme_poly_move(&v->val, 0); - MDBG_MOVE("frame move atom %s %d val %d at %d\n", - ao_scheme_poly_atom(v->atom)->name, - MDBG_OFFSET(ao_scheme_ref(v->atom)), - MDBG_OFFSET(ao_scheme_ref(v->val)), f); - } -} - -const struct ao_scheme_type ao_scheme_frame_vals_type = { - .mark = frame_vals_mark, - .size = frame_vals_size, - .move = frame_vals_move, - .name = "frame_vals" -}; - -static int -frame_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_scheme_frame); -} - -static void -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_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) - break; - if (ao_scheme_mark_memory(&ao_scheme_frame_type, frame)) - break; - } -} - -static void -frame_move(void *addr) -{ - struct ao_scheme_frame *frame = addr; - - for (;;) { - struct ao_scheme_frame *prev; - struct ao_scheme_frame_vals *vals; - int ret; - - MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); - 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; - ret = ao_scheme_move_memory(&ao_scheme_frame_type, (void **) &prev); - if (prev != ao_scheme_poly_frame(frame->prev)) { - MDBG_MOVE("frame prev moved from %d to %d\n", - MDBG_OFFSET(ao_scheme_poly_frame(frame->prev)), - MDBG_OFFSET(prev)); - frame->prev = ao_scheme_frame_poly(prev); - } - if (ret) - break; - frame = prev; - } -} - -const struct ao_scheme_type ao_scheme_frame_type = { - .mark = frame_mark, - .size = frame_size, - .move = frame_move, - .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, 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; - - ao_scheme_print_start(); - while (frame) { - if (written != 0) - printf(", "); - if (ao_scheme_print_mark_addr(frame)) { - printf("recurse..."); - 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); - } - } -} - -static int -ao_scheme_frame_find(struct ao_scheme_frame *frame, int top, ao_poly atom) -{ - struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); - int l = 0; - int r = top - 1; - - while (l <= r) { - int m = (l + r) >> 1; - if (vals->vals[m].atom < atom) - l = m + 1; - else - r = m - 1; - } - return l; -} - -ao_poly * -ao_scheme_frame_ref(struct ao_scheme_frame *frame, ao_poly atom) -{ - struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); - int l = ao_scheme_frame_find(frame, frame->num, atom); - - if (l >= frame->num) - return NULL; - - if (vals->vals[l].atom != atom) - return NULL; - return &vals->vals[l].val; -} - -struct ao_scheme_frame *ao_scheme_frame_free_list[AO_SCHEME_FRAME_FREE]; - -static struct ao_scheme_frame_vals * -ao_scheme_frame_vals_new(int num) -{ - struct ao_scheme_frame_vals *vals; - - vals = ao_scheme_alloc(frame_vals_num_size(num)); - if (!vals) - return NULL; - vals->type = AO_SCHEME_FRAME_VALS; - vals->size = num; - memset(vals->vals, '\0', num * sizeof (struct ao_scheme_val)); - return vals; -} - -struct ao_scheme_frame * -ao_scheme_frame_new(int num) -{ - struct ao_scheme_frame *frame; - struct ao_scheme_frame_vals *vals; - - if (num < AO_SCHEME_FRAME_FREE && (frame = ao_scheme_frame_free_list[num])) { - ao_scheme_frame_free_list[num] = ao_scheme_poly_frame(frame->prev); - vals = ao_scheme_poly_frame_vals(frame->vals); - } else { - frame = ao_scheme_alloc(sizeof (struct ao_scheme_frame)); - if (!frame) - return NULL; - frame->type = AO_SCHEME_FRAME; - frame->num = 0; - frame->prev = AO_SCHEME_NIL; - frame->vals = AO_SCHEME_NIL; - ao_scheme_frame_stash(frame); - vals = ao_scheme_frame_vals_new(num); - frame = ao_scheme_frame_fetch(); - if (!vals) - return NULL; - frame->vals = ao_scheme_frame_vals_poly(vals); - frame->num = num; - } - frame->prev = AO_SCHEME_NIL; - return frame; -} - -ao_poly -ao_scheme_frame_mark(struct ao_scheme_frame *frame) -{ - if (!frame) - return AO_SCHEME_NIL; - frame->type |= AO_SCHEME_FRAME_MARK; - return ao_scheme_frame_poly(frame); -} - -void -ao_scheme_frame_free(struct ao_scheme_frame *frame) -{ - if (frame && !ao_scheme_frame_marked(frame)) { - int num = frame->num; - if (num < AO_SCHEME_FRAME_FREE) { - struct ao_scheme_frame_vals *vals; - - vals = ao_scheme_poly_frame_vals(frame->vals); - memset(vals->vals, '\0', vals->size * sizeof (struct ao_scheme_val)); - frame->prev = ao_scheme_frame_poly(ao_scheme_frame_free_list[num]); - ao_scheme_frame_free_list[num] = frame; - } - } -} - -static struct ao_scheme_frame * -ao_scheme_frame_realloc(struct ao_scheme_frame *frame, int new_num) -{ - struct ao_scheme_frame_vals *vals; - struct ao_scheme_frame_vals *new_vals; - int copy; - - if (new_num == frame->num) - return frame; - ao_scheme_frame_stash(frame); - new_vals = ao_scheme_frame_vals_new(new_num); - frame = ao_scheme_frame_fetch(); - if (!new_vals) - return NULL; - vals = ao_scheme_poly_frame_vals(frame->vals); - copy = new_num; - if (copy > frame->num) - copy = frame->num; - memcpy(new_vals->vals, vals->vals, copy * sizeof (struct ao_scheme_val)); - frame->vals = ao_scheme_frame_vals_poly(new_vals); - frame->num = new_num; - return frame; -} - -void -ao_scheme_frame_bind(struct ao_scheme_frame *frame, int num, ao_poly atom, ao_poly val) -{ - struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); - int l = ao_scheme_frame_find(frame, num, atom); - - memmove(&vals->vals[l+1], - &vals->vals[l], - (num - l) * sizeof (struct ao_scheme_val)); - vals->vals[l].atom = atom; - vals->vals[l].val = val; -} - -ao_poly -ao_scheme_frame_add(struct ao_scheme_frame *frame, ao_poly atom, ao_poly val) -{ - ao_poly *ref = frame ? ao_scheme_frame_ref(frame, atom) : NULL; - - if (!ref) { - int f = frame->num; - ao_scheme_poly_stash(atom); - ao_scheme_poly_stash(val); - frame = ao_scheme_frame_realloc(frame, f + 1); - 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); - } else - *ref = val; - return val; -} - -struct ao_scheme_frame *ao_scheme_frame_global; -struct ao_scheme_frame *ao_scheme_frame_current; - -void -ao_scheme_frame_init(void) -{ - if (!ao_scheme_frame_global) - ao_scheme_frame_global = ao_scheme_frame_new(0); -} diff --git a/src/scheme/ao_scheme_int.c b/src/scheme/ao_scheme_int.c deleted file mode 100644 index 01b571c0..00000000 --- a/src/scheme/ao_scheme_int.c +++ /dev/null @@ -1,87 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * 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" - -void -ao_scheme_int_write(ao_poly p, bool write) -{ - int i = ao_scheme_poly_int(p); - (void) write; - printf("%d", i); -} - -#ifdef AO_SCHEME_FEATURE_BIGINT - -int32_t -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_BIGINT: - return ao_scheme_poly_bigint(p)->value; - } - if (fail) - *fail = true; - return 0; -} - -ao_poly -ao_scheme_integer_poly(int32_t p) -{ - struct ao_scheme_bigint *bi; - - 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 = p; - return ao_scheme_bigint_poly(bi); -} - -static void bigint_mark(void *addr) -{ - (void) addr; -} - -static int bigint_size(void *addr) -{ - if (!addr) - return 0; - return sizeof (struct ao_scheme_bigint); -} - -static void bigint_move(void *addr) -{ - (void) addr; -} - -const struct ao_scheme_type ao_scheme_bigint_type = { - .mark = bigint_mark, - .size = bigint_size, - .move = bigint_move, - .name = "bigint", -}; - -void -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 deleted file mode 100644 index e818d7b0..00000000 --- a/src/scheme/ao_scheme_lambda.c +++ /dev/null @@ -1,208 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * 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. - */ - -#include "ao_scheme.h" - -static int -lambda_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_scheme_lambda); -} - -static void -lambda_mark(void *addr) -{ - struct ao_scheme_lambda *lambda = addr; - - ao_scheme_poly_mark(lambda->code, 0); - ao_scheme_poly_mark(lambda->frame, 0); -} - -static void -lambda_move(void *addr) -{ - struct ao_scheme_lambda *lambda = addr; - - ao_scheme_poly_move(&lambda->code, 0); - ao_scheme_poly_move(&lambda->frame, 0); -} - -const struct ao_scheme_type ao_scheme_lambda_type = { - .size = lambda_size, - .mark = lambda_mark, - .move = lambda_move, - .name = "lambda", -}; - -void -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); - - printf("("); - printf("%s", ao_scheme_args_name(lambda->args)); - while (cons) { - printf(" "); - ao_scheme_poly_write(cons->car, write); - cons = ao_scheme_poly_cons(cons->cdr); - } - printf(")"); -} - -static ao_poly -ao_scheme_lambda_alloc(struct ao_scheme_cons *code, int args) -{ - struct ao_scheme_lambda *lambda; - ao_poly formal; - struct ao_scheme_cons *cons; - - formal = ao_scheme_arg(code, 0); - while (formal != AO_SCHEME_NIL) { - switch (ao_scheme_poly_type(formal)) { - case AO_SCHEME_CONS: - cons = ao_scheme_poly_cons(formal); - if (ao_scheme_poly_type(cons->car) != AO_SCHEME_ATOM) - return ao_scheme_error(AO_SCHEME_INVALID, "formal %p is not atom", cons->car); - formal = cons->cdr; - break; - case AO_SCHEME_ATOM: - formal = AO_SCHEME_NIL; - break; - default: - return ao_scheme_error(AO_SCHEME_INVALID, "formal %p is not atom", formal); - } - } - - ao_scheme_cons_stash(code); - lambda = ao_scheme_alloc(sizeof (struct ao_scheme_lambda)); - code = ao_scheme_cons_fetch(); - if (!lambda) - return AO_SCHEME_NIL; - - lambda->type = AO_SCHEME_LAMBDA; - lambda->args = args; - lambda->code = ao_scheme_cons_poly(code); - lambda->frame = ao_scheme_frame_mark(ao_scheme_frame_current); - DBGI("build frame: "); DBG_POLY(lambda->frame); DBG("\n"); - DBG_STACK(); - return ao_scheme_lambda_poly(lambda); -} - -ao_poly -ao_scheme_do_lambda(struct ao_scheme_cons *cons) -{ - return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_LAMBDA); -} - -ao_poly -ao_scheme_do_nlambda(struct ao_scheme_cons *cons) -{ - return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_NLAMBDA); -} - -ao_poly -ao_scheme_do_macro(struct ao_scheme_cons *cons) -{ - return ao_scheme_lambda_alloc(cons, AO_SCHEME_FUNC_MACRO); -} - -ao_poly -ao_scheme_lambda_eval(void) -{ - struct ao_scheme_lambda *lambda = ao_scheme_poly_lambda(ao_scheme_v); - struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_stack->values); - struct ao_scheme_cons *code = ao_scheme_poly_cons(lambda->code); - ao_poly formals; - struct ao_scheme_frame *next_frame; - int args_wanted; - ao_poly varargs = AO_SCHEME_NIL; - int args_provided; - int f; - struct ao_scheme_cons *vals; - - DBGI("lambda "); DBG_POLY(ao_scheme_lambda_poly(lambda)); DBG("\n"); - - args_wanted = 0; - for (formals = ao_scheme_arg(code, 0); - ao_scheme_is_pair(formals); - formals = ao_scheme_poly_cons(formals)->cdr) - ++args_wanted; - if (formals != AO_SCHEME_NIL) { - if (ao_scheme_poly_type(formals) != AO_SCHEME_ATOM) - return ao_scheme_error(AO_SCHEME_INVALID, "bad lambda form"); - varargs = formals; - } - - /* Create a frame to hold the variables - */ - args_provided = ao_scheme_cons_length(cons) - 1; - if (varargs == AO_SCHEME_NIL) { - if (args_wanted != args_provided) - return ao_scheme_error(AO_SCHEME_INVALID, "need %d args, got %d", args_wanted, args_provided); - } else { - if (args_provided < args_wanted) - return ao_scheme_error(AO_SCHEME_INVALID, "need at least %d args, got %d", args_wanted, args_provided); - } - - ao_scheme_poly_stash(varargs); - next_frame = ao_scheme_frame_new(args_wanted + (varargs != AO_SCHEME_NIL)); - varargs = ao_scheme_poly_fetch(); - if (!next_frame) - return AO_SCHEME_NIL; - - /* Re-fetch all of the values in case something moved */ - lambda = ao_scheme_poly_lambda(ao_scheme_v); - cons = ao_scheme_poly_cons(ao_scheme_stack->values); - code = ao_scheme_poly_cons(lambda->code); - formals = ao_scheme_arg(code, 0); - vals = ao_scheme_poly_cons(cons->cdr); - - next_frame->prev = lambda->frame; - ao_scheme_frame_current = next_frame; - ao_scheme_stack->frame = ao_scheme_frame_poly(ao_scheme_frame_current); - - for (f = 0; f < args_wanted; f++) { - struct ao_scheme_cons *arg = ao_scheme_poly_cons(formals); - DBGI("bind "); DBG_POLY(arg->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); - ao_scheme_frame_bind(next_frame, f, arg->car, vals->car); - formals = arg->cdr; - vals = ao_scheme_poly_cons(vals->cdr); - } - if (varargs) { - DBGI("bind "); DBG_POLY(varargs); DBG(" = "); DBG_POLY(ao_scheme_cons_poly(vals)); DBG("\n"); - /* - * Bind the rest of the arguments to the final parameter - */ - ao_scheme_frame_bind(next_frame, f, varargs, ao_scheme_cons_poly(vals)); - } else { - /* - * Mark the cons cells from the actuals as freed for immediate re-use, unless - * the actuals point into the source function (nlambdas and macros), or if the - * stack containing them was copied as a part of a continuation - */ - if (lambda->args == AO_SCHEME_FUNC_LAMBDA && !ao_scheme_stack_marked(ao_scheme_stack)) { - ao_scheme_stack->values = AO_SCHEME_NIL; - ao_scheme_cons_free(cons); - } - } - DBGI("eval frame: "); DBG_POLY(ao_scheme_frame_poly(next_frame)); DBG("\n"); - DBG_STACK(); - DBGI("eval code: "); DBG_POLY(code->cdr); DBG("\n"); - return code->cdr; -} diff --git a/src/scheme/ao_scheme_make_builtin b/src/scheme/ao_scheme_make_builtin deleted file mode 100644 index a4d8326f..00000000 --- a/src/scheme/ao_scheme_make_builtin +++ /dev/null @@ -1,276 +0,0 @@ -#!/usr/bin/nickle - -typedef struct { - string feature; - string type; - string c_name; - string[*] lisp_names; -} builtin_t; - -string[string] type_map = { - "lambda" => "LAMBDA", - "nlambda" => "NLAMBDA", - "macro" => "MACRO", - "f_lambda" => "F_LAMBDA", - "atom" => "atom", - "feature" => "feature", -}; - -string[*] -make_lisp(string[*] tokens) -{ - string[...] lisp = {}; - - if (dim(tokens) < 4) - return (string[1]) { tokens[dim(tokens) - 1] }; - return (string[dim(tokens)-3]) { [i] = tokens[i+3] }; -} - -builtin_t -read_builtin(file f) { - string line = File::fgets(f); - string[*] tokens = String::wordsplit(line, " \t"); - - return (builtin_t) { - .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), - }; -} - -builtin_t[*] -read_builtins(file f) { - builtin_t[...] builtins = {}; - - while (!File::end(f)) { - builtin_t b = read_builtin(f); - - if (b.type[0] != '#') - builtins[dim(builtins)] = b; - } - 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_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"); -} - -void -dump_casename(builtin_t[*] builtins) { - printf("#ifdef AO_SCHEME_BUILTIN_CASENAME\n"); - printf("#undef AO_SCHEME_BUILTIN_CASENAME\n"); - 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_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 (char *) \"???\";\n"); - printf("\t}\n"); - printf("}\n"); - printf("#endif /* AO_SCHEME_BUILTIN_CASENAME */\n"); -} - -void -cify_lisp(string l) { - for (int j = 0; j < String::length(l); j++) { - int c= l[j]; - if (Ctype::isalnum(c) || c == '_') - printf("%c", c); - else - printf("%02x", c); - } -} - -void -dump_arrayname(builtin_t[*] builtins) { - printf("#ifdef AO_SCHEME_BUILTIN_ARRAYNAME\n"); - 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_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"); - printf("#endif /* AO_SCHEME_BUILTIN_ARRAYNAME */\n"); -} - -void -dump_funcs(builtin_t[*] builtins) { - printf("#ifdef AO_SCHEME_BUILTIN_FUNCS\n"); - 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_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"); -} - -void -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_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"); -} - -void -dump_consts(builtin_t[*] builtins) { - printf("#ifdef AO_SCHEME_BUILTIN_CONSTS\n"); - printf("#undef AO_SCHEME_BUILTIN_CONSTS\n"); - printf("struct builtin_func funcs[] = {\n"); - for (int i = 0; i < dim(builtins); i++) { - if (is_func(builtins[i])) { - dump_ifdef(builtins[i]); - for (int j = 0; j < dim(builtins[i].lisp_names); j++) { - 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"); - printf("#endif /* AO_SCHEME_BUILTIN_CONSTS */\n"); -} - -void -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++) { - 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 <file>\n", argv[0]); - exit(1); - } - 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); - dump_funcs(builtins); - dump_decls(builtins); - dump_consts(builtins); - dump_atoms(builtins); - dump_atom_names(builtins); - dump_features(builtins); - } -} - -main(); diff --git a/src/scheme/ao_scheme_make_const.c b/src/scheme/ao_scheme_make_const.c deleted file mode 100644 index e34792c4..00000000 --- a/src/scheme/ao_scheme_make_const.c +++ /dev/null @@ -1,517 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * 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 <stdlib.h> -#include <ctype.h> -#include <unistd.h> -#include <getopt.h> -#include <stdbool.h> - -static struct ao_scheme_builtin * -ao_scheme_make_builtin(enum ao_scheme_builtin_id func, int args) { - struct ao_scheme_builtin *b = ao_scheme_alloc(sizeof (struct ao_scheme_builtin)); - - b->type = AO_SCHEME_BUILTIN; - b->func = func; - b->args = args; - return b; -} - -struct builtin_func { - const char *feature; - const char *name; - int args; - enum ao_scheme_builtin_id func; -}; - -struct builtin_atom { - const char *feature; - const 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_ATOM (sizeof atoms / sizeof atoms[0]) - -struct ao_scheme_frame *globals; - -static int -is_atom(int offset) -{ - struct ao_scheme_atom *a; - - for (a = ao_scheme_atoms; a; a = ao_scheme_poly_atom(a->next)) - if (((uint8_t *) a->name - ao_scheme_const) == offset) - return strlen(a->name); - return 0; -} - -#define AO_FEC_CRC_INIT 0xffff - -static inline uint16_t -ao_fec_crc_byte(uint8_t byte, uint16_t crc) -{ - uint8_t bit; - - for (bit = 0; bit < 8; bit++) { - if (((crc & 0x8000) >> 8) ^ (byte & 0x80)) - crc = (crc << 1) ^ 0x8005; - else - crc = (crc << 1); - byte <<= 1; - } - return crc; -} - -static uint16_t -ao_fec_crc(const uint8_t *bytes, uint8_t len) -{ - uint16_t crc = AO_FEC_CRC_INIT; - - while (len--) - crc = ao_fec_crc_byte(*bytes++, crc); - return crc; -} - -struct ao_scheme_macro_stack { - struct ao_scheme_macro_stack *next; - ao_poly p; -}; - -struct ao_scheme_macro_stack *macro_stack; - -static int -ao_scheme_macro_push(ao_poly p) -{ - struct ao_scheme_macro_stack *m = macro_stack; - - while (m) { - if (m->p == p) - return 1; - m = m->next; - } - m = malloc (sizeof (struct ao_scheme_macro_stack)); - m->p = p; - m->next = macro_stack; - macro_stack = m; - return 0; -} - -static void -ao_scheme_macro_pop(void) -{ - struct ao_scheme_macro_stack *m = macro_stack; - - macro_stack = m->next; - free(m); -} - -#define DBG_MACRO 0 -#if DBG_MACRO -int macro_scan_depth; - -void indent(void) -{ - int i; - for (i = 0; i < macro_scan_depth; i++) - printf(" "); -} -#define MACRO_DEBUG(a) a -#else -#define MACRO_DEBUG(a) -#endif - -ao_poly -ao_has_macro(ao_poly p); - -static ao_poly -ao_macro_test_get(ao_poly atom) -{ - ao_poly *ref = ao_scheme_atom_ref(atom, NULL); - if (ref) - return *ref; - return AO_SCHEME_NIL; -} - -static ao_poly -ao_is_macro(ao_poly p) -{ - struct ao_scheme_builtin *builtin; - struct ao_scheme_lambda *lambda; - ao_poly ret; - - MACRO_DEBUG(indent(); printf ("is macro "); ao_scheme_poly_write(p); printf("\n"); ++macro_scan_depth); - switch (ao_scheme_poly_type(p)) { - case AO_SCHEME_ATOM: - if (ao_scheme_macro_push(p)) - ret = AO_SCHEME_NIL; - else { - if (ao_is_macro(ao_macro_test_get(p))) - ret = p; - else - ret = AO_SCHEME_NIL; - ao_scheme_macro_pop(); - } - break; - case AO_SCHEME_CONS: - ret = ao_has_macro(p); - break; - case AO_SCHEME_BUILTIN: - builtin = ao_scheme_poly_builtin(p); - if ((builtin->args & AO_SCHEME_FUNC_MASK) == AO_SCHEME_FUNC_MACRO) - ret = p; - else - ret = 0; - break; - - case AO_SCHEME_LAMBDA: - lambda = ao_scheme_poly_lambda(p); - if (lambda->args == AO_SCHEME_FUNC_MACRO) - ret = p; - else - ret = ao_has_macro(lambda->code); - break; - default: - ret = AO_SCHEME_NIL; - break; - } - MACRO_DEBUG(--macro_scan_depth; indent(); printf ("... "); ao_scheme_poly_write(ret); printf("\n")); - return ret; -} - -ao_poly -ao_has_macro(ao_poly p) -{ - struct ao_scheme_cons *cons; - struct ao_scheme_lambda *lambda; - ao_poly m; - ao_poly list; - - if (p == AO_SCHEME_NIL) - return AO_SCHEME_NIL; - - MACRO_DEBUG(indent(); printf("has macro "); ao_scheme_poly_write(p); printf("\n"); ++macro_scan_depth); - switch (ao_scheme_poly_type(p)) { - case AO_SCHEME_LAMBDA: - lambda = ao_scheme_poly_lambda(p); - p = ao_has_macro(lambda->code); - break; - case AO_SCHEME_CONS: - cons = ao_scheme_poly_cons(p); - if ((p = ao_is_macro(cons->car))) - break; - - list = cons->cdr; - p = AO_SCHEME_NIL; - while (ao_scheme_is_pair(list)) { - cons = ao_scheme_poly_cons(list); - m = ao_has_macro(cons->car); - if (m) { - p = m; - break; - } - list = cons->cdr; - } - break; - - default: - p = AO_SCHEME_NIL; - break; - } - MACRO_DEBUG(--macro_scan_depth; indent(); printf("... "); ao_scheme_poly_write(p); printf("\n")); - 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; -} - -static int -ao_scheme_read_eval_abort(void) -{ - ao_poly in, out = AO_SCHEME_NIL; - for(;;) { - in = ao_scheme_read(); - if (in == _ao_scheme_atom_eof) - break; - out = ao_scheme_eval(in); - if (ao_scheme_exception) - return 0; - ao_scheme_poly_write(out, true); - putchar ('\n'); - } - return 1; -} - -static FILE *in; -static FILE *out; - -struct feature { - struct feature *next; - char name[]; -}; - -static struct feature *enable; -static struct feature *disable; - -static 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; -} - -static bool -ao_scheme_has_feature(struct feature *list, const char *name) -{ - while (list) { - if (!strcmp(list->name, name)) - return true; - list = list->next; - } - return false; -} - -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(copy, ",", &saveptr)) != NULL) { - copy = NULL; - if (!ao_scheme_has_feature(*list, name)) - ao_scheme_add_feature(list, name); - } - free(save); -} - -int -ao_scheme_getc(void) -{ - return getc(in); -} - -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=<output>] [--disable={feature,...}] [--enable={feature,...} [input]\n", program); - exit(1); -} - -int -main(int argc, char **argv) -{ - int f, o, an; - 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; - 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: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; - } - } - - ao_scheme_frame_init(); - - /* Boolean values #f and #t */ - ao_scheme_bool_get(0); - ao_scheme_bool_get(1); - - 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) { - 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((char *) funcs[f].name); - ao_scheme_atom_def(ao_scheme_atom_poly(a), - ao_scheme_builtin_poly(b)); - } - } - - /* 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"); - if (!in) { - perror(argv[optind]); - exit(1); - } - } - if (!ao_scheme_read_eval_abort()) { - fprintf(stderr, "eval failed\n"); - exit(1); - } - - /* Reduce to referenced values */ - ao_scheme_collect(AO_SCHEME_COLLECT_FULL); - - 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: ", - ao_scheme_poly_atom(vals->vals[f].atom)->name); - ao_scheme_poly_write(val, true); - 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) { - out = fopen(out_name, "w"); - if (!out) { - perror(out_name); - exit(1); - } - } - - 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)); - fprintf(out, "#define ao_builtin_frame 0x%04x\n", ao_scheme_frame_poly(ao_scheme_frame_global)); - fprintf(out, "#define ao_scheme_const_checksum ((uint16_t) 0x%04x)\n", ao_fec_crc(ao_scheme_const, ao_scheme_top)); - - fprintf(out, "#define _ao_scheme_bool_false 0x%04x\n", ao_scheme_bool_poly(ao_scheme_false)); - 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)) { - const char *n = a->name; - char ch; - fprintf(out, "#define _ao_scheme_atom_"); - while ((ch = *n++)) { - if (isalnum(ch)) - fprintf(out, "%c", ch); - else - 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 ch; - if ((o & 0xf) == 0) - fprintf(out, "\n\t"); - else - fprintf(out, " "); - ch = ao_scheme_const[o]; - if (!in_atom) - in_atom = is_atom(o); - if (in_atom) { - fprintf(out, " '%c',", ch); - in_atom--; - } else { - fprintf(out, "0x%02x,", ch); - } - } - fprintf(out, "\n};\n"); - fprintf(out, "#endif /* AO_SCHEME_CONST_BITS */\n"); - exit(0); -} diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c deleted file mode 100644 index c9215072..00000000 --- a/src/scheme/ao_scheme_mem.c +++ /dev/null @@ -1,1061 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * 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. - */ - -#define AO_SCHEME_CONST_BITS - -#include "ao_scheme.h" -#include <stdio.h> -#include <assert.h> - -#ifdef AO_SCHEME_MAKE_CONST - -/* - * When building the constant table, it is the - * pool for allocations. - */ - -#include <stdlib.h> -uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4))); -#define ao_scheme_pool ao_scheme_const -#undef AO_SCHEME_POOL -#define AO_SCHEME_POOL AO_SCHEME_POOL_CONST - -#else - -uint8_t ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribute__((aligned(4))); - -#endif - -#ifndef DBG_MEM_STATS -#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 -#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; - void *addr; - int size; -}; - -static struct ao_scheme_record *record_head, **record_tail; - -static void -ao_scheme_record_free(struct ao_scheme_record *record) -{ - while (record) { - struct ao_scheme_record *next = record->next; - free(record); - record = next; - } -} - -static void -ao_scheme_record_reset(void) -{ - ao_scheme_record_free(record_head); - record_head = NULL; - record_tail = &record_head; -} - -static void -ao_scheme_record(const struct ao_scheme_type *type, - void *addr, - int size) -{ - struct ao_scheme_record *r = malloc(sizeof (struct ao_scheme_record)); - - r->next = NULL; - r->type = type; - r->addr = addr; - r->size = size; - *record_tail = r; - record_tail = &r->next; -} - -static struct ao_scheme_record * -ao_scheme_record_save(void) -{ - struct ao_scheme_record *r = record_head; - - record_head = NULL; - record_tail = &record_head; - return r; -} - -static void -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) { - printf("%s record difers %d %s %d -> %d %s %d\n", - where, - MDBG_OFFSET(a->addr), - a->type->name, - a->size, - MDBG_OFFSET(b->addr), - b->type->name, - b->size); - ao_scheme_abort(); - } - a = a->next; - b = b->next; - } - if (a) { - printf("%s record differs %d %s %d -> NULL\n", - where, - MDBG_OFFSET(a->addr), - a->type->name, - a->size); - ao_scheme_abort(); - } - if (b) { - printf("%s record differs NULL -> %d %s %d\n", - where, - MDBG_OFFSET(b->addr), - b->type->name, - b->size); - ao_scheme_abort(); - } -} - -#else -#define ao_scheme_record_reset() -#define ao_scheme_record(t,a,s) -#endif - -uint8_t ao_scheme_exception; - -struct ao_scheme_root { - const struct ao_scheme_type *type; - void **addr; -}; - -#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 = NULL, - .addr = (void **) (void *) &stash_poly[0] - }, - { - .type = NULL, - .addr = (void **) (void *) &stash_poly[1] - }, - { - .type = NULL, - .addr = (void **) (void *) &stash_poly[2] - }, - { - .type = NULL, - .addr = (void **) (void *) &stash_poly[3] - }, - { - .type = NULL, - .addr = (void **) (void *) &stash_poly[4] - }, - { - .type = NULL, - .addr = (void **) (void *) &stash_poly[5] - }, - { - .type = &ao_scheme_atom_type, - .addr = (void **) &ao_scheme_atoms - }, - { - .type = &ao_scheme_frame_type, - .addr = (void **) &ao_scheme_frame_global, - }, - { - .type = &ao_scheme_frame_type, - .addr = (void **) &ao_scheme_frame_current, - }, - { - .type = &ao_scheme_stack_type, - .addr = (void **) &ao_scheme_stack, - }, - { - .type = NULL, - .addr = (void **) (void *) &ao_scheme_v, - }, - { - .type = &ao_scheme_cons_type, - .addr = (void **) &ao_scheme_read_cons, - }, - { - .type = &ao_scheme_cons_type, - .addr = (void **) &ao_scheme_read_cons_tail, - }, - { - .type = &ao_scheme_cons_type, - .addr = (void **) &ao_scheme_read_stack, - }, -#ifdef AO_SCHEME_MAKE_CONST - { - .type = &ao_scheme_bool_type, - .addr = (void **) &ao_scheme_false, - }, - { - .type = &ao_scheme_bool_type, - .addr = (void **) &ao_scheme_true, - }, -#endif -}; - -#define AO_SCHEME_ROOT (sizeof (ao_scheme_root) / sizeof (ao_scheme_root[0])) - -static const void ** const ao_scheme_cache[] = { - (const void **) &ao_scheme_cons_free_list, - (const void **) &ao_scheme_stack_free_list, - (const void **) &ao_scheme_frame_free_list[0], - (const void **) &ao_scheme_frame_free_list[1], - (const void **) &ao_scheme_frame_free_list[2], - (const void **) &ao_scheme_frame_free_list[3], - (const void **) &ao_scheme_frame_free_list[4], - (const void **) &ao_scheme_frame_free_list[5], -}; - -#if AO_SCHEME_FRAME_FREE != 6 -#error Unexpected AO_SCHEME_FRAME_FREE value -#endif - -#define AO_SCHEME_CACHE (sizeof (ao_scheme_cache) / sizeof (ao_scheme_cache[0])) - -#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]; -static uint8_t ao_scheme_cons_noted; - -uint16_t ao_scheme_top; - -struct ao_scheme_chunk { - uint16_t old_offset; - union { - uint16_t size; - uint16_t new_offset; - }; -}; - -#define AO_SCHEME_NCHUNK 64 - -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(addr)) - ao_scheme_abort(); -#endif - return ((uint8_t *) addr) - ao_scheme_pool; -} - -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); -} - -static inline void clear(uint8_t *tag, int offset) { - int byte = offset >> 5; - int bit = (offset >> 2) & 7; - tag[byte] &= ~(1 << bit); -} - -static inline int busy(uint8_t *tag, int offset) { - int byte = offset >> 5; - int bit = (offset >> 2) & 7; - return (tag[byte] >> bit) & 1; -} - -static inline int min(int a, int b) { return a < b ? a : b; } -static inline int max(int a, int b) { return a > b ? a : b; } - -static inline int limit(int offset) { - return min(AO_SCHEME_POOL, max(offset, 0)); -} - -static inline void -note_cons(uint16_t offset) -{ - MDBG_MOVE("note cons %d\n", offset); - ao_scheme_cons_noted = 1; - mark(ao_scheme_cons_note, offset); -} - -static uint16_t chunk_low, chunk_high; -static uint16_t chunk_first, chunk_last; - -static int -find_chunk(uint16_t offset) -{ - int l, r; - /* Binary search for the location */ - l = chunk_first; - r = chunk_last - 1; - while (l <= r) { - int m = (l + r) >> 1; - if (ao_scheme_chunk[m].old_offset < offset) - l = m + 1; - else - r = m - 1; - } - return l; -} - -static void -note_chunk(uint16_t offset, uint16_t size) -{ - int l; - int end; - - if (offset < chunk_low || chunk_high <= offset) - return; - - l = find_chunk(offset); - - /* - * The correct location is always in 'l', with r = l-1 being - * the entry before the right one - */ - -#if DBG_MEM - /* Off the right side */ - if (l >= AO_SCHEME_NCHUNK) - ao_scheme_abort(); - - /* 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 */ - end = min(AO_SCHEME_NCHUNK, chunk_last + 1); - - memmove(&ao_scheme_chunk[l+1], - &ao_scheme_chunk[l], - (end - (l+1)) * sizeof (struct ao_scheme_chunk)); - - /* Add new entry */ - ao_scheme_chunk[l].old_offset = offset; - ao_scheme_chunk[l].size = size; - - /* Increment the number of elements up to the size of the array */ - if (chunk_last < AO_SCHEME_NCHUNK) - chunk_last++; - - /* Set the top address if the array is full */ - if (chunk_last == AO_SCHEME_NCHUNK) - chunk_high = ao_scheme_chunk[AO_SCHEME_NCHUNK-1].old_offset + - ao_scheme_chunk[AO_SCHEME_NCHUNK-1].size; -} - -static void -reset_chunks(void) -{ - chunk_high = ao_scheme_top; - chunk_last = 0; - chunk_first = 0; -} - -/* - * Walk all referenced objects calling functions on each one - */ - -static void -walk(int (*visit_addr)(const struct ao_scheme_type *type, void **addr), - int (*visit_poly)(ao_poly *p, uint8_t do_note_cons)) -{ - int i; - - ao_scheme_record_reset(); - memset(ao_scheme_busy, '\0', sizeof (ao_scheme_busy)); - memset(ao_scheme_cons_note, '\0', sizeof (ao_scheme_cons_note)); - ao_scheme_cons_noted = 0; - for (i = 0; i < (int) AO_SCHEME_ROOT; i++) { - if (ao_scheme_root[i].type) { - void **a = ao_scheme_root[i].addr, *v; - if (a && (v = *a)) { - MDBG_MOVE("root ptr %d\n", MDBG_OFFSET(v)); - visit_addr(ao_scheme_root[i].type, a); - } - } else { - ao_poly *a = (ao_poly *) ao_scheme_root[i].addr, p; - if (a && (p = *a)) { - MDBG_MOVE("root poly %d\n", MDBG_OFFSET(ao_scheme_ref(p))); - visit_poly(a, 0); - } - } - } - while (ao_scheme_cons_noted) { - memcpy(ao_scheme_cons_last, ao_scheme_cons_note, sizeof (ao_scheme_cons_note)); - memset(ao_scheme_cons_note, '\0', sizeof (ao_scheme_cons_note)); - ao_scheme_cons_noted = 0; - for (i = 0; i < AO_SCHEME_POOL; i += 4) { - if (busy(ao_scheme_cons_last, i)) { - void *v = ao_scheme_pool + i; - MDBG_MOVE("root cons %d\n", MDBG_OFFSET(v)); - visit_addr(&ao_scheme_cons_type, &v); - } - } - } -} - -#if MDBG_DUMP -static void -dump_busy(void) -{ - int i; - printf("busy:"); - for (i = 0; i < ao_scheme_top; i += 4) { - if ((i & 0xff) == 0) { - printf("\n\t"); - } - else if ((i & 0x1f) == 0) - printf(" "); - if (busy(ao_scheme_busy, i)) - printf("*"); - else - printf("-"); - } - printf ("\n"); -} -#define DUMP_BUSY() dump_busy() -#else -#define DUMP_BUSY() -#endif - -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, -#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, - [AO_SCHEME_FRAME] = &ao_scheme_frame_type, - [AO_SCHEME_FRAME_VALS] = &ao_scheme_frame_vals_type, - [AO_SCHEME_LAMBDA] = &ao_scheme_lambda_type, - [AO_SCHEME_STACK] = &ao_scheme_stack_type, - [AO_SCHEME_BOOL] = &ao_scheme_bool_type, - [AO_SCHEME_STRING] = &ao_scheme_string_type, -#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 -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) -{ - return ao_scheme_mark(type, *ref); -} - -static int -ao_scheme_poly_mark_ref(ao_poly *p, uint8_t do_note_cons) -{ - return ao_scheme_poly_mark(*p, do_note_cons); -} - -#if DBG_MEM_STATS -uint64_t ao_scheme_collects[2]; -uint64_t ao_scheme_freed[2]; -uint64_t ao_scheme_loops[2]; -#endif - -int ao_scheme_last_top; -int ao_scheme_collect_counts; - -int -ao_scheme_collect(uint8_t style) -{ - ao_scheme_declare_stack - int i; - int top; -#if DBG_MEM_STATS - int loops = 0; -#endif -#if DBG_MEM_RECORD - struct ao_scheme_record *mark_record = NULL, *move_record = NULL; -#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); - - 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; - - /* 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; - if (style == AO_SCHEME_COLLECT_FULL) { - chunk_low = top = 0; - } else { - chunk_low = top = ao_scheme_last_top; - } - for (;;) { - 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_RECORD - ao_scheme_record_free(mark_record); - mark_record = ao_scheme_record_save(); - if (mark_record && move_record) - ao_scheme_record_compare("mark", move_record, mark_record); -#endif - - DUMP_BUSY(); - - /* 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(); -#endif - - if (ao_scheme_chunk[i].old_offset > top) - break; - - MDBG_MOVE("chunk %d %d not moving\n", - ao_scheme_chunk[i].old_offset, - ao_scheme_chunk[i].size); -#if DBG_MEM - if (ao_scheme_chunk[i].old_offset != top) - ao_scheme_abort(); -#endif - 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 - */ - chunk_first = i; - chunk_low = ao_scheme_chunk[i].old_offset; - - /* Copy all of the objects */ - for (; i < chunk_last; i++) { - uint16_t size = ao_scheme_chunk[i].size; - -#if DBG_MEM - if (!size) - ao_scheme_abort(); -#endif - - MDBG_MOVE("chunk %d %d -> %d\n", - ao_scheme_chunk[i].old_offset, - size, - top); - ao_scheme_chunk[i].new_offset = top; - - memmove(&ao_scheme_pool[top], - &ao_scheme_pool[ao_scheme_chunk[i].old_offset], - size); - - top += size; - } - - if (chunk_first < chunk_last) { - /* Relocate all references to the objects */ - walk(ao_scheme_move, ao_scheme_poly_move); - -#if DBG_MEM_RECORD - ao_scheme_record_free(move_record); - move_record = ao_scheme_record_save(); - if (mark_record && move_record) - ao_scheme_record_compare("move", mark_record, move_record); -#endif - } - -#if DBG_MEM_STATS - loops++; -#endif - /* If we ran into the end of the heap, then - * there's no need to keep walking - */ - if (chunk_last != AO_SCHEME_NCHUNK) - break; - - /* Next loop starts right above this loop */ - chunk_low = chunk_high; - } - -#if DBG_MEM_STATS - /* Collect stats */ - ++ao_scheme_collects[style]; - ao_scheme_freed[style] += ao_scheme_top - top; - ao_scheme_loops[style] += loops; -#endif - - ao_scheme_top = top; - if (style == AO_SCHEME_COLLECT_FULL) - ao_scheme_last_top = top; - - 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 - MDBG_DO(--ao_scheme_collecting); - return AO_SCHEME_POOL - ao_scheme_top; -} - -#if DBG_FREE_CONS -void -ao_scheme_cons_check(struct ao_scheme_cons *cons) -{ - ao_poly cdr; - int offset; - - chunk_low = 0; - reset_chunks(); - walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); - while (cons) { - if (!ao_scheme_is_pool_addr(cons)) - break; - offset = pool_offset(cons); - if (busy(ao_scheme_busy, offset)) { - ao_scheme_printf("cons at %p offset %d poly %d is busy\n\t%v\n", cons, offset, ao_scheme_cons_poly(cons), ao_scheme_cons_poly(cons)); - abort(); - } - cdr = cons->cdr; - if (!ao_scheme_is_pair(cdr)) - break; - cons = ao_scheme_poly_cons(cdr); - } -} -#endif - -/* - * Mark interfaces for objects - */ - - -/* - * Note a reference to memory and collect information about a few - * object sizes at a time - */ - -int -ao_scheme_mark_memory(const struct ao_scheme_type *type, void *addr) -{ - int offset; - if (!ao_scheme_is_pool_addr(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, ao_scheme_size(type, addr)); - return 0; -} - -/* - * Mark an object and all that it refereces - */ -static int -ao_scheme_mark(const struct ao_scheme_type *type, void *addr) -{ - int ret; - MDBG_MOVE("mark %d\n", MDBG_OFFSET(addr)); - MDBG_MOVE_IN(); - ret = ao_scheme_mark_memory(type, addr); - if (!ret) { - MDBG_MOVE("mark recurse\n"); - type->mark(addr); - } - MDBG_MOVE_OUT(); - return ret; -} - -/* - * Mark an object, unless it is a cons cell and - * do_note_cons is set. In that case, just - * set a bit in the cons note array; those - * will be marked in a separate pass to avoid - * deep recursion in the collector - */ -int -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); - - if (type == AO_SCHEME_INT) - return 1; - - addr = ao_scheme_ref(p); - if (!ao_scheme_is_pool_addr(addr)) - return 1; - - if (type == AO_SCHEME_CONS && 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); - - lisp_type = ao_scheme_types[type]; -#if DBG_MEM - if (!lisp_type) - ao_scheme_abort(); -#endif - - 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; - } -} - -/* - * Find the current location of an object - * based on the original location. For unmoved - * objects, this is simple. For moved objects, - * go search for it - */ - -static uint16_t -move_map(uint16_t offset) -{ - int l; - - if (offset < chunk_low || chunk_high <= offset) - return offset; - - l = find_chunk(offset); - -#if DBG_MEM - if (ao_scheme_chunk[l].old_offset != offset) - ao_scheme_abort(); -#endif - return ao_scheme_chunk[l].new_offset; -} - -int -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(addr)) - return 1; - - (void) type; - - MDBG_MOVE("move memory %d\n", MDBG_OFFSET(addr)); - orig_offset = pool_offset(addr); - offset = move_map(orig_offset); - if (offset != orig_offset) { - MDBG_MOVE("update ref %d %d -> %d\n", - ao_scheme_is_pool_addr(ref) ? MDBG_OFFSET(ref) : -1, - orig_offset, offset); - *ref = ao_scheme_pool + offset; - } - if (busy(ao_scheme_busy, offset)) { - MDBG_MOVE("already moved\n"); - return 1; - } - mark(ao_scheme_busy, offset); - ao_scheme_record(type, addr, ao_scheme_size(type, addr)); - return 0; -} - -static int -ao_scheme_move(const struct ao_scheme_type *type, void **ref) -{ - int ret; - MDBG_MOVE("move object %d\n", MDBG_OFFSET(*ref)); - MDBG_MOVE_IN(); - ret = ao_scheme_move_memory(type, ref); - if (!ret) { - MDBG_MOVE("move recurse\n"); - type->move(*ref); - } - MDBG_MOVE_OUT(); - return ret; -} - -int -ao_scheme_poly_move(ao_poly *ref, uint8_t do_note_cons) -{ - ao_poly p = *ref; - int ret; - void *addr; - uint16_t offset, orig_offset; - - if (ao_scheme_poly_base_type(p) == AO_SCHEME_INT) - return 1; - - addr = ao_scheme_ref(p); - if (!ao_scheme_is_pool_addr(addr)) - return 1; - - orig_offset = pool_offset(addr); - offset = move_map(orig_offset); - - 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); - - lisp_type = ao_scheme_types[type]; -#if DBG_MEM - if (!lisp_type) - ao_scheme_abort(); -#endif - /* 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, ao_scheme_poly_base_type(p)); - MDBG_MOVE("poly %d moved %d -> %d\n", - ao_scheme_poly_type(np), orig_offset, offset); - *ref = np; - } - return ret; -} - -#if DBG_MEM -static void -ao_scheme_validate(void) -{ - chunk_low = 0; - memset(ao_scheme_chunk, '\0', sizeof (ao_scheme_chunk)); - walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); -} - -int dbg_allocs; - -#endif - -void * -ao_scheme_alloc(int size) -{ - void *addr; - - MDBG_DO(++dbg_allocs); - MDBG_DO(if (dbg_validate) ao_scheme_validate()); - size = ao_scheme_size_round(size); - if (AO_SCHEME_POOL - ao_scheme_top < size && - ao_scheme_collect(AO_SCHEME_COLLECT_INCREMENTAL) < size && - ao_scheme_collect(AO_SCHEME_COLLECT_FULL) < size) - { - ao_scheme_error(AO_SCHEME_OOM, "out of memory"); - return NULL; - } - addr = ao_scheme_pool + ao_scheme_top; - ao_scheme_top += size; - MDBG_MOVE("alloc %d size %d\n", MDBG_OFFSET(addr), size); - return addr; -} - -void -ao_scheme_poly_stash(ao_poly p) -{ - assert(stash_poly_ptr < AO_SCHEME_NUM_STASH); - stash_poly[stash_poly_ptr++] = p; -} - -ao_poly -ao_scheme_poly_fetch(void) -{ - ao_poly p; - - assert (stash_poly_ptr > 0); - p = stash_poly[--stash_poly_ptr]; - stash_poly[stash_poly_ptr] = AO_SCHEME_NIL; - return p; -} - -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(addr)) - return 0; - - 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; -} - -void -ao_scheme_print_clear_addr(void *addr) -{ - int offset; - -#if DBG_MEM - if (ao_scheme_collecting) - ao_scheme_abort(); -#endif - - if (!ao_scheme_is_pool_addr(addr)) - return; - - if (!ao_scheme_print_cleared) - return; - offset = pool_offset(addr); - clear(ao_scheme_busy, offset); -} - -/* Notes that printing has started */ -void -ao_scheme_print_start(void) -{ - ao_scheme_printing++; -} - -/* 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) - 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 deleted file mode 100644 index 0cffc196..00000000 --- a/src/scheme/ao_scheme_poly.c +++ /dev/null @@ -1,71 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * 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" - -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 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] = ao_scheme_bigint_write, -#endif - [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] = ao_scheme_float_write, -#endif -#ifdef AO_SCHEME_FEATURE_VECTOR - [AO_SCHEME_VECTOR] = ao_scheme_vector_write, -#endif -}; - -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_write_funcs[type]; - return ao_scheme_invalid_write; -} - -void * -ao_scheme_ref(ao_poly poly) { - if (poly == AO_SCHEME_NIL) - return NULL; - if (poly & AO_SCHEME_CONST) - return (void *) (ao_scheme_const + (poly & AO_SCHEME_REF_MASK) - 4); - return (void *) (ao_scheme_pool + (poly & AO_SCHEME_REF_MASK) - 4); -} - -ao_poly -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_addr(a)) - return AO_SCHEME_CONST | (a - ao_scheme_const + 4) | type; - return (a - ao_scheme_pool + 4) | type; -} diff --git a/src/scheme/ao_scheme_read.c b/src/scheme/ao_scheme_read.c deleted file mode 100644 index e93466fc..00000000 --- a/src/scheme/ao_scheme_read.c +++ /dev/null @@ -1,701 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * 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 "ao_scheme_read.h" -#include <math.h> -#include <stdlib.h> - -static const uint16_t lex_classes[128] = { - IGNORE, /* ^@ */ - IGNORE, /* ^A */ - IGNORE, /* ^B */ - IGNORE, /* ^C */ - IGNORE, /* ^D */ - IGNORE, /* ^E */ - IGNORE, /* ^F */ - IGNORE, /* ^G */ - IGNORE, /* ^H */ - WHITE, /* ^I */ - WHITE, /* ^J */ - WHITE, /* ^K */ - WHITE, /* ^L */ - WHITE, /* ^M */ - IGNORE, /* ^N */ - IGNORE, /* ^O */ - IGNORE, /* ^P */ - IGNORE, /* ^Q */ - IGNORE, /* ^R */ - IGNORE, /* ^S */ - IGNORE, /* ^T */ - IGNORE, /* ^U */ - IGNORE, /* ^V */ - IGNORE, /* ^W */ - IGNORE, /* ^X */ - IGNORE, /* ^Y */ - IGNORE, /* ^Z */ - IGNORE, /* ^[ */ - IGNORE, /* ^\ */ - IGNORE, /* ^] */ - IGNORE, /* ^^ */ - IGNORE, /* ^_ */ - PRINTABLE|WHITE, /* */ - PRINTABLE, /* ! */ - PRINTABLE|STRINGC, /* " */ - PRINTABLE|POUND, /* # */ - PRINTABLE, /* $ */ - PRINTABLE, /* % */ - PRINTABLE, /* & */ - PRINTABLE|SPECIAL, /* ' */ - PRINTABLE|SPECIAL, /* ( */ - PRINTABLE|SPECIAL, /* ) */ - PRINTABLE, /* * */ - PRINTABLE|SIGN, /* + */ - PRINTABLE|SPECIAL_QUASI, /* , */ - PRINTABLE|SIGN, /* - */ - PRINTABLE|DOTC|FLOATC, /* . */ - PRINTABLE, /* / */ - PRINTABLE|DIGIT, /* 0 */ - PRINTABLE|DIGIT, /* 1 */ - PRINTABLE|DIGIT, /* 2 */ - PRINTABLE|DIGIT, /* 3 */ - PRINTABLE|DIGIT, /* 4 */ - PRINTABLE|DIGIT, /* 5 */ - PRINTABLE|DIGIT, /* 6 */ - PRINTABLE|DIGIT, /* 7 */ - PRINTABLE|DIGIT, /* 8 */ - PRINTABLE|DIGIT, /* 9 */ - PRINTABLE, /* : */ - PRINTABLE|COMMENT, /* ; */ - PRINTABLE, /* < */ - PRINTABLE, /* = */ - PRINTABLE, /* > */ - PRINTABLE, /* ? */ - PRINTABLE, /* @ */ - PRINTABLE, /* A */ - PRINTABLE, /* B */ - PRINTABLE, /* C */ - PRINTABLE, /* D */ - PRINTABLE|FLOATC, /* E */ - PRINTABLE, /* F */ - PRINTABLE, /* G */ - PRINTABLE, /* H */ - PRINTABLE, /* I */ - PRINTABLE, /* J */ - PRINTABLE, /* K */ - PRINTABLE, /* L */ - PRINTABLE, /* M */ - PRINTABLE, /* N */ - PRINTABLE, /* O */ - PRINTABLE, /* P */ - PRINTABLE, /* Q */ - PRINTABLE, /* R */ - PRINTABLE, /* S */ - PRINTABLE, /* T */ - PRINTABLE, /* U */ - PRINTABLE, /* V */ - PRINTABLE, /* W */ - PRINTABLE, /* X */ - PRINTABLE, /* Y */ - PRINTABLE, /* Z */ - PRINTABLE, /* [ */ - PRINTABLE|BACKSLASH, /* \ */ - PRINTABLE, /* ] */ - PRINTABLE, /* ^ */ - PRINTABLE, /* _ */ - PRINTABLE|SPECIAL_QUASI, /* ` */ - PRINTABLE, /* a */ - PRINTABLE, /* b */ - PRINTABLE, /* c */ - PRINTABLE, /* d */ - PRINTABLE|FLOATC, /* e */ - PRINTABLE, /* f */ - PRINTABLE, /* g */ - PRINTABLE, /* h */ - PRINTABLE, /* i */ - PRINTABLE, /* j */ - PRINTABLE, /* k */ - PRINTABLE, /* l */ - PRINTABLE, /* m */ - PRINTABLE, /* n */ - PRINTABLE, /* o */ - PRINTABLE, /* p */ - PRINTABLE, /* q */ - PRINTABLE, /* r */ - PRINTABLE, /* s */ - PRINTABLE, /* t */ - PRINTABLE, /* u */ - PRINTABLE, /* v */ - PRINTABLE, /* w */ - PRINTABLE, /* x */ - PRINTABLE, /* y */ - PRINTABLE, /* z */ - PRINTABLE, /* { */ - PRINTABLE, /* | */ - PRINTABLE, /* } */ - PRINTABLE, /* ~ */ - IGNORE, /* ^? */ -}; - -static int lex_unget_c; - -static inline int -lex_get(void) -{ - int c; - if (lex_unget_c) { - c = lex_unget_c; - lex_unget_c = 0; - } else { - c = ao_scheme_getc(); - } - return c; -} - -static inline void -lex_unget(int c) -{ - if (c != EOF) - lex_unget_c = c; -} - -static uint16_t lex_class; - -static int -lexc(void) -{ - int c; - do { - c = lex_get(); - if (c == EOF) { - c = 0; - lex_class = ENDOFFILE; - } else { - c &= 0x7f; - lex_class = lex_classes[c]; - } - } while (lex_class & IGNORE); - return c; -} - -static int -lex_quoted(void) -{ - int c; - int v; - int count; - - c = lex_get(); - if (c == EOF) { - lex_class = ENDOFFILE; - return 0; - } - lex_class = 0; - c &= 0x7f; - switch (c) { - case 'n': - return '\n'; - case 'f': - return '\f'; - case 'b': - return '\b'; - case 'r': - return '\r'; - case 'v': - return '\v'; - case 't': - return '\t'; - case '0': - case '1': - case '2': - case '3': - case '4': - case '5': - case '6': - case '7': - v = c - '0'; - count = 1; - while (count <= 3) { - c = lex_get(); - if (c == EOF) - return EOF; - c &= 0x7f; - if (c < '0' || '7' < c) { - lex_unget(c); - break; - } - v = (v << 3) + c - '0'; - ++count; - } - return v; - default: - return c; - } -} - -#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 inline void add_token(int c) { - if (c && token_len < AO_SCHEME_TOKEN_MAX - 1) - token_string[token_len++] = c; -} - -static inline void del_token(void) { - if (token_len > 0) - token_len--; -} - -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; -}; - -static const struct namedfloat namedfloats[] = { - { .name = "+inf.0", .value = INFINITY }, - { .name = "-inf.0", .value = -INFINITY }, - { .name = "+nan.0", .value = NAN }, - { .name = "-nan.0", .value = NAN }, -}; - -#define NUM_NAMED_FLOATS (sizeof namedfloats / sizeof namedfloats[0]) -#endif - -static int -_lex(void) -{ - int c; - - token_len = 0; - for (;;) { - c = lexc(); - if (lex_class & ENDOFFILE) - return END; - - if (lex_class & WHITE) - continue; - - if (lex_class & COMMENT) { - while ((c = lexc()) != '\n') { - if (lex_class & ENDOFFILE) - return END; - } - continue; - } - - if (lex_class & (SPECIAL|DOTC)) { - add_token(c); - end_token(); - switch (c) { - case '(': - case '[': - return OPEN; - case ')': - case ']': - return CLOSE; - case '\'': - return QUOTE; - case '.': - return DOT; -#ifdef AO_SCHEME_FEATURE_QUASI - case '`': - return QUASIQUOTE; - case ',': - c = lexc(); - if (c == '@') { - add_token(c); - end_token(); - return UNQUOTE_SPLICING; - } else { - lex_unget(c); - return UNQUOTE; - } -#endif - } - } - if (lex_class & POUND) { - c = lexc(); - switch (c) { - case 't': - add_token(c); - end_token(); - return BOOL; - case 'f': - add_token(c); - end_token(); - return BOOL; -#ifdef AO_SCHEME_FEATURE_VECTOR - case '(': - return OPEN_VECTOR; -#endif - case '\\': - for (;;) { - int alphabetic; - c = lexc(); - alphabetic = (('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z')); - if (token_len == 0) { - add_token(c); - if (!alphabetic) - break; - } else { - if (alphabetic) - add_token(c); - else { - lex_unget(c); - break; - } - } - } - end_token(); - if (token_len == 1) - token_int = token_string[0]; - else if (!strcmp(token_string, "space")) - token_int = ' '; - else if (!strcmp(token_string, "newline")) - token_int = '\n'; - else if (!strcmp(token_string, "tab")) - token_int = '\t'; - else if (!strcmp(token_string, "return")) - token_int = '\r'; - else if (!strcmp(token_string, "formfeed")) - token_int = '\f'; - else { - ao_scheme_error(AO_SCHEME_INVALID, "invalid character token #\\%s", token_string); - continue; - } - return NUM; - } - } - if (lex_class & STRINGC) { - for (;;) { - c = lexc(); - if (lex_class & BACKSLASH) - c = lex_quoted(); - if (lex_class & (STRINGC|ENDOFFILE)) { - end_token(); - return STRING; - } - add_token(c); - } - } - if (lex_class & PRINTABLE) { -#ifdef AO_SCHEME_FEATURE_FLOAT - int isfloat = 1; - int epos = 0; -#endif - int hasdigit = 0; - int isneg = 0; - int isint = 1; - - token_int = 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 && - (lex_class & SIGN)) - { - 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') { - if (token_len == 0) - isfloat = 0; - else - epos = token_len + 1; - } -#endif - if (lex_class & DIGIT) { - hasdigit = 1; - if (isint) - token_int = token_int * 10 + c - '0'; - } - } - add_token (c); - c = lexc (); - 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); - end_token (); - if (isint && hasdigit) { - if (isneg) - token_int = -token_int; - return NUM; - } -#ifdef AO_SCHEME_FEATURE_FLOAT - if (isfloat && hasdigit) { - token_float = strtof(token_string, NULL); - return FLOAT; - } - for (u = 0; u < NUM_NAMED_FLOATS; u++) - if (!strcmp(namedfloats[u].name, token_string)) { - token_float = namedfloats[u].value; - return FLOAT; - } -#endif - return NAME; - } - } - } - } -} - -static inline int lex(void) -{ - int parse_token = _lex(); - RDBGI("token %d (%s)\n", parse_token, token_string); - return parse_token; -} - -static int parse_token; - -int ao_scheme_read_list; -struct ao_scheme_cons *ao_scheme_read_cons; -struct ao_scheme_cons *ao_scheme_read_cons_tail; -struct ao_scheme_cons *ao_scheme_read_stack; -static int ao_scheme_read_state; - -#define READ_IN_QUOTE 0x01 -#define READ_SAW_DOT 0x02 -#define READ_DONE_DOT 0x04 -#define READ_SAW_VECTOR 0x08 - -static int -push_read_stack(int read_state) -{ - RDBGI("push read stack %p 0x%x\n", ao_scheme_read_cons, 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_poly(ao_scheme_read_stack))); - if (!ao_scheme_read_stack) - return 0; - } else - ao_scheme_read_state = read_state; - ao_scheme_read_cons = NULL; - ao_scheme_read_cons_tail = NULL; - return 1; -} - -static int -pop_read_stack(void) -{ - int read_state = 0; - if (ao_scheme_read_list) { - ao_scheme_read_cons = ao_scheme_poly_cons(ao_scheme_read_stack->car); - ao_scheme_read_stack = ao_scheme_poly_cons(ao_scheme_read_stack->cdr); - read_state = ao_scheme_poly_int(ao_scheme_read_stack->car); - ao_scheme_read_stack = ao_scheme_poly_cons(ao_scheme_read_stack->cdr); - for (ao_scheme_read_cons_tail = ao_scheme_read_cons; - ao_scheme_read_cons_tail && ao_scheme_read_cons_tail->cdr; - ao_scheme_read_cons_tail = ao_scheme_poly_cons(ao_scheme_read_cons_tail->cdr)) - ; - } else { - ao_scheme_read_cons = 0; - ao_scheme_read_cons_tail = 0; - ao_scheme_read_stack = 0; - read_state = ao_scheme_read_state; - } - RDBG_OUT(); - RDBGI("pop read stack %p %d\n", ao_scheme_read_cons, read_state); - 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) -{ - struct ao_scheme_atom *atom; - struct ao_scheme_string *string; - int read_state; - ao_poly v = AO_SCHEME_NIL; - - ao_scheme_read_list = 0; - read_state = 0; - ao_scheme_read_cons = ao_scheme_read_cons_tail = ao_scheme_read_stack = 0; - for (;;) { - parse_token = lex(); - 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++; - read_state = 0; - parse_token = lex(); - } - - switch (parse_token) { - case END: - default: - if (ao_scheme_read_list) - ao_scheme_error(AO_SCHEME_EOF, "unexpected end of file"); - return _ao_scheme_atom_eof; - break; - case NAME: - atom = ao_scheme_atom_intern(token_string); - if (atom) - v = ao_scheme_atom_poly(atom); - else - v = AO_SCHEME_NIL; - break; - 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; - else - v = _ao_scheme_bool_false; - break; - case STRING: - string = ao_scheme_string_make(token_string); - if (string) - v = ao_scheme_string_poly(string); - else - 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++; - read_state = READ_IN_QUOTE; - switch (parse_token) { - case QUOTE: - v = _ao_scheme_atom_quote; - break; -#ifdef AO_SCHEME_FEATURE_QUASI - case QUASIQUOTE: - v = _ao_scheme_atom_quasiquote; - break; - case UNQUOTE: - v = _ao_scheme_atom_unquote; - break; - case UNQUOTE_SPLICING: - v = _ao_scheme_atom_unquote2dsplicing; - break; -#endif - } - break; - case CLOSE: - if (!ao_scheme_read_list) { - v = AO_SCHEME_NIL; - break; - } - 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) { - ao_scheme_error(AO_SCHEME_INVALID, ". outside of cons"); - return AO_SCHEME_NIL; - } - if (!ao_scheme_read_cons) { - ao_scheme_error(AO_SCHEME_INVALID, ". first in cons"); - return AO_SCHEME_NIL; - } - read_state |= READ_SAW_DOT; - continue; - } - - /* loop over QUOTE ends */ - for (;;) { - if (!ao_scheme_read_list) - return v; - - if (read_state & READ_DONE_DOT) { - ao_scheme_error(AO_SCHEME_INVALID, ". not last in cons"); - return AO_SCHEME_NIL; - } - - if (read_state & READ_SAW_DOT) { - read_state |= READ_DONE_DOT; - ao_scheme_read_cons_tail->cdr = v; - } else { - struct ao_scheme_cons *read = ao_scheme_cons_cons(v, AO_SCHEME_NIL); - if (!read) - return AO_SCHEME_NIL; - - if (ao_scheme_read_cons_tail) - ao_scheme_read_cons_tail->cdr = ao_scheme_cons_poly(read); - else - ao_scheme_read_cons = read; - ao_scheme_read_cons_tail = read; - } - - if (!(read_state & READ_IN_QUOTE) || !ao_scheme_read_cons->cdr) - break; - - v = ao_scheme_cons_poly(ao_scheme_read_cons); - --ao_scheme_read_list; - read_state = pop_read_stack(); - } - } - return v; -} diff --git a/src/scheme/ao_scheme_read.h b/src/scheme/ao_scheme_read.h deleted file mode 100644 index 1aa11a3a..00000000 --- a/src/scheme/ao_scheme_read.h +++ /dev/null @@ -1,74 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * 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. - */ - -#ifndef _AO_SCHEME_READ_H_ -#define _AO_SCHEME_READ_H_ - -/* - * token classes - */ - -# define END 0 -# define NAME 1 -# 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 - */ - -# 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 - ' ' */ -# define BACKSLASH 0x0400 /* \ */ -# define STRINGC 0x0800 /* " */ -# define POUND 0x1000 /* # */ - -# define NOTNAME (STRINGC|COMMENT|ENDOFFILE|WHITE|SPECIAL) -# define INTEGER (DIGIT|SIGN) -# define NUMBER (INTEGER|FLOATC) - -#endif /* _AO_SCHEME_READ_H_ */ diff --git a/src/scheme/ao_scheme_rep.c b/src/scheme/ao_scheme_rep.c deleted file mode 100644 index b35ba5b8..00000000 --- a/src/scheme/ao_scheme_rep.c +++ /dev/null @@ -1,38 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * 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" - -ao_poly -ao_scheme_read_eval_print(void) -{ - ao_poly in, out = AO_SCHEME_NIL; - - ao_scheme_exception = 0; - for(;;) { - in = ao_scheme_read(); - if (in == _ao_scheme_atom_eof) - break; - out = ao_scheme_eval(in); - if (ao_scheme_exception) { - if (ao_scheme_exception & AO_SCHEME_EXIT) - break; - ao_scheme_exception = 0; - } else { - ao_scheme_poly_write(out, true); - putchar ('\n'); - } - } - return out; -} diff --git a/src/scheme/ao_scheme_save.c b/src/scheme/ao_scheme_save.c deleted file mode 100644 index 3a595d71..00000000 --- a/src/scheme/ao_scheme_save.c +++ /dev/null @@ -1,84 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * 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" - -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 - 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); - os->globals = ao_scheme_frame_poly(ao_scheme_frame_global); - os->const_checksum = ao_scheme_const_checksum; - os->const_checksum_inv = (uint16_t) ~ao_scheme_const_checksum; - - if (ao_scheme_os_save()) - return _ao_scheme_bool_true; -#endif - return _ao_scheme_bool_false; -} - -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 - 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"); - - if (save.const_checksum != ao_scheme_const_checksum || - save.const_checksum_inv != (uint16_t) ~ao_scheme_const_checksum) - { - return ao_scheme_error(AO_SCHEME_INVALID, "image is corrupted or stale"); - } - - if (ao_scheme_os_restore()) { - - ao_scheme_atoms = ao_scheme_poly_atom(os->atoms); - ao_scheme_frame_global = ao_scheme_poly_frame(os->globals); - - /* Clear the eval global variabls */ - ao_scheme_eval_clear_globals(); - - /* Reset the allocator */ - ao_scheme_top = AO_SCHEME_POOL; - ao_scheme_collect(AO_SCHEME_COLLECT_FULL); - - /* Re-create the evaluator stack */ - if (!ao_scheme_eval_restart()) - return _ao_scheme_bool_false; - - return _ao_scheme_bool_true; - } -#endif - return _ao_scheme_bool_false; -} diff --git a/src/scheme/ao_scheme_stack.c b/src/scheme/ao_scheme_stack.c deleted file mode 100644 index 863df3ca..00000000 --- a/src/scheme/ao_scheme_stack.c +++ /dev/null @@ -1,290 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * 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" - -const struct ao_scheme_type ao_scheme_stack_type; - -static int -stack_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_scheme_stack); -} - -static void -stack_mark(void *addr) -{ - struct ao_scheme_stack *stack = addr; - for (;;) { - ao_scheme_poly_mark(stack->sexprs, 0); - ao_scheme_poly_mark(stack->values, 0); - /* no need to mark values_tail */ - ao_scheme_poly_mark(stack->frame, 0); - ao_scheme_poly_mark(stack->list, 0); - stack = ao_scheme_poly_stack(stack->prev); - if (ao_scheme_mark_memory(&ao_scheme_stack_type, stack)) - break; - } -} - -static void -stack_move(void *addr) -{ - struct ao_scheme_stack *stack = addr; - - while (stack) { - struct ao_scheme_stack *prev; - int ret; - (void) ao_scheme_poly_move(&stack->sexprs, 0); - (void) ao_scheme_poly_move(&stack->values, 0); - (void) ao_scheme_poly_move(&stack->values_tail, 0); - (void) ao_scheme_poly_move(&stack->frame, 0); - (void) ao_scheme_poly_move(&stack->list, 0); - prev = ao_scheme_poly_stack(stack->prev); - if (!prev) - break; - ret = ao_scheme_move_memory(&ao_scheme_stack_type, (void **) &prev); - if (prev != ao_scheme_poly_stack(stack->prev)) - stack->prev = ao_scheme_stack_poly(prev); - if (ret) - break; - stack = prev; - } -} - -const struct ao_scheme_type ao_scheme_stack_type = { - .size = stack_size, - .mark = stack_mark, - .move = stack_move, - .name = "stack" -}; - -struct ao_scheme_stack *ao_scheme_stack_free_list; - -void -ao_scheme_stack_reset(struct ao_scheme_stack *stack) -{ - stack->state = eval_sexpr; - stack->sexprs = AO_SCHEME_NIL; - stack->values = AO_SCHEME_NIL; - stack->values_tail = AO_SCHEME_NIL; -} - -static struct ao_scheme_stack * -ao_scheme_stack_new(void) -{ - struct ao_scheme_stack *stack; - - if (ao_scheme_stack_free_list) { - stack = ao_scheme_stack_free_list; - ao_scheme_stack_free_list = ao_scheme_poly_stack(stack->prev); - } else { - stack = ao_scheme_alloc(sizeof (struct ao_scheme_stack)); - if (!stack) - return 0; - stack->type = AO_SCHEME_STACK; - } - ao_scheme_stack_reset(stack); - return stack; -} - -int -ao_scheme_stack_push(void) -{ - struct ao_scheme_stack *stack; - - stack = ao_scheme_stack_new(); - - if (!stack) - return 0; - - stack->prev = ao_scheme_stack_poly(ao_scheme_stack); - stack->frame = ao_scheme_frame_poly(ao_scheme_frame_current); - stack->list = AO_SCHEME_NIL; - - ao_scheme_stack = stack; - - DBGI("stack push\n"); - DBG_FRAMES(); - DBG_IN(); - return 1; -} - -void -ao_scheme_stack_pop(void) -{ - ao_poly prev; - struct ao_scheme_frame *prev_frame; - - if (!ao_scheme_stack) - return; - prev = ao_scheme_stack->prev; - if (!ao_scheme_stack_marked(ao_scheme_stack)) { - ao_scheme_stack->prev = ao_scheme_stack_poly(ao_scheme_stack_free_list); - ao_scheme_stack_free_list = ao_scheme_stack; - } - - ao_scheme_stack = ao_scheme_poly_stack(prev); - prev_frame = ao_scheme_frame_current; - if (ao_scheme_stack) - ao_scheme_frame_current = ao_scheme_poly_frame(ao_scheme_stack->frame); - else - ao_scheme_frame_current = NULL; - if (ao_scheme_frame_current != prev_frame) - ao_scheme_frame_free(prev_frame); - DBG_OUT(); - DBGI("stack pop\n"); - DBG_FRAMES(); -} - -void -ao_scheme_stack_clear(void) -{ - ao_scheme_stack = NULL; - ao_scheme_frame_current = NULL; - ao_scheme_v = AO_SCHEME_NIL; -} - -void -ao_scheme_stack_write(ao_poly poly, bool write) -{ - 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 (ao_scheme_print_mark_addr(s)) { - printf("[recurse...]"); - break; - } - written++; - printf("\t[\n"); - 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 = 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); - } - } -} - -/* - * Copy a stack, being careful to keep everybody referenced - */ -static struct ao_scheme_stack * -ao_scheme_stack_copy(struct ao_scheme_stack *old) -{ - struct ao_scheme_stack *new = NULL; - struct ao_scheme_stack *n, *prev = NULL; - - while (old) { - 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(); - new = ao_scheme_stack_fetch(); - old = ao_scheme_stack_fetch(); - if (!n) - return NULL; - - ao_scheme_stack_mark(old); - ao_scheme_frame_mark(ao_scheme_poly_frame(old->frame)); - *n = *old; - - if (prev) - prev->prev = ao_scheme_stack_poly(n); - else - new = n; - prev = n; - - old = ao_scheme_poly_stack(old->prev); - } - return new; -} - -/* - * Evaluate a continuation invocation - */ -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; - - cons = ao_scheme_poly_cons(ao_scheme_stack->values); - - if (!cons || !cons->cdr) - return ao_scheme_error(AO_SCHEME_INVALID, "continuation requires a value"); - - new->state = eval_val; - - ao_scheme_stack = new; - ao_scheme_frame_current = ao_scheme_poly_frame(ao_scheme_stack->frame); - - return ao_scheme_poly_cons(cons->cdr)->car; -} - -/* - * Call with current continuation. This calls a lambda, passing - * it a single argument which is the current continuation - */ -ao_poly -ao_scheme_do_call_cc(struct ao_scheme_cons *cons) -{ - struct ao_scheme_stack *new; - ao_poly v; - - /* Make sure the single parameter is a lambda */ - if (!ao_scheme_check_argc(_ao_scheme_atom_call2fcc, cons, 1, 1)) - return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_call2fcc, cons, 0, AO_SCHEME_LAMBDA, 0)) - return AO_SCHEME_NIL; - - /* go get the lambda */ - ao_scheme_v = ao_scheme_arg(cons, 0); - - /* Note that the whole call chain now has - * a reference to it which may escape - */ - new = ao_scheme_stack_copy(ao_scheme_stack); - if (!new) - return AO_SCHEME_NIL; - - /* re-fetch cons after the allocation */ - cons = ao_scheme_poly_cons(ao_scheme_poly_cons(ao_scheme_stack->values)->cdr); - - /* Reset the arg list to the current stack, - * and call the lambda - */ - - cons->car = ao_scheme_stack_poly(new); - cons->cdr = AO_SCHEME_NIL; - v = ao_scheme_lambda_eval(); - ao_scheme_stack->sexprs = v; - ao_scheme_stack->state = eval_begin; - return AO_SCHEME_NIL; -} diff --git a/src/scheme/ao_scheme_string.c b/src/scheme/ao_scheme_string.c deleted file mode 100644 index dfc74966..00000000 --- a/src/scheme/ao_scheme_string.c +++ /dev/null @@ -1,208 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * 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. - */ - -#include "ao_scheme.h" - -static void string_mark(void *addr) -{ - (void) addr; -} - -static int string_size(void *addr) -{ - struct ao_scheme_string *string = addr; - if (!addr) - return 0; - return strlen(string->val) + 2; -} - -static void string_move(void *addr) -{ - (void) addr; -} - -const struct ao_scheme_type ao_scheme_string_type = { - .mark = string_mark, - .size = string_size, - .move = string_move, - .name = "string", -}; - -static struct ao_scheme_string * -ao_scheme_string_alloc(int len) -{ - 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(a); - r = ao_scheme_string_alloc(alen); - a = ao_scheme_string_fetch(); - if (!r) - return NULL; - 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_atom_stash(a); - r = ao_scheme_string_alloc(alen); - a = ao_scheme_atom_fetch(); - if (!r) - return NULL; - strcpy(r->val, a->name); - return r; -} - -struct ao_scheme_string * -ao_scheme_string_cat(struct ao_scheme_string *a, struct ao_scheme_string *b) -{ - int alen = strlen(a->val); - int blen = strlen(b->val); - struct ao_scheme_string *r; - - ao_scheme_string_stash(a); - ao_scheme_string_stash(b); - r = ao_scheme_string_alloc(alen + blen); - b = ao_scheme_string_fetch(); - a = ao_scheme_string_fetch(); - if (!r) - return NULL; - strcpy(r->val, a->val); - strcpy(r->val+alen, b->val); - return r; -} - -ao_poly -ao_scheme_string_pack(struct ao_scheme_cons *cons) -{ - struct ao_scheme_string *r; - char *rval; - int len; - - len = ao_scheme_cons_length(cons); - ao_scheme_cons_stash(cons); - r = ao_scheme_string_alloc(len); - cons = ao_scheme_cons_fetch(); - if (!r) - return AO_SCHEME_NIL; - rval = r->val; - - while (cons) { - 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"); - cons = ao_scheme_cons_cdr(cons); - } - *rval++ = 0; - return ao_scheme_string_poly(r); -} - -ao_poly -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->val[i]); i++) { - struct ao_scheme_cons *n; - 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(); - tail = ao_scheme_cons_fetch(); - cons = ao_scheme_cons_fetch(); - - if (!n) { - cons = NULL; - break; - } - if (tail) - tail->cdr = ao_scheme_cons_poly(n); - else - cons = n; - tail = n; - } - return ao_scheme_cons_poly(cons); -} - -void -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; - - 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); - } -} diff --git a/src/scheme/ao_scheme_vector.c b/src/scheme/ao_scheme_vector.c deleted file mode 100644 index afdc89a8..00000000 --- a/src/scheme/ao_scheme_vector.c +++ /dev/null @@ -1,178 +0,0 @@ -/* - * Copyright © 2017 Keith Packard <keithp@keithp.com> - * - * 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, bool write) -{ - struct ao_scheme_vector *vector = ao_scheme_poly_vector(v); - unsigned int i; - int was_marked = 0; - - ao_scheme_print_start(); - was_marked = ao_scheme_print_mark_addr(vector); - if (was_marked) { - printf ("..."); - } else { - printf("#("); - for (i = 0; i < vector->length; i++) { - if (i != 0) - printf(" "); - ao_scheme_poly_write(vector->vals[i], write); - } - printf(")"); - } - if (ao_scheme_print_stop() && !was_marked) - ao_scheme_print_clear_addr(vector); -} - -static int32_t -ao_scheme_vector_offset(struct ao_scheme_vector *vector, ao_poly i) -{ - bool fail; - int32_t offset = ao_scheme_poly_integer(i, &fail); - - 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 = -1; - } - 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 < 0) - 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 < 0) - 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(cons); - vector = ao_scheme_vector_alloc(length, AO_SCHEME_NIL); - cons = ao_scheme_cons_fetch(); - 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_vector_stash(vector); - cons = ao_scheme_cons_cons(vector->vals[i], ao_scheme_cons_poly(cons)); - vector = ao_scheme_vector_fetch(); - if (!cons) - return NULL; - } - return cons; -} - -#endif /* AO_SCHEME_FEATURE_VECTOR */ diff --git a/src/scheme/make-const/.gitignore b/src/scheme/make-const/.gitignore deleted file mode 100644 index bcd57242..00000000 --- a/src/scheme/make-const/.gitignore +++ /dev/null @@ -1 +0,0 @@ -ao_scheme_make_const diff --git a/src/scheme/make-const/Makefile b/src/scheme/make-const/Makefile deleted file mode 100644 index a8e3a7f5..00000000 --- a/src/scheme/make-const/Makefile +++ /dev/null @@ -1,26 +0,0 @@ -include ../Makefile-inc - -vpath %.o . -vpath %.c .. -vpath %.h .. - -SRCS=$(SCHEME_SRCS) ao_scheme_make_const.c -HDRS=$(SCHEME_HDRS) ao_scheme_os.h - -OBJS=$(SRCS:.c=.o) - -CC=cc -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 $@ - -all: ao_scheme_make_const - -ao_scheme_make_const: $(OBJS) - $(CC) $(CFLAGS) -o $@ $^ -lm - -clean: - rm -f $(OBJS) ao_scheme_make_const - -$(OBJS): $(SCHEME_HDRS) diff --git a/src/scheme/make-const/ao_scheme_os.h b/src/scheme/make-const/ao_scheme_os.h deleted file mode 100644 index f06bbbb1..00000000 --- a/src/scheme/make-const/ao_scheme_os.h +++ /dev/null @@ -1,63 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * 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 <stdio.h> -#include <stdlib.h> -#include <time.h> - -extern int ao_scheme_getc(void); - -static inline void -ao_scheme_os_flush(void) { - 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/test/.gitignore b/src/scheme/test/.gitignore deleted file mode 100644 index 3622bc1d..00000000 --- a/src/scheme/test/.gitignore +++ /dev/null @@ -1 +0,0 @@ -ao-scheme diff --git a/src/scheme/test/Makefile b/src/scheme/test/Makefile deleted file mode 100644 index ee46118e..00000000 --- a/src/scheme/test/Makefile +++ /dev/null @@ -1,30 +0,0 @@ -include ../Makefile-inc - -vpath %.o . -vpath %.c .. -vpath %.h .. - -SRCS=$(SCHEME_SRCS) ao_scheme_test.c -HDRS=$(SCHEME_HDRS) ao_scheme_const.h - -OBJS=$(SRCS:.c=.o) - -#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 - -$(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 ao_scheme_const.h - -install: ao-scheme - install -t $$HOME/bin $^ diff --git a/src/scheme/test/ao_scheme_os.h b/src/scheme/test/ao_scheme_os.h deleted file mode 100644 index b225b2e8..00000000 --- a/src/scheme/test/ao_scheme_os.h +++ /dev/null @@ -1,67 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * 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 <stdio.h> -#include <stdlib.h> -#include <time.h> - -#define AO_SCHEME_POOL_TOTAL 32768 -#define AO_SCHEME_SAVE 1 - -extern int ao_scheme_getc(void); - -static inline void -ao_scheme_os_flush(void) { - 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/test/ao_scheme_test.c b/src/scheme/test/ao_scheme_test.c deleted file mode 100644 index 45068369..00000000 --- a/src/scheme/test/ao_scheme_test.c +++ /dev/null @@ -1,141 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * 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 <stdio.h> - -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/test/hanoi.scheme b/src/scheme/test/hanoi.scheme deleted file mode 100644 index c4ae7378..00000000 --- a/src/scheme/test/hanoi.scheme +++ /dev/null @@ -1,174 +0,0 @@ -; -; Towers of Hanoi -; -; Copyright © 2016 Keith Packard <keithp@keithp.com> -; -; 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. -; - - ; ANSI control sequences - -(define (move-to col row) - (for-each display (list "\033[" row ";" col "H")) - ) - -(define (clear) - (display "\033[2J") - ) - -(define (display-string x y str) - (move-to x y) - (display str) - ) - -(define (make-piece num max) - ; A piece for position 'num' - ; is num + 1 + num stars - ; centered in a field of max * - ; 2 + 1 characters with spaces - ; on either side. This way, - ; every piece is the same - ; number of characters - - (define (chars n c) - (if (zero? n) "" - (+ c (chars (- n 1) c)) - ) - ) - (+ (chars (- max num 1) " ") - (chars (+ (* num 2) 1) "*") - (chars (- max num 1) " ") - ) - ) - -(define (make-pieces max) - ; Make a list of numbers from 0 to max-1 - (define (nums cur max) - (if (= cur max) () - (cons cur (nums (+ cur 1) max)) - ) - ) - ; Create a list of pieces - - (map (lambda (x) (make-piece x max)) (nums 0 max)) - ) - - ; Here's all of the towers of pieces - ; This is generated when the program is run - -(define towers ()) - - ; position of the bottom of - ; the stacks set at runtime -(define bottom-y 0) -(define left-x 0) - -(define move-delay 25) - - ; Display one tower, clearing any - ; space above it - -(define (display-tower x y clear tower) - (cond ((= 0 clear) - (cond ((not (null? tower)) - (display-string x y (car tower)) - (display-tower x (+ y 1) 0 (cdr tower)) - ) - ) - ) - (else - (display-string x y " ") - (display-tower x (+ y 1) (- clear 1) tower) - ) - ) - ) - - ; Position of the top of the tower on the screen - ; Shorter towers start further down the screen - -(define (tower-pos tower) - (- bottom-y (length tower)) - ) - - ; Display all of the towers, spaced 20 columns apart - -(define (display-towers x towers) - (cond ((not (null? towers)) - (display-tower x 0 (tower-pos (car towers)) (car towers)) - (display-towers (+ x 20) (cdr towers))) - ) - ) - - ; Display all of the towers, then move the cursor - ; out of the way and flush the output - -(define (display-hanoi) - (display-towers left-x towers) - (move-to 1 23) - (flush-output) - (delay move-delay) - ) - - ; Reset towers to the starting state, with - ; all of the pieces in the first tower and the - ; other two empty - -(define (reset-towers len) - (set! towers (list (make-pieces len) () ())) - (set! bottom-y (+ len 3)) - ) - - ; Move a piece from the top of one tower - ; to the top of another - -(define (move-piece from to) - - ; references to the cons holding the two towers - - (define from-tower (list-tail towers from)) - (define to-tower (list-tail towers to)) - - ; stick the car of from-tower onto to-tower - - (set-car! to-tower (cons (caar from-tower) (car to-tower))) - - ; remove the car of from-tower - - (set-car! from-tower (cdar from-tower)) - ) - - ; The implementation of the game - -(define (_hanoi n from to use) - (cond ((= 1 n) - (move-piece from to) - (display-hanoi) - ) - (else - (_hanoi (- n 1) from use to) - (_hanoi 1 from to use) - (_hanoi (- n 1) use to from) - ) - ) - ) - - ; A pretty interface which - ; resets the state of the game, - ; clears the screen and runs - ; the program - -(define (hanoi len) - (reset-towers len) - (clear) - (display-hanoi) - (_hanoi len 0 1 2) - #t - ) diff --git a/src/scheme/tiny-test/.gitignore b/src/scheme/tiny-test/.gitignore deleted file mode 100644 index 7c4c3956..00000000 --- a/src/scheme/tiny-test/.gitignore +++ /dev/null @@ -1 +0,0 @@ -ao-scheme-tiny diff --git a/src/scheme/tiny-test/Makefile b/src/scheme/tiny-test/Makefile deleted file mode 100644 index 6b1fe003..00000000 --- a/src/scheme/tiny-test/Makefile +++ /dev/null @@ -1,28 +0,0 @@ -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.. -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 - -$(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 deleted file mode 100644 index b9f3e31f..00000000 --- a/src/scheme/tiny-test/ao_scheme_os.h +++ /dev/null @@ -1,67 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * 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 <stdio.h> -#include <stdlib.h> -#include <time.h> - -#define AO_SCHEME_POOL_TOTAL 4096 -#define AO_SCHEME_SAVE 1 - -extern int ao_scheme_getc(void); - -static inline void -ao_scheme_os_flush(void) { - 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 deleted file mode 100644 index 45068369..00000000 --- a/src/scheme/tiny-test/ao_scheme_test.c +++ /dev/null @@ -1,141 +0,0 @@ -/* - * Copyright © 2016 Keith Packard <keithp@keithp.com> - * - * 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 <stdio.h> - -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 deleted file mode 100644 index d0c0e578..00000000 --- a/src/scheme/tiny-test/ao_scheme_tiny_const.scheme +++ /dev/null @@ -1,389 +0,0 @@ -; -; Copyright © 2016 Keith Packard <keithp@keithp.com> -; -; 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 <condition> <if-true>) - ; (if <condition> <if-true> <if-false) - -(define if - (macro (test . args) - (cond ((null? (cdr args)) - (list cond (list test (car args))) - ) - (else - (list cond - (list test (car args)) - (list 'else (cadr args)) - ) - ) - ) - ) - ) - -(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/stmf0/Makefile-stmf0.defs b/src/stmf0/Makefile-stmf0.defs index fa6e6e86..4e9fa551 100644 --- a/src/stmf0/Makefile-stmf0.defs +++ b/src/stmf0/Makefile-stmf0.defs @@ -4,7 +4,7 @@ endif include $(TOPDIR)/Makedefs -vpath % $(TOPDIR)/stmf0:$(TOPDIR)/product:$(TOPDIR)/drivers:$(TOPDIR)/kernel:$(TOPDIR)/util:$(TOPDIR)/kalman:$(TOPDIR)/aes:$(TOPDIR):$(TOPDIR)/math:$(TOPDIR)/scheme +vpath % $(TOPDIR)/stmf0:$(TOPDIR)/product:$(TOPDIR)/drivers:$(TOPDIR)/kernel:$(TOPDIR)/util:$(TOPDIR)/kalman:$(TOPDIR)/aes:$(TOPDIR):$(TOPDIR)/math vpath make-altitude $(TOPDIR)/util vpath make-kalman $(TOPDIR)/util vpath kalman.5c $(TOPDIR)/kalman diff --git a/src/stmf0/Makefile.defs b/src/stmf0/Makefile.defs index 3da42874..a0aa558b 100644 --- a/src/stmf0/Makefile.defs +++ b/src/stmf0/Makefile.defs @@ -4,6 +4,10 @@ endif include $(TOPDIR)/stmf0/Makefile-stmf0.defs +LOADER=flash-loader/$(PROGNAME)-altos-flash-$(VERSION).elf +MAKEBIN=$(TOPDIR)/../ao-tools/ao-makebin/ao-makebin +FLASH_ADDR=0x08000000 + LDFLAGS=$(CFLAGS) -L$(TOPDIR)/stmf0 -Wl,-Taltos.ld -n .DEFAULT_GOAL=all diff --git a/src/stmf0/ao_adc_fast.c b/src/stmf0/ao_adc_fast.c index 5ce3a396..fbf4ad2e 100644 --- a/src/stmf0/ao_adc_fast.c +++ b/src/stmf0/ao_adc_fast.c @@ -154,7 +154,7 @@ ao_adc_init(void) #endif /* Set the clock */ - stm_adc.cfgr2 = STM_ADC_CFGR2_CKMODE_ADCCLK << STM_ADC_CFGR2_CKMODE; + stm_adc.cfgr2 = STM_ADC_CFGR2_CKMODE_PCLK_2 << STM_ADC_CFGR2_CKMODE; /* Shortest sample time */ stm_adc.smpr = STM_ADC_SMPR_SMP_1_5 << STM_ADC_SMPR_SMP; diff --git a/src/stmf0/ao_adc_fast.h b/src/stmf0/ao_adc_fast.h index 3f0b0547..504651e5 100644 --- a/src/stmf0/ao_adc_fast.h +++ b/src/stmf0/ao_adc_fast.h @@ -26,7 +26,7 @@ void ao_adc_init(void); /* Total ring size in samples */ -#define AO_ADC_RING_SIZE 256 +#define AO_ADC_RING_SIZE 1024 extern uint16_t ao_adc_ring[AO_ADC_RING_SIZE] __attribute__((aligned(4))); diff --git a/src/stmf0/ao_arch_funcs.h b/src/stmf0/ao_arch_funcs.h index 01d51f90..56a3bc75 100644 --- a/src/stmf0/ao_arch_funcs.h +++ b/src/stmf0/ao_arch_funcs.h @@ -488,14 +488,17 @@ static inline void ao_arch_start_scheduler(void) { /* ao_usb_stm.c */ #if AO_USB_DIRECTIO -uint16_t * -ao_usb_alloc(void); +uint8_t +ao_usb_alloc(uint16_t *buffers[2]); -void -ao_usb_write(uint16_t *buffer, uint16_t len); +uint8_t +ao_usb_alloc2(uint16_t *buffers[2]); -void -ao_usb_write2(uint16_t *buffer, uint16_t len); +uint8_t +ao_usb_write(uint16_t len); + +uint8_t +ao_usb_write2(uint16_t len); #endif /* AO_USB_DIRECTIO */ #endif /* _AO_ARCH_FUNCS_H_ */ diff --git a/src/stmf0/ao_usb_stm.c b/src/stmf0/ao_usb_stm.c index 59aed3aa..bf08abc1 100644 --- a/src/stmf0/ao_usb_stm.c +++ b/src/stmf0/ao_usb_stm.c @@ -82,15 +82,12 @@ static uint8_t ao_usb_ep0_out_len; */ /* Buffer description tables */ -static union stm_usb_bdt *ao_usb_bdt; -/* USB address of end of allocated storage */ -#if AO_USB_DIRECTIO -static uint16_t ao_usb_sram_addr; -#endif + +#define ao_usb_bdt ((union stm_usb_bdt *) (intptr_t) (void *) stm_usb_sram) /* Pointer to ep0 tx/rx buffers in USB memory */ -static uint16_t *ao_usb_ep0_tx_buffer; -static uint16_t *ao_usb_ep0_rx_buffer; +static uint16_t ao_usb_ep0_tx_offset; +static uint16_t ao_usb_ep0_rx_offset; #if AO_USB_HAS_INT /* Pointer to interrupt buffer in USB memory */ @@ -100,31 +97,19 @@ static uint16_t ao_usb_int_tx_offset; /* Pointer to bulk data tx/rx buffers in USB memory */ #if AO_USB_HAS_IN static uint16_t ao_usb_in_tx_offset; -static uint16_t *ao_usb_in_tx_buffer; - -/* System ram shadow of USB buffer; writing individual bytes is - * too much of a pain (sigh) */ -static uint8_t ao_usb_tx_buffer[AO_USB_IN_SIZE]; +static uint8_t ao_usb_in_tx_which; static uint8_t ao_usb_tx_count; #endif #if AO_USB_HAS_OUT static uint16_t ao_usb_out_rx_offset; -static uint16_t *ao_usb_out_rx_buffer; - -/* System ram shadow of USB buffer; writing individual bytes is - * too much of a pain (sigh) */ -static uint8_t ao_usb_rx_buffer[AO_USB_OUT_SIZE]; +static uint8_t ao_usb_out_rx_which; static uint8_t ao_usb_rx_count, ao_usb_rx_pos; #endif #if AO_USB_HAS_IN2 -static uint16_t ao_usb_in2_tx_offset; -static uint16_t *ao_usb_in2_tx_buffer; - -/* System ram shadow of USB buffer; writing individual bytes is - * too much of a pain (sigh) */ -static uint8_t ao_usb_tx2_buffer[AO_USB_IN_SIZE]; +static uint16_t ao_usb_in_tx2_offset; +static uint8_t ao_usb_in_tx2_which; static uint8_t ao_usb_tx2_count; #endif @@ -188,6 +173,16 @@ static inline uint16_t *ao_usb_packet_buffer_addr(uint16_t sram_addr) return (uint16_t *) (void *) (stm_usb_sram + sram_addr); } +static inline uint16_t ao_usb_packet_get(uint16_t sram_addr) +{ + return ao_usb_packet_buffer_addr(sram_addr)[0]; +} + +static inline void ao_usb_packet_put(uint16_t sram_addr, uint16_t val) +{ + ao_usb_packet_buffer_addr(sram_addr)[0] = val; +} + static inline uint16_t ao_usb_packet_buffer_offset(uint16_t *addr) { return (uint16_t) ((uint8_t *) addr - stm_usb_sram); @@ -217,10 +212,18 @@ static inline uint32_t ao_usb_epr_dtog_rx(uint32_t epr) { return (epr >> STM_USB_EPR_DTOG_RX) & 1; } +static inline uint32_t ao_usb_epr_sw_buf_tx(uint32_t epr) { + return (epr >> STM_USB_EPR_SW_BUF_TX) & 1; +} + static inline uint32_t ao_usb_epr_dtog_tx(uint32_t epr) { return (epr >> STM_USB_EPR_DTOG_TX) & 1; } +static inline uint32_t ao_usb_epr_sw_buf_rx(uint32_t epr) { + return (epr >> STM_USB_EPR_SW_BUF_RX) & 1; +} + /* * Set current device address and mark the * interface as active @@ -298,8 +301,8 @@ _ao_usb_set_stat_tx(int ep, uint32_t stat_tx) epr_write &= STM_USB_EPR_PRESERVE_MASK; epr_write |= STM_USB_EPR_INVARIANT; epr_write |= set_toggle(epr_old, - STM_USB_EPR_STAT_TX_MASK << STM_USB_EPR_STAT_TX, - stat_tx << STM_USB_EPR_STAT_TX); + STM_USB_EPR_STAT_TX_MASK << STM_USB_EPR_STAT_TX, + stat_tx << STM_USB_EPR_STAT_TX); stm_usb.epr[ep].r = epr_write; _tx_dbg1("set_stat_tx bottom", epr_write); } @@ -313,6 +316,21 @@ ao_usb_set_stat_tx(int ep, uint32_t stat_tx) } static void +_ao_usb_toggle_dtog(int ep, uint32_t dtog_rx, uint32_t dtog_tx) +{ + uint16_t epr_write; + + _tx_dbg1("toggle_dtog top", dtog_rx); + epr_write = stm_usb.epr[ep].r; + epr_write &= STM_USB_EPR_PRESERVE_MASK; + epr_write |= STM_USB_EPR_INVARIANT; + epr_write |= ((dtog_rx << STM_USB_EPR_DTOG_RX) | + (dtog_tx << STM_USB_EPR_DTOG_TX)); + stm_usb.epr[ep].r = epr_write; + _tx_dbg1("toggle_dtog bottom", epr_write); +} + +static void _ao_usb_set_stat_rx(int ep, uint32_t stat_rx) { uint16_t epr_write, epr_old; @@ -333,29 +351,35 @@ ao_usb_set_stat_rx(int ep, uint32_t stat_rx) { } /* - * Set just endpoint 0, for use during startup + * Initialize an entpoint */ static void -ao_usb_init_ep(uint8_t ep, uint32_t addr, uint32_t type, uint32_t stat_rx, uint32_t stat_tx) +ao_usb_init_ep(uint8_t ep, uint16_t addr, uint16_t type, + uint16_t stat_rx, uint16_t stat_tx, + uint16_t kind, + uint16_t dtog_rx, uint16_t dtog_tx) { uint16_t epr; ao_arch_block_interrupts(); epr = stm_usb.epr[ep].r; epr = ((0 << STM_USB_EPR_CTR_RX) | - (epr & (1 << STM_USB_EPR_DTOG_RX)) | - set_toggle(epr, - (STM_USB_EPR_STAT_RX_MASK << STM_USB_EPR_STAT_RX), - (stat_rx << STM_USB_EPR_STAT_RX)) | (type << STM_USB_EPR_EP_TYPE) | - (0 << STM_USB_EPR_EP_KIND) | + (kind << STM_USB_EPR_EP_KIND) | (0 << STM_USB_EPR_CTR_TX) | - (epr & (1 << STM_USB_EPR_DTOG_TX)) | + (addr << STM_USB_EPR_EA) | set_toggle(epr, + + (1 << STM_USB_EPR_DTOG_RX) | + (STM_USB_EPR_STAT_RX_MASK << STM_USB_EPR_STAT_RX) | + (1 << STM_USB_EPR_DTOG_TX) | (STM_USB_EPR_STAT_TX_MASK << STM_USB_EPR_STAT_TX), - (stat_tx << STM_USB_EPR_STAT_TX)) | - (addr << STM_USB_EPR_EA)); + + (dtog_rx << STM_USB_EPR_DTOG_RX) | + (stat_rx << STM_USB_EPR_STAT_RX) | + (dtog_tx << STM_USB_EPR_DTOG_TX) | + (stat_tx << STM_USB_EPR_STAT_TX))); stm_usb.epr[ep].r = epr; ao_arch_release_interrupts(); debug ("writing epr[%d] 0x%04x wrote 0x%04x\n", @@ -367,41 +391,37 @@ ao_usb_alloc_buffers(void) { uint16_t sram_addr = 0; - ao_usb_bdt = (void *) stm_usb_sram; + /* allocate space for BDT, which is at the start of SRAM */ sram_addr += 8 * STM_USB_BDT_SIZE; - ao_usb_ep0_tx_buffer = ao_usb_packet_buffer_addr(sram_addr); + ao_usb_ep0_tx_offset = sram_addr; sram_addr += AO_USB_CONTROL_SIZE; - ao_usb_ep0_rx_buffer = ao_usb_packet_buffer_addr(sram_addr); + ao_usb_ep0_rx_offset = sram_addr; sram_addr += AO_USB_CONTROL_SIZE; - #if AO_USB_HAS_INT + sram_addr += (sram_addr & 1); ao_usb_int_tx_offset = sram_addr; sram_addr += AO_USB_INT_SIZE; #endif #if AO_USB_HAS_OUT - ao_usb_out_rx_buffer = ao_usb_packet_buffer_addr(sram_addr); + sram_addr += (sram_addr & 1); ao_usb_out_rx_offset = sram_addr; - sram_addr += AO_USB_OUT_SIZE; + sram_addr += AO_USB_OUT_SIZE * 2; #endif #if AO_USB_HAS_IN - ao_usb_in_tx_buffer = ao_usb_packet_buffer_addr(sram_addr); + sram_addr += (sram_addr & 1); ao_usb_in_tx_offset = sram_addr; - sram_addr += AO_USB_IN_SIZE; + sram_addr += AO_USB_IN_SIZE * 2; #endif #if AO_USB_HAS_IN2 - ao_usb_in2_tx_buffer = ao_usb_packet_buffer_addr(sram_addr); - ao_usb_in2_tx_offset = sram_addr; - sram_addr += AO_USB_IN_SIZE; -#endif - -#if AO_USB_DIRECTIO - ao_usb_sram_addr = sram_addr; + sram_addr += (sram_addr & 1); + ao_usb_in_tx2_offset = sram_addr; + sram_addr += AO_USB_IN_SIZE * 2; #endif } @@ -410,11 +430,11 @@ ao_usb_init_btable(void) { /* Set up EP 0 - a Control end point with 32 bytes of in and out buffers */ - ao_usb_bdt[0].single.addr_tx = ao_usb_packet_buffer_offset(ao_usb_ep0_tx_buffer); - ao_usb_bdt[0].single.count_tx = 0; + stm_usb_bdt[0].single.addr_tx = ao_usb_ep0_tx_offset; + stm_usb_bdt[0].single.count_tx = 0; - ao_usb_bdt[0].single.addr_rx = ao_usb_packet_buffer_offset(ao_usb_ep0_rx_buffer); - ao_usb_bdt[0].single.count_rx = ((1 << STM_USB_BDT_COUNT_RX_BL_SIZE) | + stm_usb_bdt[0].single.addr_rx = ao_usb_ep0_rx_offset; + stm_usb_bdt[0].single.count_rx = ((1 << STM_USB_BDT_COUNT_RX_BL_SIZE) | (((AO_USB_CONTROL_SIZE / 32) - 1) << STM_USB_BDT_COUNT_RX_NUM_BLOCK)); } @@ -431,14 +451,16 @@ ao_usb_set_ep0(void) ao_usb_init_ep(AO_USB_CONTROL_EPR, AO_USB_CONTROL_EP, STM_USB_EPR_EP_TYPE_CONTROL, STM_USB_EPR_STAT_RX_VALID, - STM_USB_EPR_STAT_TX_NAK); + STM_USB_EPR_STAT_TX_NAK, + STM_USB_EPR_EP_KIND_NO_STATUS_OUT, 0, 0); /* Clear all of the other endpoints */ for (e = 1; e < 8; e++) { ao_usb_init_ep(e, 0, STM_USB_EPR_EP_TYPE_CONTROL, STM_USB_EPR_STAT_RX_DISABLED, - STM_USB_EPR_STAT_TX_DISABLED); + STM_USB_EPR_STAT_TX_DISABLED, + STM_USB_EPR_EP_KIND_SNGL_BUF, 0, 0); } ao_usb_set_address(0); @@ -464,51 +486,76 @@ ao_usb_set_configuration(void) #if AO_USB_HAS_INT /* Set up the INT end point */ - ao_usb_bdt[AO_USB_INT_EPR].single.addr_tx = ao_usb_int_tx_offset; - ao_usb_bdt[AO_USB_INT_EPR].single.count_tx = 0; + stm_usb_bdt[AO_USB_INT_EPR].single.addr_tx = ao_usb_int_tx_offset; + stm_usb_bdt[AO_USB_INT_EPR].single.count_tx = 0; ao_usb_init_ep(AO_USB_INT_EPR, AO_USB_INT_EP, STM_USB_EPR_EP_TYPE_INTERRUPT, STM_USB_EPR_STAT_RX_DISABLED, - STM_USB_EPR_STAT_TX_NAK); + STM_USB_EPR_STAT_TX_NAK, + STM_USB_EPR_EP_KIND_SNGL_BUF, 0, 0); #endif #if AO_USB_HAS_OUT /* Set up the OUT end point */ - ao_usb_bdt[AO_USB_OUT_EPR].single.addr_rx = ao_usb_out_rx_offset; - ao_usb_bdt[AO_USB_OUT_EPR].single.count_rx = ((1 << STM_USB_BDT_COUNT_RX_BL_SIZE) | - (((AO_USB_OUT_SIZE / 32) - 1) << STM_USB_BDT_COUNT_RX_NUM_BLOCK)); + stm_usb_bdt[AO_USB_OUT_EPR].double_rx[0].addr = ao_usb_out_rx_offset; + stm_usb_bdt[AO_USB_OUT_EPR].double_rx[0].count = ((1 << STM_USB_BDT_COUNT_RX_BL_SIZE) | + (((AO_USB_OUT_SIZE / 32) - 1) << STM_USB_BDT_COUNT_RX_NUM_BLOCK)); + stm_usb_bdt[AO_USB_OUT_EPR].double_rx[1].addr = ao_usb_out_rx_offset + AO_USB_OUT_SIZE; + stm_usb_bdt[AO_USB_OUT_EPR].double_rx[1].count = ((1 << STM_USB_BDT_COUNT_RX_BL_SIZE) | + (((AO_USB_OUT_SIZE / 32) - 1) << STM_USB_BDT_COUNT_RX_NUM_BLOCK)); + + /* set 'our' buffer to one, and the device buffer to 0 */ ao_usb_init_ep(AO_USB_OUT_EPR, AO_USB_OUT_EP, STM_USB_EPR_EP_TYPE_BULK, STM_USB_EPR_STAT_RX_VALID, - STM_USB_EPR_STAT_TX_DISABLED); + STM_USB_EPR_STAT_TX_DISABLED, + STM_USB_EPR_EP_KIND_DBL_BUF, 0, 1); + + /* At first receive, we'll flip this back to 0 */ + ao_usb_out_rx_which = 1; #endif #if AO_USB_HAS_IN /* Set up the IN end point */ - ao_usb_bdt[AO_USB_IN_EPR].single.addr_tx = ao_usb_in_tx_offset; - ao_usb_bdt[AO_USB_IN_EPR].single.count_tx = 0; + stm_usb_bdt[AO_USB_IN_EPR].double_tx[0].addr = ao_usb_in_tx_offset; + stm_usb_bdt[AO_USB_IN_EPR].double_tx[0].count = 0; + stm_usb_bdt[AO_USB_IN_EPR].double_tx[1].addr = ao_usb_in_tx_offset + AO_USB_IN_SIZE; + stm_usb_bdt[AO_USB_IN_EPR].double_tx[1].count = 0; + /* set 'our' buffer to 0, and the device buffer to 1 */ ao_usb_init_ep(AO_USB_IN_EPR, AO_USB_IN_EP, STM_USB_EPR_EP_TYPE_BULK, STM_USB_EPR_STAT_RX_DISABLED, - STM_USB_EPR_STAT_TX_NAK); + STM_USB_EPR_STAT_TX_NAK, + STM_USB_EPR_EP_KIND_DBL_BUF, + 0, 1); + + /* First transmit data goes to buffer 0 */ + ao_usb_in_tx_which = 0; #endif #if AO_USB_HAS_IN2 /* Set up the IN2 end point */ - ao_usb_bdt[AO_USB_IN2_EPR].single.addr_tx = ao_usb_in2_tx_offset; - ao_usb_bdt[AO_USB_IN2_EPR].single.count_tx = 0; + stm_usb_bdt[AO_USB_IN2_EPR].double_tx[0].addr = ao_usb_in_tx2_offset; + stm_usb_bdt[AO_USB_IN2_EPR].double_tx[0].count = 0; + stm_usb_bdt[AO_USB_IN2_EPR].double_tx[1].addr = ao_usb_in_tx2_offset + AO_USB_IN_SIZE; + stm_usb_bdt[AO_USB_IN2_EPR].double_tx[1].count = 0; ao_usb_init_ep(AO_USB_IN2_EPR, AO_USB_IN2_EP, STM_USB_EPR_EP_TYPE_BULK, STM_USB_EPR_STAT_RX_DISABLED, - STM_USB_EPR_STAT_TX_NAK); + STM_USB_EPR_STAT_TX_NAK, + STM_USB_EPR_EP_KIND_DBL_BUF, + 0, 1); + + /* First transmit data goes to buffer 0 */ + ao_usb_in_tx2_which = 0; #endif ao_usb_in_flushed = 0; @@ -531,39 +578,48 @@ ao_usb_set_configuration(void) #endif } +#if USB_STATUS static uint16_t control_count; static uint16_t int_count; static uint16_t in_count; static uint16_t out_count; static uint16_t reset_count; +#endif /* The USB memory must be accessed in 16-bit units */ static void -ao_usb_copy_tx(const uint8_t *src, uint16_t *base, uint16_t bytes) +ao_usb_tx_byte(uint16_t offset, uint8_t byte) { - while (bytes >= 2) { - *base++ = src[0] | (src[1] << 8); - src += 2; - bytes -= 2; - } - if (bytes) - *base = *src; + if (offset & 1) + ao_usb_packet_put(offset - 1, + ao_usb_packet_get(offset - 1) | ((uint16_t) byte) << 8); + else + ao_usb_packet_put(offset, (uint16_t) byte); +} + +static uint8_t +ao_usb_rx_byte(uint16_t offset) +{ + if (offset & 1) + return (uint8_t) ((ao_usb_packet_get(offset - 1)) >> 8); + else + return (uint8_t) ao_usb_packet_get(offset); } static void -ao_usb_copy_rx(uint8_t *dst, uint16_t *base, uint16_t bytes) +ao_usb_copy_tx(const uint8_t *src, uint16_t offset, uint16_t bytes) { - while (bytes >= 2) { - uint16_t s = *base++; - dst[0] = s; - dst[1] = s >> 8; - dst += 2; - bytes -= 2; - } - if (bytes) - *dst = *base; + while (bytes--) + ao_usb_tx_byte(offset++, *src++); +} + +static void +ao_usb_copy_rx(uint8_t *dst, uint16_t offset, uint16_t bytes) +{ + while (bytes--) + *dst++ = ao_usb_rx_byte(offset++); } /* Send an IN data packet */ @@ -588,12 +644,12 @@ ao_usb_ep0_flush(void) ao_usb_ep0_in_len -= this_len; debug_data ("Flush EP0 len %d:", this_len); - ao_usb_copy_tx(ao_usb_ep0_in_data, ao_usb_ep0_tx_buffer, this_len); + ao_usb_copy_tx(ao_usb_ep0_in_data, ao_usb_ep0_tx_offset, this_len); debug_data ("\n"); ao_usb_ep0_in_data += this_len; /* Mark the endpoint as TX valid to send the packet */ - ao_usb_bdt[AO_USB_CONTROL_EPR].single.count_tx = this_len; + stm_usb_bdt[AO_USB_CONTROL_EPR].single.count_tx = this_len; ao_usb_set_stat_tx(AO_USB_CONTROL_EPR, STM_USB_EPR_STAT_TX_VALID); debug ("queue tx. epr 0 now %08x\n", stm_usb.epr[AO_USB_CONTROL_EPR]); } @@ -602,7 +658,7 @@ ao_usb_ep0_flush(void) static void ao_usb_ep0_fill(void) { - uint16_t len = ao_usb_bdt[0].single.count_rx & STM_USB_BDT_COUNT_RX_COUNT_RX_MASK; + uint16_t len = stm_usb_bdt[0].single.count_rx & STM_USB_BDT_COUNT_RX_COUNT_RX_MASK; if (len > ao_usb_ep0_out_len) len = ao_usb_ep0_out_len; @@ -610,7 +666,7 @@ ao_usb_ep0_fill(void) /* Pull all of the data out of the packet */ debug_data ("Fill EP0 len %d:", len); - ao_usb_copy_rx(ao_usb_ep0_out_data, ao_usb_ep0_rx_buffer, len); + ao_usb_copy_rx(ao_usb_ep0_out_data, ao_usb_ep0_rx_offset, len); debug_data ("\n"); ao_usb_ep0_out_data += len; @@ -895,7 +951,9 @@ stm_usb_isr(void) switch (ep) { case 0: +#if USB_STATUS ++control_count; +#endif if (ao_usb_epr_ctr_rx(epr)) { if (ao_usb_epr_setup(epr)) ao_usb_ep0_receive |= AO_USB_EP0_GOT_SETUP; @@ -907,7 +965,9 @@ stm_usb_isr(void) ao_usb_ep0_handle(ao_usb_ep0_receive); break; case AO_USB_OUT_EPR: +#if USB_STATUS ++out_count; +#endif if (ao_usb_epr_ctr_rx(epr)) { _rx_dbg1("RX ISR", epr); ao_usb_out_avail = 1; @@ -917,7 +977,9 @@ stm_usb_isr(void) } break; case AO_USB_IN_EPR: +#if USB_STATUS ++in_count; +#endif _tx_dbg1("TX ISR", epr); if (ao_usb_epr_ctr_tx(epr)) { ao_usb_in_pending = 0; @@ -935,7 +997,9 @@ stm_usb_isr(void) break; #endif case AO_USB_INT_EPR: +#if USB_STATUS ++int_count; +#endif if (ao_usb_epr_ctr_tx(epr)) _ao_usb_set_stat_tx(AO_USB_INT_EPR, STM_USB_EPR_STAT_TX_NAK); break; @@ -944,7 +1008,9 @@ stm_usb_isr(void) } if (istr & (1 << STM_USB_ISTR_RESET)) { +#if USB_STATUS ++reset_count; +#endif debug ("\treset\n"); ao_usb_set_ep0(); } @@ -972,11 +1038,18 @@ _ao_usb_in_send(void) ao_usb_in_pending = 1; if (ao_usb_tx_count != AO_USB_IN_SIZE) ao_usb_in_flushed = 1; - ao_usb_copy_tx(ao_usb_tx_buffer, ao_usb_in_tx_buffer, ao_usb_tx_count); - ao_usb_bdt[AO_USB_IN_EPR].single.addr_tx = ao_usb_in_tx_offset; - ao_usb_bdt[AO_USB_IN_EPR].single.count_tx = ao_usb_tx_count; + stm_usb_bdt[AO_USB_IN_EPR].double_tx[ao_usb_in_tx_which].count = ao_usb_tx_count; ao_usb_tx_count = 0; + + /* Toggle our usage */ + ao_usb_in_tx_which = 1 - ao_usb_in_tx_which; + + /* Toggle the SW_BUF flag */ + _ao_usb_toggle_dtog(AO_USB_IN_EPR, 1, 0); + + /* Mark the outgoing buffer as valid */ _ao_usb_set_stat_tx(AO_USB_IN_EPR, STM_USB_EPR_STAT_TX_VALID); + _tx_dbg0("in_send end"); } @@ -1029,7 +1102,7 @@ ao_usb_putchar(char c) _ao_usb_in_wait(); ao_usb_in_flushed = 0; - ao_usb_tx_buffer[ao_usb_tx_count++] = (uint8_t) c; + ao_usb_tx_byte(ao_usb_in_tx_offset + AO_USB_IN_SIZE * ao_usb_in_tx_which + ao_usb_tx_count++, c); /* Send the packet when full */ if (ao_usb_tx_count == AO_USB_IN_SIZE) { @@ -1053,11 +1126,15 @@ _ao_usb_in2_send(void) ao_usb_in2_pending = 1; if (ao_usb_tx2_count != AO_USB_IN_SIZE) ao_usb_in2_flushed = 1; - ao_usb_copy_tx(ao_usb_tx2_buffer, ao_usb_in2_tx_buffer, ao_usb_tx2_count); - ao_usb_bdt[AO_USB_IN2_EPR].single.addr_tx = ao_usb_in_tx_offset; - ao_usb_bdt[AO_USB_IN2_EPR].single.count_tx = ao_usb_tx_count; + stm_usb_bdt[AO_USB_IN2_EPR].double_tx[ao_usb_in_tx2_which].count = ao_usb_tx2_count; ao_usb_tx2_count = 0; + + /* Toggle our usage */ + ao_usb_in_tx2_which = 1 - ao_usb_in_tx2_which; + + /* Mark the outgoing buffer as valid */ _ao_usb_set_stat_tx(AO_USB_IN2_EPR, STM_USB_EPR_STAT_TX_VALID); + _tx_dbg0("in2_send end"); } @@ -1110,7 +1187,7 @@ ao_usb_putchar2(char c) _ao_usb_in2_wait(); ao_usb_in2_flushed = 0; - ao_usb_tx2_buffer[ao_usb_tx2_count++] = (uint8_t) c; + ao_usb_tx_byte(ao_usb_in_tx2_offset + AO_USB_IN_SIZE * ao_usb_in_tx2_which + ao_usb_tx2_count++, c); /* Send the packet when full */ if (ao_usb_tx2_count == AO_USB_IN_SIZE) { @@ -1126,20 +1203,24 @@ ao_usb_putchar2(char c) static void _ao_usb_out_recv(void) { - _rx_dbg0("out_recv top"); + _rx_dbg1("out_recv top", stm_usb.epr[AO_USB_OUT_EPR].r); + + /* Clear packet available field until we get another interrupt */ ao_usb_out_avail = 0; - ao_usb_rx_count = ao_usb_bdt[AO_USB_OUT_EPR].single.count_rx & STM_USB_BDT_COUNT_RX_COUNT_RX_MASK; + /* Switch to new buffer */ + ao_usb_out_rx_which = 1 - ao_usb_out_rx_which; - _rx_dbg1("out_recv count", ao_usb_rx_count); - debug ("recv %d\n", ao_usb_rx_count); - debug_data("Fill OUT len %d:", ao_usb_rx_count); - ao_usb_copy_rx(ao_usb_rx_buffer, ao_usb_out_rx_buffer, ao_usb_rx_count); - debug_data("\n"); + ao_usb_rx_count = stm_usb_bdt[AO_USB_OUT_EPR].double_rx[ao_usb_out_rx_which].count & STM_USB_BDT_COUNT_RX_COUNT_RX_MASK; ao_usb_rx_pos = 0; - /* ACK the packet */ - _ao_usb_set_stat_rx(AO_USB_OUT_EPR, STM_USB_EPR_STAT_RX_VALID); + /* Toggle the SW_BUF_RX bit */ + _ao_usb_toggle_dtog(AO_USB_OUT_EPR, 0, 1); + +// /* Ack the packet */ +// _ao_usb_set_stat_rx(AO_USB_OUT_EPR, STM_USB_EPR_STAT_RX_VALID); + + _rx_dbg1("out_recv count", ao_usb_rx_count); } int @@ -1154,17 +1235,18 @@ _ao_usb_pollchar(void) if (ao_usb_rx_pos != ao_usb_rx_count) break; - _rx_dbg0("poll check"); +// _rx_dbg0("poll check"); /* Check to see if a packet has arrived */ if (!ao_usb_out_avail) { - _rx_dbg0("poll none"); +// _rx_dbg0("poll none"); return AO_READ_AGAIN; } _ao_usb_out_recv(); } /* Pull a character out of the fifo */ - c = ao_usb_rx_buffer[ao_usb_rx_pos++]; + c = ao_usb_rx_byte(ao_usb_out_rx_offset + ao_usb_out_rx_which * AO_USB_OUT_SIZE + ao_usb_rx_pos++); + _rx_dbg1("char", c); return c; } @@ -1182,18 +1264,18 @@ ao_usb_getchar(void) #endif #if AO_USB_DIRECTIO -uint16_t * -ao_usb_alloc(void) -{ - uint16_t *buffer; - buffer = ao_usb_packet_buffer_addr(ao_usb_sram_addr); - ao_usb_sram_addr += AO_USB_IN_SIZE; - return buffer; +#if AO_USB_HAS_IN +uint8_t +ao_usb_alloc(uint16_t *buffers[2]) +{ + buffers[0] = ao_usb_packet_buffer_addr(ao_usb_in_tx_offset); + buffers[1] = ao_usb_packet_buffer_addr(ao_usb_in_tx_offset + AO_USB_IN_SIZE); + return ao_usb_in_tx_which; } -void -ao_usb_write(uint16_t *buffer, uint16_t len) +uint8_t +ao_usb_write(uint16_t len) { ao_arch_block_interrupts(); @@ -1205,12 +1287,6 @@ ao_usb_write(uint16_t *buffer, uint16_t len) continue; } - /* Flush any pending regular I/O */ - if (ao_usb_tx_count) { - _ao_usb_in_send(); - continue; - } - /* Wait for an idle IN buffer */ if (ao_usb_in_pending) { ao_sleep(&ao_usb_in_pending); @@ -1221,15 +1297,35 @@ ao_usb_write(uint16_t *buffer, uint16_t len) ao_usb_in_pending = 1; ao_usb_in_flushed = (len != AO_USB_IN_SIZE); - ao_usb_bdt[AO_USB_IN_EPR].single.addr_tx = ao_usb_packet_buffer_offset(buffer); - ao_usb_bdt[AO_USB_IN_EPR].single.count_tx = len; + + stm_usb_bdt[AO_USB_IN_EPR].double_tx[ao_usb_in_tx_which].count = len; + + /* Toggle our usage */ + ao_usb_in_tx_which = 1 - ao_usb_in_tx_which; + + /* Toggle the SW_BUF flag */ + _ao_usb_toggle_dtog(AO_USB_IN_EPR, 1, 0); + + /* Mark the outgoing buffer as valid */ _ao_usb_set_stat_tx(AO_USB_IN_EPR, STM_USB_EPR_STAT_TX_VALID); + ao_arch_release_interrupts(); + return ao_usb_in_tx_which; } +#endif #if AO_USB_HAS_IN2 -void -ao_usb_write2(uint16_t *buffer, uint16_t len) + +uint8_t +ao_usb_alloc2(uint16_t *buffers[2]) +{ + buffers[0] = ao_usb_packet_buffer_addr(ao_usb_in_tx2_offset); + buffers[1] = ao_usb_packet_buffer_addr(ao_usb_in_tx2_offset + AO_USB_IN_SIZE); + return ao_usb_in_tx2_which; +} + +uint8_t +ao_usb_write2(uint16_t len) { ao_arch_block_interrupts(); @@ -1241,12 +1337,6 @@ ao_usb_write2(uint16_t *buffer, uint16_t len) continue; } - /* Flush any pending regular I/O */ - if (ao_usb_tx2_count) { - _ao_usb_in2_send(); - continue; - } - /* Wait for an idle IN buffer */ if (ao_usb_in2_pending) { ao_sleep(&ao_usb_in2_pending); @@ -1257,10 +1347,20 @@ ao_usb_write2(uint16_t *buffer, uint16_t len) ao_usb_in2_pending = 1; ao_usb_in2_flushed = (len != AO_USB_IN_SIZE); - ao_usb_bdt[AO_USB_IN2_EPR].single.addr_tx = ao_usb_packet_buffer_offset(buffer); - ao_usb_bdt[AO_USB_IN2_EPR].single.count_tx = len; + + stm_usb_bdt[AO_USB_IN2_EPR].double_tx[ao_usb_in_tx2_which].count = len; + + /* Toggle our usage */ + ao_usb_in_tx2_which = 1 - ao_usb_in_tx2_which; + + /* Toggle the SW_BUF flag */ + _ao_usb_toggle_dtog(AO_USB_IN2_EPR, 1, 0); + + /* Mark the outgoing buffer as valid */ _ao_usb_set_stat_tx(AO_USB_IN2_EPR, STM_USB_EPR_STAT_TX_VALID); ao_arch_release_interrupts(); + + return ao_usb_in_tx2_which; } #endif #endif @@ -1443,8 +1543,8 @@ struct ao_usb_dbg { #define NUM_USB_DBG 128 -static struct ao_usb_dbg dbg[128]; -static int dbg_i; +struct ao_usb_dbg dbg[128]; +int dbg_i; static void _dbg(int line, char *msg, uint32_t value) { @@ -1465,7 +1565,7 @@ static void _dbg(int line, char *msg, uint32_t value) dbg[dbg_i].rx_count = ao_usb_rx_count; dbg[dbg_i].rx_pos = ao_usb_rx_pos; dbg[dbg_i].out_avail = ao_usb_out_avail; - dbg[dbg_i].out_epr = stm_usb.epr[AO_USB_OUT_EPR]; + dbg[dbg_i].out_epr = stm_usb.epr[AO_USB_OUT_EPR].r; #endif if (++dbg_i == NUM_USB_DBG) dbg_i = 0; diff --git a/src/stmf0/registers.ld b/src/stmf0/registers.ld index 1f9862b1..c301a7ce 100644 --- a/src/stmf0/registers.ld +++ b/src/stmf0/registers.ld @@ -26,6 +26,7 @@ stm_crs = 0x40006c00; stm_bxcan = 0x40006400; stm_usb_sram = 0x40006000; +stm_usb_bdt = 0x40006000; stm_usb = 0x40005c00; stm_i2c1 = 0x40005400; diff --git a/src/stmf0/stm32f0.h b/src/stmf0/stm32f0.h index 61faf2e4..968c1295 100644 --- a/src/stmf0/stm32f0.h +++ b/src/stmf0/stm32f0.h @@ -1890,6 +1890,7 @@ extern struct stm_usb stm_usb; #define STM_USB_EPR_CTR_RX 15 #define STM_USB_EPR_CTR_RX_WRITE_INVARIANT 1 #define STM_USB_EPR_DTOG_RX 14 +#define STM_USB_EPR_SW_BUF_TX 14 #define STM_USB_EPR_DTOG_RX_WRITE_INVARIANT 0 #define STM_USB_EPR_STAT_RX 12 #define STM_USB_EPR_STAT_RX_DISABLED 0 @@ -1906,11 +1907,14 @@ extern struct stm_usb stm_usb; #define STM_USB_EPR_EP_TYPE_INTERRUPT 3 #define STM_USB_EPR_EP_TYPE_MASK 3 #define STM_USB_EPR_EP_KIND 8 +#define STM_USB_EPR_EP_KIND_SNGL_BUF 0 /* Bulk */ #define STM_USB_EPR_EP_KIND_DBL_BUF 1 /* Bulk */ +#define STM_USB_EPR_EP_KIND_NO_STATUS_OUT 0 /* Control */ #define STM_USB_EPR_EP_KIND_STATUS_OUT 1 /* Control */ #define STM_USB_EPR_CTR_TX 7 #define STM_USB_CTR_TX_WRITE_INVARIANT 1 #define STM_USB_EPR_DTOG_TX 6 +#define STM_USB_EPR_SW_BUF_RX 6 #define STM_USB_EPR_DTOG_TX_WRITE_INVARIANT 0 #define STM_USB_EPR_STAT_TX 4 #define STM_USB_EPR_STAT_TX_DISABLED 0 @@ -1996,7 +2000,12 @@ union stm_usb_bdt { #define STM_USB_BDT_SIZE 8 +/* We'll use the first block of usb SRAM for the BDT */ extern uint8_t stm_usb_sram[] __attribute__((aligned(4))); +extern union stm_usb_bdt stm_usb_bdt[STM_USB_BDT_SIZE] __attribute__((aligned(4))); + +#define stm_usb_sram ((uint8_t *) 0x40006000) +#define stm_usb_bdt ((union stm_usb_bdt *) 0x40006000) struct stm_exti { vuint32_t imr; diff --git a/telegps/Makefile.am b/telegps/Makefile.am index 9dd2ceac..2fe231f1 100644 --- a/telegps/Makefile.am +++ b/telegps/Makefile.am @@ -112,7 +112,8 @@ FIRMWARE_TBT_4_0=$(top_srcdir)/src/telebt-v4.0/telebt-v4.0-$(VERSION).ihx FIRMWARE_TBT=$(FIRMWARE_TBT_1_0) $(FIRMWARE_TBT_3_0) $(FIRMWARE_TBT_4_0) FIRMWARE_TG_1_0=$(top_srcdir)/src/telegps-v1.0/telegps-v1.0-$(VERSION).ihx -FIRMWARE_TG=$(FIRMWARE_TG_1_0) +FIRMWARE_TG_2_0=$(top_srcdir)/src/telegps-v2.0/telegps-v2.0-$(VERSION).ihx +FIRMWARE_TG=$(FIRMWARE_TG_1_0) $(FIRMWARE_TG_2_0) FIRMWARE=$(FIRMWARE_TG) $(FIRMWARE_TD) $(FIRMWARE_TBT) diff --git a/telegps/telegps-windows.nsi.in b/telegps/telegps-windows.nsi.in index d0cd969c..e6ce9f84 100644 --- a/telegps/telegps-windows.nsi.in +++ b/telegps/telegps-windows.nsi.in @@ -121,6 +121,7 @@ Section "TeleGPS, TeleDongle and TeleBT Firmware" SetOutPath $INSTDIR File "../src/telegps-v1.0/telegps-v1.0-${VERSION}.ihx" + File "../src/telegps-v2.0/telegps-v2.0-${VERSION}.ihx" File "../src/teledongle-v0.2/teledongle-v0.2-${VERSION}.ihx" File "../src/teledongle-v3.0/teledongle-v3.0-${VERSION}.ihx" File "../src/telebt-v1.0/telebt-v1.0-${VERSION}.ihx" |