From 60666630789b6925d7e16160ebdc88ccd23f51de Mon Sep 17 00:00:00 2001 From: Bdale Garbee Date: Mon, 18 Sep 2017 20:43:14 -0600 Subject: be more aggressive about removing and ignoring .mdwn files --- .gitignore | 1 + altosui/Makefile.am | 2 +- micropeak/Makefile.am | 2 +- telegps/Makefile.am | 2 +- 4 files changed, 4 insertions(+), 3 deletions(-) diff --git a/.gitignore b/.gitignore index 61f48048..48a39f73 100644 --- a/.gitignore +++ b/.gitignore @@ -7,6 +7,7 @@ *.lnk *.lst *.map +*.mdwn *.mem *.o *.rel diff --git a/altosui/Makefile.am b/altosui/Makefile.am index 53762aec..6f206c3d 100644 --- a/altosui/Makefile.am +++ b/altosui/Makefile.am @@ -194,7 +194,7 @@ clean-local: Altos-Linux-*.tar.bz2 Altos-Linux-*.sh Altos-Mac-*.dmg Altos-Windows-*.exe \ windows altoslib_*.jar altosuilib_*.jar $(FREETTS_CLASS) \ $(JFREECHART_CLASS) $(JCOMMON_CLASS) $(LIBALTOS) Manifest.txt Manifest-fat.txt altos-windows.log altos-windows.nsi \ - altosui altosui-test altosui-jdb macosx linux *.desktop $(MDWN) + altosui altosui-test altosui-jdb macosx linux *.desktop *.mdwn EXTRA_DIST = $(desktop_file).in diff --git a/micropeak/Makefile.am b/micropeak/Makefile.am index 6f674b19..5e153b82 100644 --- a/micropeak/Makefile.am +++ b/micropeak/Makefile.am @@ -103,7 +103,7 @@ clean-local: altoslib_*.jar altosuilib_*.jar \ $(JFREECHART_CLASS) $(JCOMMON_CLASS) $(LIBALTOS) Manifest.txt Manifest-fat.txt \ micropeak micropeak-test micropeak-jdb macosx linux windows micropeak-windows.log \ - micropeak-windows.nsi *.desktop $(MDWN) + micropeak-windows.nsi *.desktop *.mdwn EXTRA_DIST = $(desktop_file).in diff --git a/telegps/Makefile.am b/telegps/Makefile.am index a1c4a0a1..9dd2ceac 100644 --- a/telegps/Makefile.am +++ b/telegps/Makefile.am @@ -128,7 +128,7 @@ clean-local: altoslib_*.jar altosuilib_*.jar \ $(JFREECHART_CLASS) $(JCOMMON_CLASS) $(FREETTS_CLASS) $(LIBALTOS) Manifest.txt Manifest-fat.txt \ telegps telegps-test telegps-jdb macosx linux windows telegps-windows.log \ - telegps-windows.nsi *.desktop $(MDWN) + telegps-windows.nsi *.desktop *.mdwn EXTRA_DIST = $(desktop_file).in -- cgit v1.2.3 From 8124109e0b455c9d8d583f4d985b93d23d7b1350 Mon Sep 17 00:00:00 2001 From: Bdale Garbee Date: Mon, 18 Sep 2017 21:24:52 -0600 Subject: tweak Releasing based on 1.8.2 release experience --- Releasing | 1 + 1 file changed, 1 insertion(+) diff --git a/Releasing b/Releasing index 8af50a1e..b8f8b75f 100644 --- a/Releasing +++ b/Releasing @@ -126,6 +126,7 @@ These are Bdale's notes on how to do a release. src/telemini-v3.0/flash-loader/{*.elf,*.bin} \ ~/altusmetrumllc/Binaries/loaders/ (cd ~/altusmetrumllc ; git add Binaries ; git commit -a) + - remove previous versions (only keep latest release) (cd ~/altusmetrumllc ; git push) - Push new release to web site -- cgit v1.2.3 From df39a30c762d57c7d04110e054f74d50fa8d85de Mon Sep 17 00:00:00 2001 From: Bdale Garbee Date: Tue, 19 Sep 2017 11:56:52 -0600 Subject: don't exit on dfu-util errors, it's not reliable about reporting success --- ao-bringup/turnon_telebt | 2 +- ao-bringup/turnon_telegps | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/ao-bringup/turnon_telebt b/ao-bringup/turnon_telebt index fb8318b3..8bf9bcb5 100755 --- a/ao-bringup/turnon_telebt +++ b/ao-bringup/turnon_telebt @@ -44,7 +44,7 @@ esac FLASH_FILE=$REPO/loaders/telebt-v$VERSION-altos-flash-*.bin ALTOS_FILE=$REPO/telebt-v$VERSION-*.elf -$DFU_UTIL -a 0 -s 0x08000000:leave -D $FLASH_FILE || exit 1 +$DFU_UTIL -a 0 -s 0x08000000:leave -D $FLASH_FILE sleep 2 diff --git a/ao-bringup/turnon_telegps b/ao-bringup/turnon_telegps index fd879abd..48af692a 100755 --- a/ao-bringup/turnon_telegps +++ b/ao-bringup/turnon_telegps @@ -49,7 +49,7 @@ esac FLASH_FILE=$REPO/loaders/telegps-v2.0-altos-flash-*.bin ALTOS_FILE=$REPO/telegps-v2.0-*.elf -$DFU_UTIL -a 0 -s 0x08000000:leave -D $FLASH_FILE || exit 1 +$DFU_UTIL -a 0 -s 0x08000000:leave -D $FLASH_FILE sleep 2 -- cgit v1.2.3 From cfc09e8f1f263595972cbb6af23f22e2d749c744 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 26 Sep 2017 18:00:36 -0700 Subject: altoslib: Add tilt and pyro data to CSV export It's now version 6. Also removed duplicate time values and made radio values conditional on having radio data. Signed-off-by: Keith Packard --- altoslib/AltosCSV.java | 87 +++++++++++++++++++++++++++++++++++------ altoslib/AltosFlightSeries.java | 2 +- altoslib/AltosLib.java | 6 ++- 3 files changed, 80 insertions(+), 15 deletions(-) diff --git a/altoslib/AltosCSV.java b/altoslib/AltosCSV.java index f55b4785..a8de23f0 100644 --- a/altoslib/AltosCSV.java +++ b/altoslib/AltosCSV.java @@ -29,9 +29,11 @@ public class AltosCSV implements AltosWriter { int boost_tick; boolean has_basic; + boolean has_radio; boolean has_battery; boolean has_flight_state; boolean has_advanced; + boolean has_igniter; boolean has_gps; boolean has_gps_sat; boolean has_companion; @@ -39,7 +41,7 @@ public class AltosCSV implements AltosWriter { AltosFlightSeries series; int[] indices; - static final int ALTOS_CSV_VERSION = 5; + static final int ALTOS_CSV_VERSION = 6; /* Version 4 format: * @@ -49,7 +51,8 @@ public class AltosCSV implements AltosWriter { * flight number * callsign * time (seconds since boost) - * clock (tick count / 100) + * + * Radio info (if available) * rssi * link quality * @@ -81,6 +84,14 @@ public class AltosCSV implements AltosWriter { * mag_x (g) * mag_y (g) * mag_z (g) + * tilt (d) + * + * Extra igniter voltages (if available) + * pyro (V) + * igniter_a (V) + * igniter_b (V) + * igniter_c (V) + * igniter_d (V) * * GPS data (if available) * connected (1/0) @@ -115,13 +126,26 @@ public class AltosCSV implements AltosWriter { */ void write_general_header() { - out.printf("version,serial,flight,call,time,clock,rssi,lqi"); + out.printf("version,serial,flight,call,time"); } double time() { return series.time(indices); } + void write_general() { + out.printf("%s, %d, %d, %s, %8.2f", + ALTOS_CSV_VERSION, + series.cal_data().serial, + series.cal_data().flight, + series.cal_data().callsign, + time()); + } + + void write_radio_header() { + out.printf("rssi,lqi"); + } + int rssi() { return (int) series.value(AltosFlightSeries.rssi_name, indices); } @@ -130,12 +154,8 @@ public class AltosCSV implements AltosWriter { return (int) series.value(AltosFlightSeries.status_name, indices); } - void write_general() { - double time = time(); - out.printf("%s, %d, %d, %s, %8.2f, %8.2f, %4d, %3d", - ALTOS_CSV_VERSION, series.cal_data().serial, - series.cal_data().flight, series.cal_data().callsign, - time, time, + void write_radio() { + out.printf("%4d, %3d", rssi(), status() & 0x7f); } @@ -149,7 +169,7 @@ public class AltosCSV implements AltosWriter { void write_flight() { int state = state(); - out.printf("%d,%8s", state, AltosLib.state_name(state)); + out.printf("%2d,%8s", state, AltosLib.state_name(state)); } void write_basic_header() { @@ -189,7 +209,7 @@ public class AltosCSV implements AltosWriter { } void write_advanced_header() { - out.printf("accel_x,accel_y,accel_z,gyro_x,gyro_y,gyro_z,mag_x,mag_y,mag_z"); + out.printf("accel_x,accel_y,accel_z,gyro_x,gyro_y,gyro_z,mag_x,mag_y,mag_z,tilt"); } double accel_along() { return series.value(AltosFlightSeries.accel_along_name, indices); } @@ -204,11 +224,30 @@ public class AltosCSV implements AltosWriter { double mag_across() { return series.value(AltosFlightSeries.mag_across_name, indices); } double mag_through() { return series.value(AltosFlightSeries.mag_through_name, indices); } + double tilt() { return series.value(AltosFlightSeries.orient_name, indices); } + void write_advanced() { - out.printf("%7.2f,%7.2f,%7.2f,%7.2f,%7.2f,%7.2f,%7.2f,%7.2f,%7.2f", + out.printf("%7.2f,%7.2f,%7.2f,%7.2f,%7.2f,%7.2f,%7.2f,%7.2f,%7.2f,%7.2f", accel_along(), accel_across(), accel_through(), gyro_roll(), gyro_pitch(), gyro_yaw(), - mag_along(), mag_across(), mag_through()); + mag_along(), mag_across(), mag_through(), + tilt()); + } + + void write_igniter_header() { + out.printf("pyro"); + for (int i = 0; i < series.igniter_voltage.length; i++) + out.printf(",%s", AltosLib.igniter_short_name(i)); + } + + double pyro() { return series.value(AltosFlightSeries.pyro_voltage_name, indices); } + + double igniter_value(int channel) { return series.value(series.igniter_voltage_name(channel), indices); } + + void write_igniter() { + out.printf("%5.2f", pyro()); + for (int i = 0; i < series.igniter_voltage.length; i++) + out.printf(",%5.2f", igniter_value(i)); } void write_gps_header() { @@ -306,6 +345,10 @@ public class AltosCSV implements AltosWriter { void write_header() { out.printf("#"); write_general_header(); + if (has_radio) { + out.printf(","); + write_radio_header(); + } if (has_flight_state) { out.printf(","); write_flight_header(); @@ -322,6 +365,10 @@ public class AltosCSV implements AltosWriter { out.printf(","); write_advanced_header(); } + if (has_igniter) { + out.printf(","); + write_igniter_header(); + } if (has_gps) { out.printf(","); write_gps_header(); @@ -339,6 +386,10 @@ public class AltosCSV implements AltosWriter { void write_one() { write_general(); + if (has_radio) { + out.printf(","); + write_radio(); + } if (has_flight_state) { out.printf(","); write_flight(); @@ -355,6 +406,10 @@ public class AltosCSV implements AltosWriter { out.printf(","); write_advanced(); } + if (has_igniter) { + out.printf(","); + write_igniter(); + } if (has_gps) { out.printf(","); write_gps(); @@ -395,14 +450,18 @@ public class AltosCSV implements AltosWriter { series.finish(); + has_radio = false; has_flight_state = false; has_basic = false; has_battery = false; has_advanced = false; + has_igniter = false; has_gps = false; has_gps_sat = false; has_companion = false; + if (series.has_series(AltosFlightSeries.rssi_name)) + has_radio = true; if (series.has_series(AltosFlightSeries.state_name)) has_flight_state = true; if (series.has_series(AltosFlightSeries.accel_name) || series.has_series(AltosFlightSeries.pressure_name)) @@ -411,6 +470,8 @@ public class AltosCSV implements AltosWriter { has_battery = true; if (series.has_series(AltosFlightSeries.accel_across_name)) has_advanced = true; + if (series.has_series(AltosFlightSeries.pyro_voltage_name)) + has_igniter = true; if (series.gps_series != null) has_gps = true; diff --git a/altoslib/AltosFlightSeries.java b/altoslib/AltosFlightSeries.java index 57f1a491..df575189 100644 --- a/altoslib/AltosFlightSeries.java +++ b/altoslib/AltosFlightSeries.java @@ -643,7 +643,7 @@ public class AltosFlightSeries extends AltosDataListener { public void set_igniter_voltage(double[] voltage) { int channels = voltage.length; if (igniter_voltage == null || igniter_voltage.length <= channels) { - AltosTimeSeries[] new_igniter_voltage = new AltosTimeSeries[channels + 1]; + AltosTimeSeries[] new_igniter_voltage = new AltosTimeSeries[channels]; int i = 0; if (igniter_voltage != null) { diff --git a/altoslib/AltosLib.java b/altoslib/AltosLib.java index d1063509..77b3fcc4 100644 --- a/altoslib/AltosLib.java +++ b/altoslib/AltosLib.java @@ -587,7 +587,11 @@ public class AltosLib { } public static String igniter_name(int i) { - return String.format("Ignitor %c", 'A' + i); + return String.format("Igniter %c", 'A' + i); + } + + public static String igniter_short_name(int i) { + return String.format("igniter_%c", 'a' + i); } public static AltosRecordSet record_set(File file) throws FileNotFoundException, IOException { -- cgit v1.2.3 From 322c1abead39cb398380dff384cd274c19dd81dd Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 2 Oct 2017 13:55:57 -0700 Subject: altosuilib: Don't drain voice when terminating display If the voice thread is wedged (as with PulseAudio and un-patched freetts 1.2.2), we'll get stuck here and the UI will freeze up. Signed-off-by: Keith Packard --- altosuilib/AltosDisplayThread.java | 3 --- 1 file changed, 3 deletions(-) diff --git a/altosuilib/AltosDisplayThread.java b/altosuilib/AltosDisplayThread.java index 3fcc02da..5e691ac4 100644 --- a/altosuilib/AltosDisplayThread.java +++ b/altosuilib/AltosDisplayThread.java @@ -159,9 +159,6 @@ public class AltosDisplayThread extends Thread { report(false); } } catch (InterruptedException ie) { - try { - voice.drain(); - } catch (InterruptedException iie) { } } } -- cgit v1.2.3 From de2b6ec1cdfd48c948bff7edbfe2540440429b1b Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 2 Oct 2017 16:55:18 -0700 Subject: altoslib,altosuilib,altosui: log_format/device_type TeleGPS selects stateless When the device being analyzed has no flight state, we want to use the 'stateless' state so that the UI can display reasonable information. This bit was lost in the recent AltosState shuffle and this patch brings it back. Signed-off-by: Keith Packard --- altoslib/AltosCalData.java | 7 +++++++ altoslib/AltosDataListener.java | 31 +++++++++++++++++++++++++--- altoslib/AltosEepromRecord.java | 2 +- altoslib/AltosEepromRecordSet.java | 2 ++ altoslib/AltosFlightSeries.java | 16 +++++++-------- altoslib/AltosState.java | 34 +++++++++++-------------------- altoslib/AltosTelemetry.java | 2 +- altoslib/AltosTelemetryConfiguration.java | 2 +- altoslib/AltosTelemetryFile.java | 2 +- altoslib/AltosTelemetryReader.java | 8 ++------ 10 files changed, 62 insertions(+), 44 deletions(-) diff --git a/altoslib/AltosCalData.java b/altoslib/AltosCalData.java index 6258c1a8..7415d5ad 100644 --- a/altoslib/AltosCalData.java +++ b/altoslib/AltosCalData.java @@ -72,6 +72,13 @@ public class AltosCalData { } } + public int log_format = AltosLib.MISSING; + + public void set_log_format(int log_format) { + if (log_format != AltosLib.MISSING) + this.log_format = log_format; + } + public int config_major = AltosLib.MISSING; public int config_minor = AltosLib.MISSING; public int flight_log_max = AltosLib.MISSING; diff --git a/altoslib/AltosDataListener.java b/altoslib/AltosDataListener.java index be6d840f..fb37fe3d 100644 --- a/altoslib/AltosDataListener.java +++ b/altoslib/AltosDataListener.java @@ -19,7 +19,6 @@ public abstract class AltosDataListener { private AltosCalData cal_data = null; public double time = AltosLib.MISSING; - public int state = AltosLib.MISSING; public double frequency = AltosLib.MISSING; public void set_tick(int tick) { @@ -42,14 +41,34 @@ public abstract class AltosDataListener { cal_data().set_serial(serial); } + public void set_device_type(int device_type) { + cal_data().set_device_type(device_type); + switch (device_type) { + case AltosLib.product_telegps: + set_state(AltosLib.ao_flight_stateless); + break; + } + } + + public void set_log_format(int log_format) { + cal_data().set_log_format(log_format); + switch (log_format) { + case AltosLib.AO_LOG_FORMAT_TELEGPS: + set_state(AltosLib.ao_flight_stateless); + break; + } + } + public double time() { return time; } public void set_state(int state) { cal_data().set_state(state); - if (state != AltosLib.MISSING) - this.state = state; + } + + public int state() { + return cal_data().state; } public void set_flight(int flight) { @@ -64,6 +83,12 @@ public abstract class AltosDataListener { public void finish() { } + public void init() { + set_state(AltosLib.ao_flight_invalid); + time = AltosLib.MISSING; + frequency = AltosLib.MISSING; + } + public abstract void set_rssi(int rssi, int status); public abstract void set_received_time(long received_time); diff --git a/altoslib/AltosEepromRecord.java b/altoslib/AltosEepromRecord.java index 094584fe..e937c3d0 100644 --- a/altoslib/AltosEepromRecord.java +++ b/altoslib/AltosEepromRecord.java @@ -83,7 +83,7 @@ public abstract class AltosEepromRecord implements Comparable /* AltosDataProvider */ public void provide_data(AltosDataListener listener, AltosCalData cal_data) { - cal_data.set_tick(tick()); + listener.set_tick(tick()); if (cmd() == AltosLib.AO_LOG_FLIGHT) cal_data.set_boost_tick(); listener.set_time(cal_data.time()); diff --git a/altoslib/AltosEepromRecordSet.java b/altoslib/AltosEepromRecordSet.java index 48e90c05..d91ae3ac 100644 --- a/altoslib/AltosEepromRecordSet.java +++ b/altoslib/AltosEepromRecordSet.java @@ -44,6 +44,8 @@ public class AltosEepromRecordSet implements AltosRecordSet { AltosCalData cal_data = cal_data(); cal_data.reset(); + listener.set_log_format(config_data().log_format); + for (AltosEepromRecord record : ordered) { record.provide_data(listener, cal_data); } diff --git a/altoslib/AltosFlightSeries.java b/altoslib/AltosFlightSeries.java index df575189..f7ea0d15 100644 --- a/altoslib/AltosFlightSeries.java +++ b/altoslib/AltosFlightSeries.java @@ -150,15 +150,13 @@ public class AltosFlightSeries extends AltosDataListener { public void set_state(int state) { - if (state == AltosLib.ao_flight_pad) - return; - - if (state_series == null) - state_series = add_series(state_name, AltosConvert.state_name); - else if (this.state == state) - return; - this.state = state; - state_series.add(time(), state); + if (state != AltosLib.ao_flight_pad && state != AltosLib.MISSING && state != AltosLib.ao_flight_stateless) { + if (state_series == null) + state_series = add_series(state_name, AltosConvert.state_name); + if (this.state() != state) + state_series.add(time(), state); + } + super.set_state(state); } public AltosTimeSeries accel_series; diff --git a/altoslib/AltosState.java b/altoslib/AltosState.java index 39ab10da..54c70094 100644 --- a/altoslib/AltosState.java +++ b/altoslib/AltosState.java @@ -480,7 +480,7 @@ public class AltosState extends AltosDataListener { class AltosPressure extends AltosValue { void set(double p, double time) { super.set(p, time); - if (state == AltosLib.ao_flight_pad) + if (state() == AltosLib.ao_flight_pad) ground_pressure.set_filtered(p, time); double a = pressure_to_altitude(p); altitude.set_computed(a, time); @@ -557,7 +557,7 @@ public class AltosState extends AltosDataListener { class AltosSpeed extends AltosCValue { boolean can_max() { - return state < AltosLib.ao_flight_fast || state == AltosLib.ao_flight_stateless; + return state() < AltosLib.ao_flight_fast || state() == AltosLib.ao_flight_stateless; } void set_accel() { @@ -615,7 +615,7 @@ public class AltosState extends AltosDataListener { class AltosAccel extends AltosCValue { boolean can_max() { - return state < AltosLib.ao_flight_fast || state == AltosLib.ao_flight_stateless; + return state() < AltosLib.ao_flight_fast || state() == AltosLib.ao_flight_stateless; } void set_measured(double a, double time) { @@ -712,11 +712,11 @@ public class AltosState extends AltosDataListener { } public void init() { + super.init(); + set = 0; received_time = System.currentTimeMillis(); - time = AltosLib.MISSING; - state = AltosLib.ao_flight_invalid; landed = false; boost = false; rssi = AltosLib.MISSING; @@ -819,9 +819,9 @@ public class AltosState extends AltosDataListener { if (gps.locked && gps.nsat >= 4) { /* Track consecutive 'good' gps reports, waiting for 10 of them */ - if (state == AltosLib.ao_flight_pad || state == AltosLib.ao_flight_stateless) { + if (state() == AltosLib.ao_flight_pad || state() == AltosLib.ao_flight_stateless) { set_npad(npad+1); - if (pad_lat != AltosLib.MISSING && (npad < 10 || state == AltosLib.ao_flight_pad)) { + if (pad_lat != AltosLib.MISSING && (npad < 10 || state() == AltosLib.ao_flight_pad)) { pad_lat = (pad_lat * 31 + gps.lat) / 32; pad_lon = (pad_lon * 31 + gps.lon) / 32; gps_ground_altitude.set_filtered(gps.alt, time); @@ -859,24 +859,14 @@ public class AltosState extends AltosDataListener { } public String state_name() { - return AltosLib.state_name(state); + return AltosLib.state_name(state()); } public void set_state(int state) { - if (state != AltosLib.ao_flight_invalid) { - this.state = state; - ascent = (AltosLib.ao_flight_boost <= state && - state <= AltosLib.ao_flight_coast); - boost = (AltosLib.ao_flight_boost == state); - } - } - - public int state() { - return state; - } - - private void re_init() { - init(); + super.set_state(state); + ascent = (AltosLib.ao_flight_boost <= state() && + state() <= AltosLib.ao_flight_coast); + boost = (AltosLib.ao_flight_boost == state()); } public int rssi() { diff --git a/altoslib/AltosTelemetry.java b/altoslib/AltosTelemetry.java index f17e1171..fe536c6a 100644 --- a/altoslib/AltosTelemetry.java +++ b/altoslib/AltosTelemetry.java @@ -51,7 +51,7 @@ public abstract class AltosTelemetry implements AltosDataProvider { public void provide_data(AltosDataListener listener) { listener.set_serial(serial()); - if (listener.state == AltosLib.ao_flight_invalid) + if (listener.state() == AltosLib.ao_flight_invalid) listener.set_state(AltosLib.ao_flight_startup); if (frequency != AltosLib.MISSING) listener.set_frequency(frequency); diff --git a/altoslib/AltosTelemetryConfiguration.java b/altoslib/AltosTelemetryConfiguration.java index ea307442..c8026a83 100644 --- a/altoslib/AltosTelemetryConfiguration.java +++ b/altoslib/AltosTelemetryConfiguration.java @@ -40,7 +40,7 @@ public class AltosTelemetryConfiguration extends AltosTelemetryStandard { AltosCalData cal_data = listener.cal_data(); - cal_data.set_device_type(device_type()); + listener.set_device_type(device_type()); cal_data.set_flight(flight()); cal_data.set_config(config_major(), config_minor(), flight_log_max()); if (device_type() == AltosLib.product_telegps) diff --git a/altoslib/AltosTelemetryFile.java b/altoslib/AltosTelemetryFile.java index 135b0284..e51455f8 100644 --- a/altoslib/AltosTelemetryFile.java +++ b/altoslib/AltosTelemetryFile.java @@ -128,7 +128,7 @@ public class AltosTelemetryFile implements AltosRecordSet { /* Try to pick up at least one pre-boost value */ if (cal_data.time() >= -2) telem.provide_data(listener); - if (listener.state == AltosLib.ao_flight_landed) + if (listener.state() == AltosLib.ao_flight_landed) break; } listener.finish(); diff --git a/altoslib/AltosTelemetryReader.java b/altoslib/AltosTelemetryReader.java index 26fe4f26..8fb61a4f 100644 --- a/altoslib/AltosTelemetryReader.java +++ b/altoslib/AltosTelemetryReader.java @@ -41,19 +41,15 @@ public class AltosTelemetryReader extends AltosFlightReader { throw new IOException("IO error"); } while (!link.get_monitor()); AltosTelemetry telem = AltosTelemetry.parse(l.line); - if (state == null) { - System.out.printf("Make state\n"); + if (state == null) state = new AltosState(cal_data()); - } telem.provide_data(state); return state; } public AltosCalData cal_data() { - if (cal_data == null) { - System.out.printf("Make cal data\n"); + if (cal_data == null) cal_data = new AltosCalData(); - } return cal_data; } -- cgit v1.2.3 From 770998be2c15dd41a63520d0c8747d7cf32ec447 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 2 Oct 2017 16:57:15 -0700 Subject: altos: Allow pyro config name to end with newline, not just space/tab A pyro config like 'Descending' has no value associated. When it is at the end of the line, allow a newline to terminate the name instead of just a space. Signed-off-by: Keith Packard --- src/kernel/ao_pyro.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/kernel/ao_pyro.c b/src/kernel/ao_pyro.c index 9543b3ef..0aed50d5 100644 --- a/src/kernel/ao_pyro.c +++ b/src/kernel/ao_pyro.c @@ -482,7 +482,7 @@ ao_pyro_set(void) break; for (c = 0; c < AO_PYRO_NAME_LEN - 1; c++) { - if (ao_cmd_is_white()) + if (ao_cmd_is_white() || ao_cmd_lex_c == '\n') break; name[c] = ao_cmd_lex_c; ao_cmd_lex(); -- cgit v1.2.3 From c6be13e8ef80e5afc836e04cbfe4cb17631540e4 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 2 Oct 2017 16:58:53 -0700 Subject: altoslib: Allow early bail-out on bad telemetry CRC Check the CRC status in the packet before creating a new telemetry object. Signed-off-by: Keith Packard --- altoslib/AltosTelemetry.java | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/altoslib/AltosTelemetry.java b/altoslib/AltosTelemetry.java index fe536c6a..a374519d 100644 --- a/altoslib/AltosTelemetry.java +++ b/altoslib/AltosTelemetry.java @@ -28,8 +28,11 @@ public abstract class AltosTelemetry implements AltosDataProvider { int[] bytes; /* All telemetry packets have these fields */ - public int rssi() { return AltosConvert.telem_to_rssi(AltosLib.int8(bytes, bytes.length - 3)); } - public int status() { return AltosLib.uint8(bytes, bytes.length - 2); } + static public int rssi(int[] bytes) { return AltosConvert.telem_to_rssi(AltosLib.int8(bytes, bytes.length - 3)); } + static public int status(int[] bytes) { return AltosLib.uint8(bytes, bytes.length - 2); } + + public int rssi() { return rssi(bytes); } + public int status() { return status(bytes); } /* All telemetry packets report these fields in some form */ public abstract int serial(); @@ -96,6 +99,9 @@ public abstract class AltosTelemetry implements AltosDataProvider { if (!cksum(bytes)) throw new ParseException(String.format("invalid line \"%s\"", hex), 0); + if ((status(bytes) & PKT_APPEND_STATUS_1_CRC_OK) == 0) + throw new AltosCRCException(rssi(bytes)); + /* length, data ..., rssi, status, checksum -- 4 bytes extra */ switch (bytes.length) { case AltosLib.ao_telemetry_standard_len + 4: -- cgit v1.2.3 From d75e8b9046295051c91696461e8d5f59c8260ccc Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 2 Oct 2017 17:02:18 -0700 Subject: altosuilib: Show raw tick values in graph and info table Not terribly useful, but did help validate firmware handling of tick wrapping, so we'll keep it. Signed-off-by: Keith Packard --- altoslib/AltosDataListener.java | 7 +++++++ altoslib/AltosFlightSeries.java | 11 +++++++++++ altosuilib/AltosGraph.java | 16 +++++++++++++++- altosuilib/AltosInfoTable.java | 2 ++ 4 files changed, 35 insertions(+), 1 deletion(-) diff --git a/altoslib/AltosDataListener.java b/altoslib/AltosDataListener.java index fb37fe3d..359d04c9 100644 --- a/altoslib/AltosDataListener.java +++ b/altoslib/AltosDataListener.java @@ -21,7 +21,14 @@ public abstract class AltosDataListener { public double time = AltosLib.MISSING; public double frequency = AltosLib.MISSING; + public int raw_tick = AltosLib.MISSING; + + public int tick() { + return raw_tick; + } + public void set_tick(int tick) { + raw_tick = tick; cal_data.set_tick(tick); set_time(cal_data.time()); } diff --git a/altoslib/AltosFlightSeries.java b/altoslib/AltosFlightSeries.java index f7ea0d15..ab7943b3 100644 --- a/altoslib/AltosFlightSeries.java +++ b/altoslib/AltosFlightSeries.java @@ -191,6 +191,17 @@ public class AltosFlightSeries extends AltosDataListener { public void set_received_time(long received_time) { } + public AltosTimeSeries tick_series; + + public static final String tick_name = "Tick"; + + public void set_tick(int tick) { + super.set_tick(tick); + if (tick_series == null) + tick_series = add_series(tick_name, null); + tick_series.add(time(), tick); + } + public AltosTimeSeries rssi_series; public static final String rssi_name = "RSSI"; diff --git a/altosuilib/AltosGraph.java b/altosuilib/AltosGraph.java index 31042abb..5df95233 100644 --- a/altosuilib/AltosGraph.java +++ b/altosuilib/AltosGraph.java @@ -80,6 +80,7 @@ public class AltosGraph extends AltosUIGraph { static final private Color orient_color = new Color(31, 31, 31); static AltosUnits dop_units = null; + static AltosUnits tick_units = null; AltosUIFlightSeries flight_series; @@ -89,7 +90,7 @@ public class AltosGraph extends AltosUIGraph { AltosUIAxis height_axis, speed_axis, accel_axis, voltage_axis, temperature_axis, nsat_axis, dbm_axis; AltosUIAxis distance_axis, pressure_axis, thrust_axis; AltosUIAxis gyro_axis, orient_axis, mag_axis; - AltosUIAxis course_axis, dop_axis; + AltosUIAxis course_axis, dop_axis, tick_axis; if (stats.serial != AltosLib.MISSING && stats.product != null && stats.flight != AltosLib.MISSING) setName(String.format("%s %d flight %d\n", stats.product, stats.serial, stats.flight)); @@ -98,6 +99,7 @@ public class AltosGraph extends AltosUIGraph { pressure_axis = newAxis("Pressure", AltosConvert.pressure, pressure_color, 0); speed_axis = newAxis("Speed", AltosConvert.speed, speed_color); thrust_axis = newAxis("Thrust", AltosConvert.force, thrust_color); + tick_axis = newAxis("Tick", tick_units, accel_color, 0); accel_axis = newAxis("Acceleration", AltosConvert.accel, accel_color); voltage_axis = newAxis("Voltage", AltosConvert.voltage, voltage_color); temperature_axis = newAxis("Temperature", AltosConvert.temperature, temperature_color, 0); @@ -129,6 +131,11 @@ public class AltosGraph extends AltosUIGraph { plot, false); + flight_series.register_axis(AltosUIFlightSeries.tick_name, + accel_color, + false, + tick_axis); + flight_series.register_axis(AltosUIFlightSeries.accel_name, accel_color, true, @@ -320,6 +327,12 @@ public class AltosGraph extends AltosUIGraph { return flight_series.series(cal_data); } + public void set_filter(double filter) { + System.out.printf("filter set to %f\n", filter); + flight_series.set_filter(filter, filter); + units_changed(false); + } + public void set_data(AltosFlightStats stats, AltosUIFlightSeries flight_series) { set_series(setup(stats, flight_series)); } @@ -330,6 +343,7 @@ public class AltosGraph extends AltosUIGraph { public AltosGraph(AltosUIEnable enable, AltosFlightStats stats, AltosUIFlightSeries flight_series) { this(enable); + this.flight_series = flight_series; set_series(setup(stats, flight_series)); } } diff --git a/altosuilib/AltosInfoTable.java b/altosuilib/AltosInfoTable.java index 9e528b1f..e759394b 100644 --- a/altosuilib/AltosInfoTable.java +++ b/altosuilib/AltosInfoTable.java @@ -142,6 +142,8 @@ public class AltosInfoTable extends JTable implements AltosFlightDisplay, Hierar info_add_row(0, "Device", "%s", AltosLib.product_name(cal_data.device_type)); else if (cal_data.product != null) info_add_row(0, "Device", "%s", cal_data.product); + if (state.tick() != AltosLib.MISSING) + info_add_row(0, "Tick", "%6d", state.tick()); if (state.altitude() != AltosLib.MISSING) info_add_row(0, "Altitude", "%6.0f m", state.altitude()); if (cal_data.ground_altitude != AltosLib.MISSING) -- cgit v1.2.3 From 98dc29a7a964f8d653b73989c6751695d168844c Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 2 Oct 2017 19:33:37 -0700 Subject: altoslib: Add user-selectable filter width for data smoothing Also switch smoothing window to Kaiser and change default accel filter width to 1 second instead of 4 seconds. Now users can play with the filter and see what it does. Signed-off-by: Keith Packard --- altoslib/AltosFlightSeries.java | 90 +++++++++++++++++++++++++---------- altoslib/AltosTimeSeries.java | 42 ++++++++++++++-- altoslib/Makefile.am | 1 + altosui/AltosGraphUI.java | 23 +++++++-- altosuilib/AltosFlightStatsTable.java | 84 ++++++++++++++++++++++++-------- altosuilib/AltosGraph.java | 8 +--- altosuilib/AltosUIEnable.java | 82 ++++++++++++++++++++++++++++++- altosuilib/AltosUIGraph.java | 4 ++ altosuilib/AltosUITimeSeries.java | 3 +- micropeak/MicroPeak.java | 23 ++++++++- telegps/TeleGPSGraphUI.java | 26 ++++++++-- 11 files changed, 320 insertions(+), 66 deletions(-) diff --git a/altoslib/AltosFlightSeries.java b/altoslib/AltosFlightSeries.java index ab7943b3..02bf64ff 100644 --- a/altoslib/AltosFlightSeries.java +++ b/altoslib/AltosFlightSeries.java @@ -21,7 +21,7 @@ public class AltosFlightSeries extends AltosDataListener { public ArrayList series = new ArrayList(); public double speed_filter_width = 4.0; - public double accel_filter_width = 4.0; + public double accel_filter_width = 1.0; public int[] indices() { int[] indices = new int[series.size()]; @@ -160,6 +160,7 @@ public class AltosFlightSeries extends AltosDataListener { } public AltosTimeSeries accel_series; + public boolean accel_computed; public static final String accel_name = "Accel"; @@ -174,17 +175,44 @@ public class AltosFlightSeries extends AltosDataListener { accel_series = add_series(accel_name, AltosConvert.accel); accel_series.add(time(), acceleration); + accel_computed = false; } - private void compute_accel() { - if (accel_series != null) - return; + private AltosTimeSeries compute_accel() { + AltosTimeSeries new_accel_series = null; if (speed_series != null) { - AltosTimeSeries temp_series = make_series(speed_name, AltosConvert.speed); - speed_series.filter(temp_series, accel_filter_width); - accel_series = add_series(accel_name, AltosConvert.accel); - temp_series.differentiate(accel_series); + AltosTimeSeries temp_series; + if (accel_filter_width > 0) { + temp_series = make_series(speed_name, AltosConvert.speed); + speed_series.filter(temp_series, accel_filter_width); + } else + temp_series = speed_series; + + new_accel_series = make_series(accel_name, AltosConvert.accel); + temp_series.differentiate(new_accel_series); + } + return new_accel_series; + } + + public void set_filter(double speed_filter, double accel_filter) { + this.speed_filter_width = speed_filter; + this.accel_filter_width = accel_filter; + + AltosTimeSeries new_speed_series = compute_speed(); + + if (new_speed_series != null) { + speed_series.erase_values(); + for (AltosTimeValue tv : new_speed_series) + speed_series.add(tv); + } + if (accel_computed) { + AltosTimeSeries new_accel_series = compute_accel(); + if (new_accel_series != null) { + accel_series.erase_values(); + for (AltosTimeValue tv : new_accel_series) + accel_series.add(tv); + } } } @@ -268,21 +296,24 @@ public class AltosFlightSeries extends AltosDataListener { public static final String speed_name = "Speed"; - private void compute_speed() { - if (speed_series != null) - return; - + private AltosTimeSeries compute_speed() { + AltosTimeSeries new_speed_series = null; AltosTimeSeries alt_speed_series = null; AltosTimeSeries accel_speed_series = null; if (altitude_series != null) { - AltosTimeSeries temp_series = make_series(altitude_name, AltosConvert.height); - altitude_series.filter(temp_series, speed_filter_width); + AltosTimeSeries temp_series; + + if (speed_filter_width > 0) { + temp_series = make_series(speed_name, AltosConvert.height); + altitude_series.filter(temp_series, speed_filter_width); + } else + temp_series = altitude_series; alt_speed_series = make_series(speed_name, AltosConvert.speed); temp_series.differentiate(alt_speed_series); } - if (accel_series != null) { + if (accel_series != null && !accel_computed) { if (orient_series != null) { vert_accel_series = add_series(vert_accel_name, AltosConvert.accel); @@ -318,26 +349,25 @@ public class AltosFlightSeries extends AltosDataListener { } } if (apogee_time == AltosLib.MISSING) { - speed_series = alt_speed_series; + new_speed_series = alt_speed_series; } else { - speed_series = make_series(speed_name, AltosConvert.speed); + new_speed_series = make_series(speed_name, AltosConvert.speed); for (AltosTimeValue d : accel_speed_series) { if (d.time <= apogee_time) - speed_series.add(d); + new_speed_series.add(d); } for (AltosTimeValue d : alt_speed_series) { if (d.time > apogee_time) - speed_series.add(d); + new_speed_series.add(d); } } } else if (alt_speed_series != null) { - speed_series = alt_speed_series; + new_speed_series = alt_speed_series; } else if (accel_speed_series != null) { - speed_series = accel_speed_series; + new_speed_series = accel_speed_series; } - if (speed_series != null) - add_series(speed_series); + return new_speed_series; } public AltosTimeSeries orient_series; @@ -690,8 +720,18 @@ public class AltosFlightSeries extends AltosDataListener { public void finish() { compute_orient(); - compute_speed(); - compute_accel(); + if (speed_series == null) { + speed_series = compute_speed(); + if (speed_series != null) + add_series(speed_series); + } + if (accel_series == null) { + accel_series = compute_accel(); + if (accel_series != null) { + add_series(accel_series); + accel_computed = true; + } + } compute_height(); } diff --git a/altoslib/AltosTimeSeries.java b/altoslib/AltosTimeSeries.java index 9f3b4d80..7208c176 100644 --- a/altoslib/AltosTimeSeries.java +++ b/altoslib/AltosTimeSeries.java @@ -20,15 +20,30 @@ public class AltosTimeSeries implements Iterable, Comparable values; + boolean data_changed; public int compareTo(AltosTimeSeries other) { return label.compareTo(other.label); } public void add(AltosTimeValue tv) { + data_changed = true; values.add(tv); } + public void erase_values() { + data_changed = true; + this.values = new ArrayList(); + } + + public void clear_changed() { + data_changed = false; + } + +// public boolean changed() { +// return data_changed; +// } + public void add(double time, double value) { add(new AltosTimeValue(time, value)); } @@ -264,14 +279,35 @@ public class AltosTimeSeries implements Iterable, Comparable 0); + return s; + } + + private static double kaiser(double n, double m, double beta) { + double alpha = m / 2; + double t = (n - alpha) / alpha; + + if (t > 1) + t = 1; + double k = i0 (beta * Math.sqrt (1 - t*t)) / i0(beta); + return k; + } + + private double filter_coeff(double dist, double width) { + return kaiser(dist + width/2.0, width, 2 * Math.PI); } public AltosTimeSeries filter(AltosTimeSeries f, double width) { + double half_width = width/2; + int half_point = values.size() / 2; for (int i = 0; i < values.size(); i++) { double center_time = values.get(i).time; double left_time = center_time - half_width; diff --git a/altoslib/Makefile.am b/altoslib/Makefile.am index 08af9496..2a1cb8e4 100644 --- a/altoslib/Makefile.am +++ b/altoslib/Makefile.am @@ -55,6 +55,7 @@ altoslib_JAVA = \ AltosEepromList.java \ AltosEepromLog.java \ AltosFile.java \ + AltosFilterListener.java \ AltosFlash.java \ AltosFlashListener.java \ AltosDataListener.java \ diff --git a/altosui/AltosGraphUI.java b/altosui/AltosGraphUI.java index 042f9277..f387ed9b 100644 --- a/altosui/AltosGraphUI.java +++ b/altosui/AltosGraphUI.java @@ -31,7 +31,7 @@ import org.jfree.chart.ChartPanel; import org.jfree.chart.JFreeChart; import org.jfree.ui.RefineryUtilities; -public class AltosGraphUI extends AltosUIFrame implements AltosFontListener, AltosUnitsListener +public class AltosGraphUI extends AltosUIFrame implements AltosFontListener, AltosUnitsListener, AltosFilterListener { JTabbedPane pane; AltosGraph graph; @@ -82,6 +82,23 @@ public class AltosGraphUI extends AltosUIFrame implements AltosFontListener, Alt enable.units_changed(imperial_units); } + AltosUIFlightSeries flight_series; + + public void filter_changed(double speed_filter, double accel_filter) { + flight_series.set_filter(speed_filter, accel_filter); + graph.filter_changed(); + stats = new AltosFlightStats(flight_series); + statsTable.filter_changed(stats); + } + + public double speed_filter() { + return flight_series.speed_filter_width; + } + + public double accel_filter() { + return flight_series.accel_filter_width; + } + AltosGraphUI(AltosRecordSet set, File file) throws InterruptedException, IOException { super(file.getName()); AltosCalData cal_data = set.cal_data(); @@ -89,9 +106,9 @@ public class AltosGraphUI extends AltosUIFrame implements AltosFontListener, Alt pane = new JTabbedPane(); - enable = new AltosUIEnable(); + flight_series = new AltosUIFlightSeries(cal_data); - AltosUIFlightSeries flight_series = new AltosUIFlightSeries(cal_data); + enable = new AltosUIEnable(this); set.capture_series(flight_series); diff --git a/altosuilib/AltosFlightStatsTable.java b/altosuilib/AltosFlightStatsTable.java index 415c0244..8f7e9bff 100644 --- a/altosuilib/AltosFlightStatsTable.java +++ b/altosuilib/AltosFlightStatsTable.java @@ -38,6 +38,11 @@ public class AltosFlightStatsTable extends JComponent implements AltosFontListen value[i].setFont(AltosUILib.value_font); } + public void set(String ... values) { + for (int j = 0; j < values.length; j++) + value[j].setText(values[j]); + } + public FlightStat(GridBagLayout layout, int y, String label_text, String ... values) { GridBagConstraints c = new GridBagConstraints(); c.insets = new Insets(AltosUILib.tab_elt_pad, AltosUILib.tab_elt_pad, AltosUILib.tab_elt_pad, AltosUILib.tab_elt_pad); @@ -87,6 +92,43 @@ public class AltosFlightStatsTable extends JComponent implements AltosFontListen return String.format("%s %4d° %9.6f'", h, deg, min); } + private FlightStat max_height_stat; + private FlightStat max_speed_stat; + private FlightStat max_accel_stat; + private FlightStat boost_accel_stat; + private FlightStat drogue_descent_stat; + private FlightStat main_descent_stat; + + public void set_values(AltosFlightStats stats) { + if (max_height_stat != null && stats.max_height != AltosLib.MISSING) { + max_height_stat.set(String.format("%6.1f m", stats.max_height), + String.format("%5.0f ft", AltosConvert.meters_to_feet(stats.max_height))); + } + if (max_speed_stat != null && stats.max_speed != AltosLib.MISSING) { + max_speed_stat.set(String.format("%6.1f m/s", stats.max_speed), + String.format("%5.0f fps", AltosConvert.mps_to_fps(stats.max_speed)), + String.format("Mach %4.1f", AltosConvert.meters_to_mach(stats.max_speed))); + } + if (max_accel_stat != null && stats.max_acceleration != AltosLib.MISSING) { + max_accel_stat.set(String.format("%6.1f m/s²", stats.max_acceleration), + String.format("%5.0f ft/s²", AltosConvert.meters_to_feet(stats.max_acceleration)), + String.format("%6.2f G", AltosConvert.meters_to_g(stats.max_acceleration))); + } + if (boost_accel_stat != null && stats.state_accel[AltosLib.ao_flight_boost] != AltosLib.MISSING) { + boost_accel_stat.set(String.format("%6.1f m/s²", stats.state_accel[AltosLib.ao_flight_boost]), + String.format("%5.0f ft/s²", AltosConvert.meters_to_feet(stats.state_accel[AltosLib.ao_flight_boost])), + String.format("%6.2f G", AltosConvert.meters_to_g(stats.state_accel[AltosLib.ao_flight_boost]))); + } + if (drogue_descent_stat != null && stats.state_speed[AltosLib.ao_flight_drogue] != AltosLib.MISSING) { + drogue_descent_stat.set(String.format("%6.1f m/s", -stats.state_speed[AltosLib.ao_flight_drogue]), + String.format("%5.0f ft/s", -AltosConvert.meters_to_feet(stats.state_speed[AltosLib.ao_flight_drogue]))); + } + if (main_descent_stat != null && stats.state_speed[AltosLib.ao_flight_main] != AltosLib.MISSING) { + main_descent_stat.set(String.format("%6.1f m/s", -stats.state_speed[AltosLib.ao_flight_main]), + String.format("%5.0f ft/s", -AltosConvert.meters_to_feet(stats.state_speed[AltosLib.ao_flight_main]))); + } + } + public void set_stats(AltosFlightStats stats) { int y = 0; if (stats.serial != AltosLib.MISSING) { @@ -113,9 +155,9 @@ public class AltosFlightStatsTable extends JComponent implements AltosFontListen String.format("%02d:%02d:%02d UTC", stats.hour, stats.minute, stats.second)); } if (stats.max_height != AltosLib.MISSING) { - new FlightStat(layout, y++, "Maximum height", - String.format("%6.1f m", stats.max_height), - String.format("%5.0f ft", AltosConvert.meters_to_feet(stats.max_height))); + max_height_stat = new FlightStat(layout, y++, "Maximum height", + String.format("%6.1f m", stats.max_height), + String.format("%5.0f ft", AltosConvert.meters_to_feet(stats.max_height))); } if (stats.max_gps_height != AltosLib.MISSING) { new FlightStat(layout, y++, "Maximum GPS height", @@ -123,21 +165,21 @@ public class AltosFlightStatsTable extends JComponent implements AltosFontListen String.format("%5.0f ft", AltosConvert.meters_to_feet(stats.max_gps_height))); } if (stats.max_speed != AltosLib.MISSING) { - new FlightStat(layout, y++, "Maximum speed", - String.format("%6.1f m/s", stats.max_speed), - String.format("%5.0f fps", AltosConvert.mps_to_fps(stats.max_speed)), - String.format("Mach %4.1f", AltosConvert.meters_to_mach(stats.max_speed))); + max_speed_stat = new FlightStat(layout, y++, "Maximum speed", + String.format("%6.1f m/s", stats.max_speed), + String.format("%5.0f fps", AltosConvert.mps_to_fps(stats.max_speed)), + String.format("Mach %4.1f", AltosConvert.meters_to_mach(stats.max_speed))); } if (stats.max_acceleration != AltosLib.MISSING) - new FlightStat(layout, y++, "Maximum boost acceleration", - String.format("%6.1f m/s²", stats.max_acceleration), - String.format("%5.0f ft/s²", AltosConvert.meters_to_feet(stats.max_acceleration)), - String.format("%6.2f G", AltosConvert.meters_to_g(stats.max_acceleration))); + max_accel_stat = new FlightStat(layout, y++, "Maximum boost acceleration", + String.format("%6.1f m/s²", stats.max_acceleration), + String.format("%5.0f ft/s²", AltosConvert.meters_to_feet(stats.max_acceleration)), + String.format("%6.2f G", AltosConvert.meters_to_g(stats.max_acceleration))); if (stats.state_accel[AltosLib.ao_flight_boost] != AltosLib.MISSING) - new FlightStat(layout, y++, "Average boost acceleration", - String.format("%6.1f m/s²", stats.state_accel[AltosLib.ao_flight_boost]), - String.format("%5.0f ft/s²", AltosConvert.meters_to_feet(stats.state_accel[AltosLib.ao_flight_boost])), - String.format("%6.2f G", AltosConvert.meters_to_g(stats.state_accel[AltosLib.ao_flight_boost]))); + boost_accel_stat = new FlightStat(layout, y++, "Average boost acceleration", + String.format("%6.1f m/s²", stats.state_accel[AltosLib.ao_flight_boost]), + String.format("%5.0f ft/s²", AltosConvert.meters_to_feet(stats.state_accel[AltosLib.ao_flight_boost])), + String.format("%6.2f G", AltosConvert.meters_to_g(stats.state_accel[AltosLib.ao_flight_boost]))); if (stats.state_time[AltosLib.ao_flight_boost] != 0 || stats.state_time[AltosLib.ao_flight_fast] != 0 || stats.state_time[AltosLib.ao_flight_coast] != 0) { double boost_time = stats.state_time[AltosLib.ao_flight_boost]; @@ -167,14 +209,14 @@ public class AltosFlightStatsTable extends JComponent implements AltosFontListen label = "Descent rate"; else label = "Drogue descent rate"; - new FlightStat(layout, y++, label, + drogue_descent_stat = new FlightStat(layout, y++, label, String.format("%6.1f m/s", -stats.state_speed[AltosLib.ao_flight_drogue]), String.format("%5.0f ft/s", -AltosConvert.meters_to_feet(stats.state_speed[AltosLib.ao_flight_drogue]))); } if (stats.state_speed[AltosLib.ao_flight_main] != AltosLib.MISSING) - new FlightStat(layout, y++, "Main descent rate", - String.format("%6.1f m/s", -stats.state_speed[AltosLib.ao_flight_main]), - String.format("%5.0f ft/s", -AltosConvert.meters_to_feet(stats.state_speed[AltosLib.ao_flight_main]))); + main_descent_stat = new FlightStat(layout, y++, "Main descent rate", + String.format("%6.1f m/s", -stats.state_speed[AltosLib.ao_flight_main]), + String.format("%5.0f ft/s", -AltosConvert.meters_to_feet(stats.state_speed[AltosLib.ao_flight_main]))); if (stats.state_time[AltosLib.ao_flight_drogue] != 0 || stats.state_time[AltosLib.ao_flight_main] != 0) { double drogue_duration = stats.state_time[AltosLib.ao_flight_drogue]; double main_duration = stats.state_time[AltosLib.ao_flight_main]; @@ -210,6 +252,10 @@ public class AltosFlightStatsTable extends JComponent implements AltosFontListen AltosUIPreferences.unregister_font_listener(this); } + public void filter_changed(AltosFlightStats stats) { + set_values(stats); + } + public AltosFlightStatsTable() { layout = new GridBagLayout(); diff --git a/altosuilib/AltosGraph.java b/altosuilib/AltosGraph.java index 5df95233..3f610285 100644 --- a/altosuilib/AltosGraph.java +++ b/altosuilib/AltosGraph.java @@ -92,7 +92,7 @@ public class AltosGraph extends AltosUIGraph { AltosUIAxis gyro_axis, orient_axis, mag_axis; AltosUIAxis course_axis, dop_axis, tick_axis; - if (stats.serial != AltosLib.MISSING && stats.product != null && stats.flight != AltosLib.MISSING) + if (stats != null && stats.serial != AltosLib.MISSING && stats.product != null && stats.flight != AltosLib.MISSING) setName(String.format("%s %d flight %d\n", stats.product, stats.serial, stats.flight)); height_axis = newAxis("Height", AltosConvert.height, height_color); @@ -327,12 +327,6 @@ public class AltosGraph extends AltosUIGraph { return flight_series.series(cal_data); } - public void set_filter(double filter) { - System.out.printf("filter set to %f\n", filter); - flight_series.set_filter(filter, filter); - units_changed(false); - } - public void set_data(AltosFlightStats stats, AltosUIFlightSeries flight_series) { set_series(setup(stats, flight_series)); } diff --git a/altosuilib/AltosUIEnable.java b/altosuilib/AltosUIEnable.java index 0c23fa8d..4bd07c52 100644 --- a/altosuilib/AltosUIEnable.java +++ b/altosuilib/AltosUIEnable.java @@ -21,6 +21,7 @@ package org.altusmetrum.altosuilib_12; import java.awt.*; import java.awt.event.*; import javax.swing.*; +import javax.swing.event.*; import java.io.*; import java.util.concurrent.*; import java.util.*; @@ -36,12 +37,17 @@ import org.jfree.chart.labels.*; import org.jfree.data.xy.*; import org.jfree.data.*; -public class AltosUIEnable extends Container { +public class AltosUIEnable extends Container implements ChangeListener { Insets il, ir; int y; int x; JCheckBox imperial_units; + JLabel speed_filter_label; + JSlider speed_filter; + JLabel accel_filter_label; + JSlider accel_filter; + AltosFilterListener filter_listener; static final int max_rows = 14; @@ -69,11 +75,15 @@ public class AltosUIEnable extends Container { } } + LinkedList elements = new LinkedList(); + public void add(String name, AltosUIGrapher grapher, boolean enabled) { GraphElement e = new GraphElement(name, grapher, enabled); GridBagConstraints c = new GridBagConstraints(); + elements.add(e); + /* Add element */ c = new GridBagConstraints(); c.gridx = x; c.gridy = y; @@ -90,6 +100,17 @@ public class AltosUIEnable extends Container { } } + public void stateChanged(ChangeEvent e) { + JSlider filter = (JSlider) e.getSource(); + if (!filter.getValueIsAdjusting()) { + double speed_value = (int) speed_filter.getValue() / 1000.0; + double accel_value = (int) accel_filter.getValue() / 1000.0; + if (filter_listener != null) { + filter_listener.filter_changed(speed_value, accel_value); + } + } + } + public void add_units() { /* Imperial units setting */ @@ -109,9 +130,66 @@ public class AltosUIEnable extends Container { c.anchor = GridBagConstraints.LINE_START; c.insets = il; add(imperial_units, c); + + speed_filter_label = new JLabel("Speed Filter(ms)"); + c = new GridBagConstraints(); + c.gridx = 0; c.gridy = 1001; + c.fill = GridBagConstraints.NONE; + c.anchor = GridBagConstraints.LINE_START; + c.insets = il; + add(speed_filter_label, c); + + speed_filter = new JSlider(JSlider.HORIZONTAL, 0, 10000, (int) (filter_listener.speed_filter() * 1000.0)); + Hashtable label_table = new Hashtable(); + for (int i = 0; i <= 10000; i += 5000) { + label_table.put(new Integer(i), new JLabel(String.format("%d", i))); + } + speed_filter.setPaintTicks(true); + speed_filter.setMajorTickSpacing(1000); + speed_filter.setMinorTickSpacing(250); + speed_filter.setLabelTable(label_table); + speed_filter.setPaintTrack(false); + speed_filter.setSnapToTicks(true); + speed_filter.setPaintLabels(true); + speed_filter.addChangeListener(this); + + c = new GridBagConstraints(); + c.gridx = 1; c.gridy = 1001; + c.gridwidth = 1000; c.gridheight = 1; + c.fill = GridBagConstraints.BOTH; + c.anchor = GridBagConstraints.LINE_START; + c.insets = il; + add(speed_filter, c); + + accel_filter_label = new JLabel("Acceleration Filter(ms)"); + c = new GridBagConstraints(); + c.gridx = 0; c.gridy = 1002; + c.fill = GridBagConstraints.NONE; + c.anchor = GridBagConstraints.LINE_START; + c.insets = il; + add(accel_filter_label, c); + + accel_filter = new JSlider(JSlider.HORIZONTAL, 0, 10000, (int) (filter_listener.accel_filter() * 1000.0)); + accel_filter.setPaintTicks(true); + accel_filter.setMajorTickSpacing(1000); + accel_filter.setMinorTickSpacing(250); + accel_filter.setLabelTable(label_table); + accel_filter.setPaintTrack(false); + accel_filter.setSnapToTicks(true); + accel_filter.setPaintLabels(true); + accel_filter.addChangeListener(this); + + c = new GridBagConstraints(); + c.gridx = 1; c.gridy = 1002; + c.gridwidth = 1000; c.gridheight = 1; + c.fill = GridBagConstraints.BOTH; + c.anchor = GridBagConstraints.LINE_START; + c.insets = il; + add(accel_filter, c); } - public AltosUIEnable() { + public AltosUIEnable(AltosFilterListener filter_listener) { + this.filter_listener = filter_listener; il = new Insets(4,4,4,4); ir = new Insets(4,4,4,4); x = 0; diff --git a/altosuilib/AltosUIGraph.java b/altosuilib/AltosUIGraph.java index 0caabcfa..efc3d493 100644 --- a/altosuilib/AltosUIGraph.java +++ b/altosuilib/AltosUIGraph.java @@ -95,6 +95,10 @@ public class AltosUIGraph implements AltosUnitsListener { s.set_units(); } + public void filter_changed() { + units_changed(false); + } + public void setName (String name) { chart.setTitle(name); } diff --git a/altosuilib/AltosUITimeSeries.java b/altosuilib/AltosUITimeSeries.java index 08f95ca7..71166064 100644 --- a/altosuilib/AltosUITimeSeries.java +++ b/altosuilib/AltosUITimeSeries.java @@ -89,7 +89,7 @@ public class AltosUITimeSeries extends AltosTimeSeries implements AltosUIGrapher public void fireSeriesChanged() { } - void set_data() { + public void set_data() { if (marker) { if (markers != null) { for (ValueMarker marker : markers) @@ -124,6 +124,7 @@ public class AltosUITimeSeries extends AltosTimeSeries implements AltosUIGrapher } xy_series.setNotify(true); } + clear_changed(); } public void set_units() { diff --git a/micropeak/MicroPeak.java b/micropeak/MicroPeak.java index 749d0f64..c6a2a3c9 100644 --- a/micropeak/MicroPeak.java +++ b/micropeak/MicroPeak.java @@ -27,7 +27,7 @@ import java.util.*; import org.altusmetrum.altoslib_12.*; import org.altusmetrum.altosuilib_12.*; -public class MicroPeak extends MicroFrame implements ActionListener, ItemListener { +public class MicroPeak extends MicroFrame implements ActionListener, ItemListener, AltosFilterListener { File filename; AltosGraph graph; @@ -206,6 +206,25 @@ public class MicroPeak extends MicroFrame implements ActionListener, ItemListene Preferences(); } + public void filter_changed(double speed_filter, double accel_filter) { + data.flight_series.set_filter(speed_filter, accel_filter); + graph.filter_changed(); + data.flight_stats = new AltosFlightStats(data.flight_series); + statsTable.filter_changed(data.flight_stats); + } + + public double speed_filter() { + if (data != null && data.flight_series != null) + return data.flight_series.speed_filter_width; + return 4.0; + } + + public double accel_filter() { + if (data != null && data.flight_series != null) + return data.flight_series.accel_filter_width; + return 1.0; + } + public MicroPeak() { ++number_of_windows; @@ -267,7 +286,7 @@ public class MicroPeak extends MicroFrame implements ActionListener, ItemListene } }); - enable = new AltosUIEnable(); + enable = new AltosUIEnable(this); graph = new AltosGraph(enable); statsTable = new AltosFlightStatsTable(); diff --git a/telegps/TeleGPSGraphUI.java b/telegps/TeleGPSGraphUI.java index 9d8c6bf5..c68f2bad 100644 --- a/telegps/TeleGPSGraphUI.java +++ b/telegps/TeleGPSGraphUI.java @@ -34,7 +34,7 @@ import org.jfree.chart.ChartPanel; import org.jfree.chart.JFreeChart; import org.jfree.ui.RefineryUtilities; -public class TeleGPSGraphUI extends AltosUIFrame implements AltosFontListener, AltosUnitsListener +public class TeleGPSGraphUI extends AltosUIFrame implements AltosFontListener, AltosUnitsListener, AltosFilterListener { JTabbedPane pane; AltosGraph graph; @@ -92,20 +92,38 @@ public class TeleGPSGraphUI extends AltosUIFrame implements AltosFontListener, A enable.units_changed(imperial_units); } + AltosUIFlightSeries flight_series; + + public void filter_changed(double speed_filter, double accel_filter) { + flight_series.set_filter(speed_filter, accel_filter); + graph.filter_changed(); + stats = new AltosFlightStats(flight_series); + statsTable.filter_changed(stats); + } + + public double speed_filter() { + return flight_series.speed_filter_width; + } + + public double accel_filter() { + return flight_series.accel_filter_width; + } + TeleGPSGraphUI(AltosRecordSet set, File file) throws InterruptedException, IOException { super(file.getName()); AltosCalData cal_data = set.cal_data(); - AltosUIFlightSeries flight_series = new AltosUIFlightSeries(cal_data); + flight_series = new AltosUIFlightSeries(cal_data); set.capture_series(flight_series); flight_series.finish(); pane = new JTabbedPane(); - enable = new AltosUIEnable(); + graph = new AltosGraph(enable, stats, flight_series); + stats = new AltosFlightStats(flight_series); - graph = new AltosGraph(enable, stats, flight_series); + enable = new AltosUIEnable(this); statsTable = new AltosFlightStatsTable(stats); -- cgit v1.2.3 From 730ee7bf91f607ece42c010a10c53d0013492b96 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Wed, 4 Oct 2017 13:42:16 -0700 Subject: altoslib: Adapt KML output to make TRA record people happier Provide two paths, one using GPS data the other baro. Replace separate path segments for each state with markers so that the path is a single unit, able to be displayed in the elevation profile widget. Signed-off-by: Keith Packard --- altoslib/AltosFlightStats.java | 7 + altoslib/AltosKML.java | 289 ++++++++++++++++++++++++++++++----------- 2 files changed, 222 insertions(+), 74 deletions(-) diff --git a/altoslib/AltosFlightStats.java b/altoslib/AltosFlightStats.java index ea1a9675..6bb83581 100644 --- a/altoslib/AltosFlightStats.java +++ b/altoslib/AltosFlightStats.java @@ -27,6 +27,8 @@ public class AltosFlightStats { public double max_acceleration; public double[] state_speed = new double[AltosLib.ao_flight_invalid + 1]; public double[] state_enter_speed = new double[AltosLib.ao_flight_invalid + 1]; + public double[] state_enter_height = new double[AltosLib.ao_flight_invalid + 1]; + public double[] state_enter_gps_height = new double[AltosLib.ao_flight_invalid + 1]; public double[] state_accel = new double[AltosLib.ao_flight_invalid + 1]; public double[] state_time = new double[AltosLib.ao_flight_invalid + 1]; public String product; @@ -134,6 +136,11 @@ public class AltosFlightStats { if (0 <= state && state <= AltosLib.ao_flight_invalid && delta_time > 0) { if (state_enter_speed[state] == AltosLib.MISSING) state_enter_speed[state] = series.speed_series.value(start_time); + if (state_enter_height[state] == AltosLib.MISSING) + state_enter_height[state] = series.height_series.value(start_time); + if (state_enter_gps_height[state] == AltosLib.MISSING) + if (series.gps_height != null) + state_enter_gps_height[state] = series.gps_height.value(start_time); speeds[state].value += series.speed_series.average(start_time, end_time) * delta_time; speeds[state].time += delta_time; accels[state].value += series.accel_series.average(start_time, end_time) * delta_time; diff --git a/altoslib/AltosKML.java b/altoslib/AltosKML.java index 587b845b..4738ac91 100644 --- a/altoslib/AltosKML.java +++ b/altoslib/AltosKML.java @@ -38,16 +38,18 @@ public class AltosKML implements AltosWriter { int flight_state = -1; AltosGPS prev = null; double gps_start_altitude = AltosLib.MISSING; + AltosFlightSeries series; AltosFlightStats stats; + AltosCalData cal_data; static final String[] kml_state_colors = { "FF000000", // startup "FF000000", // idle "FF000000", // pad "FF0000FF", // boost + "FF8040FF", // coast "FF4080FF", // fast - "FF00FFFF", // coast - "FFFF0000", // drogue + "FF00FFFF", // drogue "FF00FF00", // main "FF000000", // landed "FFFFFFFF", // invalid @@ -60,85 +62,169 @@ public class AltosKML implements AltosWriter { return kml_state_colors[state]; } + static final String[] kml_style_colors = { + "FF0000FF", // baro + "FFFF0000", // gps + }; + + static String style_color(int style) { + if (style < 0 || kml_style_colors.length <= style) + return kml_style_colors[0]; + return kml_style_colors[style]; + } + static final String kml_header_start = "\n" + "\n" + "\n" + " AO Flight#%d S/N: %03d\n" + - " \n"; + " \n"; + static final String kml_header_end = - " \n" + - " 0\n"; - - static final String kml_style_start = - " \n"; - - static final String kml_placemark_start = - " \n" + - " %s\n" + - " #ao-flightstate-%s\n" + - " \n" + - " 1\n" + - " absolute\n" + - " \n"; + " \n" + + " 1\n"; + + static final String kml_folder_start = + " \n" + + " %s\n"; + + static final String kml_path_style_start = + " \n"; + + static final String kml_point_style_start = + " \n"; + + static final String kml_path_start = + " \n" + + " %s\n" + + " #ao-style-%s\n" + + " \n" + + " 1\n" + + " absolute\n" + + " \n"; static final String kml_coord_fmt = - " %.7f,%.7f,%.7f \n"; + " %.7f,%.7f,%.7f \n"; - static final String kml_placemark_end = - " \n" + - " \n" + - " \n"; + static final String kml_path_end = + " \n" + + " \n" + + " \n"; + + static final String kml_point_start = + " \n" + + " %s\n" + + " #ao-style-%s\n" + + " \n" + + " 1\n" + + " absolute\n" + + " \n"; + + static final String kml_point_end = + " \n" + + " \n" + + " \n"; + + static final String kml_folder_end = + " \n"; static final String kml_footer = "\n" + "\n"; - void start (AltosCalData cal_data) { + void start () { AltosGPS gps = cal_data.gps_pad; gps_start_altitude = cal_data.gps_pad_altitude; out.printf(kml_header_start, cal_data.flight, cal_data.serial); - out.printf("Date: %04d-%02d-%02d\n", + out.printf("Product: %s\n", stats.product); + out.printf("Firmware: %s\n", stats.firmware_version); + out.printf("Date: %04d-%02d-%02d\n", gps.year, gps.month, gps.day); - out.printf("Time: %2d:%02d:%02d\n", + out.printf("Time: %2d:%02d:%02d\n", gps.hour, gps.minute, gps.second); + if (stats.max_height != AltosLib.MISSING) + out.printf("Max baro height: %s\n", AltosConvert.height.show(6, stats.max_height)); + if (stats.max_gps_height != AltosLib.MISSING) + out.printf("Max GPS Height: %s\n", AltosConvert.height.show(6, stats.max_gps_height)); + if (stats.max_speed != AltosLib.MISSING) + out.printf("Max speed: %s\n", AltosConvert.speed.show(6, stats.max_speed)); + if (stats.max_acceleration != AltosLib.MISSING) + out.printf("Max accel: %s\n", AltosConvert.accel.show(6, stats.max_acceleration)); out.printf("%s", kml_header_end); } - boolean started = false; + void folder_start(String folder_name) { + out.printf(kml_folder_start, folder_name); + } - void state_start(int state) { - String state_name = AltosLib.state_name(state); - String state_color = state_color(state); - out.printf(kml_style_start, state_name, state_color); - out.printf("State: %s\n", state_name); - out.printf("Time: %6.2f s\n", stats.state_time[state]); - out.printf("Average speed: %s\n", AltosConvert.speed.show(6, stats.state_speed[state])); - out.printf("Average accel: %s\n", AltosConvert.accel.show(6, stats.state_accel[state])); - out.printf("%s", kml_style_end); - out.printf(kml_placemark_start, state_name, state_name); + void folder_end() { + out.printf(kml_folder_end); } - void state_end() { - out.printf("%s", kml_placemark_end); + void path_style_start(String style, String color) { + out.printf(kml_path_style_start, style, color); } - void coord(double time, AltosGPS gps, int state, double height) { - double altitude; + void path_style_end() { + out.printf(kml_path_style_end); + } + + void point_style_start(String style, String color) { + out.printf(kml_point_style_start, style, color, color); + } + + void point_style_end() { + out.printf(kml_point_style_end); + } - if (height != AltosLib.MISSING) - altitude = height + gps_start_altitude; - else - altitude = gps.alt; + void path_start(String name, String style) { + out.printf(kml_path_start, name, style); + } + + void path_end() { + out.printf(kml_path_end); + } + + void point_start(String name, String style) { + out.printf(kml_point_start, name, style); + } + + void point_end() { + out.printf(kml_point_end); + } + + boolean started = false; + + private double baro_altitude(AltosFlightSeries series, double time) { + double height = series.value(AltosFlightSeries.height_name, time); + + if (height == AltosLib.MISSING) + return AltosLib.MISSING; + if (cal_data.gps_pad_altitude == AltosLib.MISSING) + return AltosLib.MISSING; + + return height + cal_data.gps_pad_altitude; + } + + void coord(double time, AltosGPS gps, double altitude) { out.printf(kml_coord_fmt, gps.lon, gps.lat, altitude, (double) gps.alt, @@ -150,48 +236,103 @@ public class AltosKML implements AltosWriter { } public void close() { - if (prev != null) { - state_end(); - end(); - prev = null; - } if (out != null) { out.close(); out = null; } } - public void write(AltosGPSTimeValue gtv, AltosCalData cal_data, int state, double height) { - AltosGPS gps = gtv.gps; + public void write(AltosGPS gps, double alt) + { if (gps.lat == AltosLib.MISSING) return; if (gps.lon == AltosLib.MISSING) return; - if (state != flight_state) { - flight_state = state; - if (prev != null) { - coord(gtv.time, gps, state, height); - state_end(); - } - state_start(state); + if (alt == AltosLib.MISSING) { + alt = cal_data.gps_pad_altitude; + if (alt == AltosLib.MISSING) + return; } - coord(0, gps, state, height); + coord(0, gps, alt); prev = gps; } - private int state(AltosFlightSeries series, double time) { - return (int) series.value_before(AltosFlightSeries.state_name, time); - } + public void write_point(AltosTimeValue tv, boolean is_gps) { + int state = (int) tv.value; + String style_prefix = is_gps ? "gps-" : "baro-"; + String state_name = AltosLib.state_name(state); + String state_label = AltosLib.state_name_capital(state); + String style_name = style_prefix + state_name; + String folder_name = is_gps ? "GPS" : "Baro"; + String full_name = state_label + " (" + folder_name + ")"; + AltosGPS gps = series.gps_before(tv.time); + double altitude = is_gps ? gps.alt : baro_altitude(series, tv.time); - private double height(AltosFlightSeries series, double time) { - return series.value(AltosFlightSeries.height_name, time); + point_style_start(style_name, state_color(state)); + out.printf("%s\n", full_name); + switch (state) { + case AltosLib.ao_flight_boost: + out.printf("Max accel %s\n", AltosConvert.accel.show(6, stats.max_acceleration)); + out.printf("Max speed %s\n", AltosConvert.speed.show(6, stats.max_speed)); + break; + case AltosLib.ao_flight_coast: + case AltosLib.ao_flight_fast: + out.printf("Entry speed %s\n", AltosConvert.speed.show(6, stats.state_enter_speed[state])); + out.printf("Entry height %s\n", AltosConvert.height.show(6, altitude - cal_data.gps_pad_altitude)); + break; + case AltosLib.ao_flight_drogue: + out.printf("Max height %s\n", AltosConvert.height.show(6, is_gps ? stats.max_gps_height : stats.max_height)); + out.printf("Average descent rate %s\n", AltosConvert.speed.show(6, -stats.state_speed[state])); + break; + case AltosLib.ao_flight_main: + out.printf("Entry speed %s\n", AltosConvert.speed.show(6, -stats.state_enter_speed[state])); + out.printf("Entry height %s\n", AltosConvert.height.show(6, altitude - cal_data.gps_pad_altitude)); + out.printf("Average descent rate %s\n", AltosConvert.speed.show(6, -stats.state_speed[state])); + break; + case AltosLib.ao_flight_landed: + out.printf("Landing speed %s\n", AltosConvert.speed.show(6, -stats.state_enter_speed[state])); + break; + } + point_style_end(); + point_start(full_name, style_name); + gps = series.gps_before(tv.time); + write(gps, altitude); + point_end(); } public void write(AltosFlightSeries series) { + this.series = series; + series.finish(); stats = new AltosFlightStats(series); - start(series.cal_data()); + cal_data = series.cal_data(); + start(); + folder_start("Barometric Altitude"); + path_style_start("baro", style_color(0)); + out.printf("Barometric Altitude\n"); + out.printf("Max height: %s\n", AltosConvert.height.show(6, stats.max_height)); + path_style_end(); + path_start("Barometric Altitude", "baro"); for (AltosGPSTimeValue gtv : series.gps_series) - write(gtv, series.cal_data(), state(series, gtv.time), height(series, gtv.time)); + write(gtv.gps, baro_altitude(series, gtv.time)); + path_end(); + for (AltosTimeValue tv : series.state_series) { + write_point(tv, false); + } + folder_end(); + folder_start("GPS Altitude"); + path_style_start("gps", style_color(1)); + out.printf("GPS Altitude"); + out.printf("Max height: %s\n", AltosConvert.height.show(6, stats.max_gps_height)); + path_style_end(); + path_start("GPS Altitude", "gps"); + for (AltosGPSTimeValue gtv : series.gps_series) + write(gtv.gps, gtv.gps.alt); + path_end(); + for (AltosTimeValue tv : series.state_series) { + write_point(tv, true); + } + folder_end(); + end(); } public AltosKML(File in_name) throws FileNotFoundException { -- cgit v1.2.3 From 2f779d318753b73463f7166977453ab5533e5921 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Wed, 4 Oct 2017 13:43:45 -0700 Subject: altosuilib: Add 'show marker' button to graphs Provides a marker at each actual data point which can be useful for sparse data sets like telemetry with poor reception. Signed-off-by: Keith Packard --- altosuilib/AltosShapeListener.java | 19 +++++++++++++++++++ altosuilib/AltosUIEnable.java | 37 +++++++++++++++++++++++++++++++++---- altosuilib/AltosUIGraph.java | 9 ++++++++- altosuilib/AltosUITimeSeries.java | 6 +++++- altosuilib/Makefile.am | 1 + 5 files changed, 66 insertions(+), 6 deletions(-) create mode 100644 altosuilib/AltosShapeListener.java diff --git a/altosuilib/AltosShapeListener.java b/altosuilib/AltosShapeListener.java new file mode 100644 index 00000000..082b6135 --- /dev/null +++ b/altosuilib/AltosShapeListener.java @@ -0,0 +1,19 @@ +/* + * Copyright © 2017 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +package org.altusmetrum.altosuilib_12; + +public interface AltosShapeListener { + void set_shapes_visible(boolean visible); +} diff --git a/altosuilib/AltosUIEnable.java b/altosuilib/AltosUIEnable.java index 4bd07c52..ed1e6c53 100644 --- a/altosuilib/AltosUIEnable.java +++ b/altosuilib/AltosUIEnable.java @@ -43,11 +43,13 @@ public class AltosUIEnable extends Container implements ChangeListener { int y; int x; JCheckBox imperial_units; + JCheckBox show_shapes; JLabel speed_filter_label; JSlider speed_filter; JLabel accel_filter_label; JSlider accel_filter; AltosFilterListener filter_listener; + AltosShapeListener shape_listener; static final int max_rows = 14; @@ -111,6 +113,16 @@ public class AltosUIEnable extends Container implements ChangeListener { } } + public void set_shapes_visible(boolean visible) { + System.out.printf("set shapes %b\n", visible); + if (shape_listener != null) + shape_listener.set_shapes_visible(visible); + } + + public void register_shape_listener(AltosShapeListener shape_listener) { + this.shape_listener = shape_listener; + } + public void add_units() { /* Imperial units setting */ @@ -131,12 +143,29 @@ public class AltosUIEnable extends Container implements ChangeListener { c.insets = il; add(imperial_units, c); - speed_filter_label = new JLabel("Speed Filter(ms)"); + show_shapes = new JCheckBox("Show Markers", false); + show_shapes.addActionListener(new ActionListener() { + public void actionPerformed(ActionEvent e) { + JCheckBox item = (JCheckBox) e.getSource(); + boolean enabled = item.isSelected(); + set_shapes_visible(enabled); + } + }); + show_shapes.setToolTipText("Show marker Use Imperial units instead of metric"); c = new GridBagConstraints(); c.gridx = 0; c.gridy = 1001; c.fill = GridBagConstraints.NONE; c.anchor = GridBagConstraints.LINE_START; c.insets = il; + add(show_shapes, c); + + + speed_filter_label = new JLabel("Speed Filter(ms)"); + c = new GridBagConstraints(); + c.gridx = 0; c.gridy = 1002; + c.fill = GridBagConstraints.NONE; + c.anchor = GridBagConstraints.LINE_START; + c.insets = il; add(speed_filter_label, c); speed_filter = new JSlider(JSlider.HORIZONTAL, 0, 10000, (int) (filter_listener.speed_filter() * 1000.0)); @@ -154,7 +183,7 @@ public class AltosUIEnable extends Container implements ChangeListener { speed_filter.addChangeListener(this); c = new GridBagConstraints(); - c.gridx = 1; c.gridy = 1001; + c.gridx = 1; c.gridy = 1002; c.gridwidth = 1000; c.gridheight = 1; c.fill = GridBagConstraints.BOTH; c.anchor = GridBagConstraints.LINE_START; @@ -163,7 +192,7 @@ public class AltosUIEnable extends Container implements ChangeListener { accel_filter_label = new JLabel("Acceleration Filter(ms)"); c = new GridBagConstraints(); - c.gridx = 0; c.gridy = 1002; + c.gridx = 0; c.gridy = 1003; c.fill = GridBagConstraints.NONE; c.anchor = GridBagConstraints.LINE_START; c.insets = il; @@ -180,7 +209,7 @@ public class AltosUIEnable extends Container implements ChangeListener { accel_filter.addChangeListener(this); c = new GridBagConstraints(); - c.gridx = 1; c.gridy = 1002; + c.gridx = 1; c.gridy = 1003; c.gridwidth = 1000; c.gridheight = 1; c.fill = GridBagConstraints.BOTH; c.anchor = GridBagConstraints.LINE_START; diff --git a/altosuilib/AltosUIGraph.java b/altosuilib/AltosUIGraph.java index efc3d493..6328d40a 100644 --- a/altosuilib/AltosUIGraph.java +++ b/altosuilib/AltosUIGraph.java @@ -36,7 +36,7 @@ import org.jfree.chart.labels.*; import org.jfree.data.xy.*; import org.jfree.data.*; -public class AltosUIGraph implements AltosUnitsListener { +public class AltosUIGraph implements AltosUnitsListener, AltosShapeListener { XYPlot plot; JFreeChart chart; @@ -99,6 +99,11 @@ public class AltosUIGraph implements AltosUnitsListener { units_changed(false); } + public void set_shapes_visible(boolean visible) { + for (AltosUITimeSeries s : series) + s.set_shapes_visible(visible); + } + public void setName (String name) { chart.setTitle(name); } @@ -127,6 +132,8 @@ public class AltosUIGraph implements AltosUnitsListener { this.series = null; this.axis_index = 0; + enable.register_shape_listener(this); + axes_added = new Hashtable(); xAxis = new NumberAxis("Time (s)"); diff --git a/altosuilib/AltosUITimeSeries.java b/altosuilib/AltosUITimeSeries.java index 71166064..b98c8376 100644 --- a/altosuilib/AltosUITimeSeries.java +++ b/altosuilib/AltosUITimeSeries.java @@ -66,7 +66,7 @@ public class AltosUITimeSeries extends AltosTimeSeries implements AltosUIGrapher AltosUIAxis axis; boolean marker; boolean marker_top; - XYItemRenderer renderer; + XYLineAndShapeRenderer renderer; XYPlot plot; AltosXYSeries xy_series; ArrayList markers; @@ -188,6 +188,10 @@ public class AltosUITimeSeries extends AltosTimeSeries implements AltosUIGrapher this.marker_top = marker_top; } + public void set_shapes_visible(boolean shapes_visible) { + renderer.setSeriesShapesVisible(0, shapes_visible); + } + public AltosUITimeSeries(String label, AltosUnits units) { super(label, units); } diff --git a/altosuilib/Makefile.am b/altosuilib/Makefile.am index ce86d21e..0f606225 100644 --- a/altosuilib/Makefile.am +++ b/altosuilib/Makefile.am @@ -31,6 +31,7 @@ altosuilib_JAVA = \ AltosUIFlightSeries.java \ AltosUIGraph.java \ AltosGraph.java \ + AltosShapeListener.java \ AltosUSBDevice.java \ AltosVoice.java \ AltosDisplayThread.java \ -- cgit v1.2.3 From 7e971b45f22aa77421061ff2925e0458835014b2 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Wed, 4 Oct 2017 13:44:31 -0700 Subject: altoslib: Missing file for filter additions. Signed-off-by: Keith Packard --- altoslib/AltosFilterListener.java | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) create mode 100644 altoslib/AltosFilterListener.java diff --git a/altoslib/AltosFilterListener.java b/altoslib/AltosFilterListener.java new file mode 100644 index 00000000..fe91100a --- /dev/null +++ b/altoslib/AltosFilterListener.java @@ -0,0 +1,22 @@ +/* + * Copyright © 2017 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +package org.altusmetrum.altoslib_12; + +public interface AltosFilterListener { + void filter_changed(double speed_filter, double accel_filter); + + double speed_filter(); + double accel_filter(); +} -- cgit v1.2.3 From 5d82209122e3b797a7345f6ad5b6710832fcdd4a Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 5 Oct 2017 16:46:08 -0700 Subject: Set version to 1.8.2.1 Testing KML export changes at TRA Signed-off-by: Keith Packard --- configure.ac | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/configure.ac b/configure.ac index 2bf6c7e3..6b922183 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.2) +AC_INIT([altos], 1.8.2.1) ANDROID_VERSION=16 AC_CONFIG_SRCDIR([src/kernel/ao.h]) AM_INIT_AUTOMAKE([foreign dist-bzip2]) AM_MAINTAINER_MODE -RELEASE_DATE=2017-09-18 +RELEASE_DATE=2017-10-05 AC_SUBST(RELEASE_DATE) VERSION_DASH=`echo $VERSION | sed 's/\./-/g'` -- cgit v1.2.3 From c8dbfff65dd61e42d0a02158dcb520e7710ef87e Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 8 Oct 2017 18:50:59 -0700 Subject: altos: Stop storing pyro fired status in config block We already have the fired status saved in the ao_pyro_fired variable, so just use that to detect whether a channel has already been fired. Fixes possible cases where the pyro config data gets written back to eeprom with the fired bit set, which then inhibits the channel during flight. Signed-off-by: Keith Packard --- src/kernel/ao_pyro.c | 15 +++++++-------- src/kernel/ao_pyro.h | 2 +- 2 files changed, 8 insertions(+), 9 deletions(-) diff --git a/src/kernel/ao_pyro.c b/src/kernel/ao_pyro.c index 0aed50d5..e5c30eec 100644 --- a/src/kernel/ao_pyro.c +++ b/src/kernel/ao_pyro.c @@ -76,7 +76,7 @@ uint16_t ao_pyro_fired; #if PYRO_DBG int pyro_dbg; -#define DBG(...) do { if (pyro_dbg) printf("\t%d: ", (int) (pyro - ao_config.pyro)); printf(__VA_ARGS__); } while (0) +#define DBG(...) do { if (pyro_dbg) { printf("\t%d: ", (int) (pyro - ao_config.pyro)); printf(__VA_ARGS__); } } while (0) #else #define DBG(...) #endif @@ -239,11 +239,8 @@ ao_pyro_pins_fire(uint16_t fire) } ao_delay(ao_config.pyro_time); for (p = 0; p < AO_PYRO_NUM; p++) { - if (fire & (1 << p)) { + if (fire & (1 << p)) ao_pyro_pin_set(p, 0); - ao_config.pyro[p].fired = 1; - ao_pyro_fired |= (1 << p); - } } ao_delay(AO_MS_TO_TICKS(50)); } @@ -261,7 +258,7 @@ ao_pyro_check(void) /* Ignore igniters which have already fired */ - if (pyro->fired) + if (ao_pyro_fired & (1 << p)) continue; /* Ignore disabled igniters @@ -296,7 +293,7 @@ ao_pyro_check(void) * by setting the fired bit */ if (!ao_pyro_ready(pyro)) { - pyro->fired = 1; + ao_pyro_fired |= (1 << p); continue; } @@ -307,8 +304,10 @@ ao_pyro_check(void) fire |= (1 << p); } - if (fire) + if (fire) { + ao_pyro_fired |= fire; ao_pyro_pins_fire(fire); + } return any_waiting; } diff --git a/src/kernel/ao_pyro.h b/src/kernel/ao_pyro.h index a730ef19..3ab5af3b 100644 --- a/src/kernel/ao_pyro.h +++ b/src/kernel/ao_pyro.h @@ -63,7 +63,7 @@ struct ao_pyro { uint8_t state_less, state_greater_or_equal; int16_t motor; uint16_t delay_done; - uint8_t fired; + uint8_t _unused; /* was 'fired' */ }; #define AO_PYRO_8_BIT_VALUE (ao_pyro_state_less|ao_pyro_state_greater_or_equal) -- cgit v1.2.3 From 9d7bb706918fd7d6db77eab21931b4fc74cb9105 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 12 Oct 2017 00:14:30 -0700 Subject: altos: Add MPU9250 driver (accel/gyro only for now) This is almost an exact copy of the MPU6000 driver, just a few minor register changes. Signed-off-by: Keith Packard --- src/drivers/ao_mpu9250.c | 415 +++++++++++++++++++++++++++++++++++++++++++++++ src/drivers/ao_mpu9250.h | 220 +++++++++++++++++++++++++ 2 files changed, 635 insertions(+) create mode 100644 src/drivers/ao_mpu9250.c create mode 100644 src/drivers/ao_mpu9250.h diff --git a/src/drivers/ao_mpu9250.c b/src/drivers/ao_mpu9250.c new file mode 100644 index 00000000..b79f27ca --- /dev/null +++ b/src/drivers/ao_mpu9250.c @@ -0,0 +1,415 @@ +/* + * Copyright © 2012 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * 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 +#include +#include + +#if HAS_MPU9250 + +static uint8_t ao_mpu9250_configured; + +extern uint8_t ao_sensor_errors; + +#ifndef AO_MPU9250_I2C_INDEX +#define AO_MPU9250_SPI 1 +#else +#define AO_MPU9250_SPI 0 +#endif + +#if AO_MPU9250_SPI + +#define ao_mpu9250_spi_get() ao_spi_get(AO_MPU9250_SPI_BUS, AO_SPI_SPEED_1MHz) +#define ao_mpu9250_spi_put() ao_spi_put(AO_MPU9250_SPI_BUS) + +#define ao_mpu9250_spi_start() ao_spi_set_cs(AO_MPU9250_SPI_CS_PORT, \ + (1 << AO_MPU9250_SPI_CS_PIN)) + +#define ao_mpu9250_spi_end() ao_spi_clr_cs(AO_MPU9250_SPI_CS_PORT, \ + (1 << AO_MPU9250_SPI_CS_PIN)) + +#endif + + +static void +_ao_mpu9250_reg_write(uint8_t addr, uint8_t value) +{ + uint8_t d[2] = { addr, value }; +#if AO_MPU9250_SPI + ao_mpu9250_spi_start(); + ao_spi_send(d, 2, AO_MPU9250_SPI_BUS); + ao_mpu9250_spi_end(); +#else + ao_i2c_get(AO_MPU9250_I2C_INDEX); + ao_i2c_start(AO_MPU9250_I2C_INDEX, MPU9250_ADDR_WRITE); + ao_i2c_send(d, 2, AO_MPU9250_I2C_INDEX, TRUE); + ao_i2c_put(AO_MPU9250_I2C_INDEX); +#endif +} + +static void +_ao_mpu9250_read(uint8_t addr, void *data, uint8_t len) +{ +#if AO_MPU9250_SPI + addr |= 0x80; + ao_mpu9250_spi_start(); + ao_spi_send(&addr, 1, AO_MPU9250_SPI_BUS); + ao_spi_recv(data, len, AO_MPU9250_SPI_BUS); + ao_mpu9250_spi_end(); +#else + ao_i2c_get(AO_MPU9250_I2C_INDEX); + ao_i2c_start(AO_MPU9250_I2C_INDEX, MPU9250_ADDR_WRITE); + ao_i2c_send(&addr, 1, AO_MPU9250_I2C_INDEX, FALSE); + ao_i2c_start(AO_MPU9250_I2C_INDEX, MPU9250_ADDR_READ); + ao_i2c_recv(data, len, AO_MPU9250_I2C_INDEX, TRUE); + ao_i2c_put(AO_MPU9250_I2C_INDEX); +#endif +} + +static uint8_t +_ao_mpu9250_reg_read(uint8_t addr) +{ + uint8_t value; +#if AO_MPU9250_SPI + addr |= 0x80; + ao_mpu9250_spi_start(); + ao_spi_send(&addr, 1, AO_MPU9250_SPI_BUS); + ao_spi_recv(&value, 1, AO_MPU9250_SPI_BUS); + ao_mpu9250_spi_end(); +#else + ao_i2c_get(AO_MPU9250_I2C_INDEX); + ao_i2c_start(AO_MPU9250_I2C_INDEX, MPU9250_ADDR_WRITE); + ao_i2c_send(&addr, 1, AO_MPU9250_I2C_INDEX, FALSE); + ao_i2c_start(AO_MPU9250_I2C_INDEX, MPU9250_ADDR_READ); + ao_i2c_recv(&value, 1, AO_MPU9250_I2C_INDEX, TRUE); + ao_i2c_put(AO_MPU9250_I2C_INDEX); +#endif + return value; +} + +static void +_ao_mpu9250_sample(struct ao_mpu9250_sample *sample) +{ + uint16_t *d = (uint16_t *) sample; + int i = sizeof (*sample) / 2; + + _ao_mpu9250_read(MPU9250_ACCEL_XOUT_H, sample, sizeof (*sample)); +#if __BYTE_ORDER == __LITTLE_ENDIAN + /* byte swap */ + while (i--) { + uint16_t t = *d; + *d++ = (t >> 8) | (t << 8); + } +#endif +} + +#define G 981 /* in cm/s² */ + +#if 0 +static int16_t /* cm/s² */ +ao_mpu9250_accel(int16_t v) +{ + return (int16_t) ((v * (int32_t) (16.0 * 980.665 + 0.5)) / 32767); +} + +static int16_t /* deg*10/s */ +ao_mpu9250_gyro(int16_t v) +{ + return (int16_t) ((v * (int32_t) 20000) / 32767); +} +#endif + +static uint8_t +ao_mpu9250_accel_check(int16_t normal, int16_t test) +{ + int16_t diff = test - normal; + + if (diff < MPU9250_ST_ACCEL(16) / 4) { + return 1; + } + if (diff > MPU9250_ST_ACCEL(16) * 4) { + return 1; + } + return 0; +} + +static uint8_t +ao_mpu9250_gyro_check(int16_t normal, int16_t test) +{ + int16_t diff = test - normal; + + if (diff < 0) + diff = -diff; + if (diff < MPU9250_ST_GYRO(2000) / 4) { + return 1; + } + if (diff > MPU9250_ST_GYRO(2000) * 4) { + return 1; + } + return 0; +} + +static void +_ao_mpu9250_wait_alive(void) +{ + uint8_t i; + + /* Wait for the chip to wake up */ + for (i = 0; i < 30; i++) { + ao_delay(AO_MS_TO_TICKS(100)); + if (_ao_mpu9250_reg_read(MPU9250_WHO_AM_I) == MPU9250_I_AM_9250) + break; + } + if (i == 30) + ao_panic(AO_PANIC_SELF_TEST_MPU9250); +} + +#define ST_TRIES 10 + +static void +_ao_mpu9250_setup(void) +{ + struct ao_mpu9250_sample normal_mode, test_mode; + int errors; + int st_tries; + + if (ao_mpu9250_configured) + return; + + _ao_mpu9250_wait_alive(); + + /* Reset the whole chip */ + + _ao_mpu9250_reg_write(MPU9250_PWR_MGMT_1, + (1 << MPU9250_PWR_MGMT_1_DEVICE_RESET)); + + /* Wait for it to reset. If we talk too quickly, it appears to get confused */ + + _ao_mpu9250_wait_alive(); + + /* Reset signal conditioning, disabling I2C on SPI systems */ + _ao_mpu9250_reg_write(MPU9250_USER_CTRL, + (0 << MPU9250_USER_CTRL_FIFO_EN) | + (0 << MPU9250_USER_CTRL_I2C_MST_EN) | + (AO_MPU9250_SPI << MPU9250_USER_CTRL_I2C_IF_DIS) | + (0 << MPU9250_USER_CTRL_FIFO_RESET) | + (0 << MPU9250_USER_CTRL_I2C_MST_RESET) | + (1 << MPU9250_USER_CTRL_SIG_COND_RESET)); + + while (_ao_mpu9250_reg_read(MPU9250_USER_CTRL) & (1 << MPU9250_USER_CTRL_SIG_COND_RESET)) + ao_delay(AO_MS_TO_TICKS(10)); + + /* Reset signal paths */ + _ao_mpu9250_reg_write(MPU9250_SIGNAL_PATH_RESET, + (1 << MPU9250_SIGNAL_PATH_RESET_GYRO_RESET) | + (1 << MPU9250_SIGNAL_PATH_RESET_ACCEL_RESET) | + (1 << MPU9250_SIGNAL_PATH_RESET_TEMP_RESET)); + + _ao_mpu9250_reg_write(MPU9250_SIGNAL_PATH_RESET, + (0 << MPU9250_SIGNAL_PATH_RESET_GYRO_RESET) | + (0 << MPU9250_SIGNAL_PATH_RESET_ACCEL_RESET) | + (0 << MPU9250_SIGNAL_PATH_RESET_TEMP_RESET)); + + /* Select clocks, disable sleep */ + _ao_mpu9250_reg_write(MPU9250_PWR_MGMT_1, + (0 << MPU9250_PWR_MGMT_1_DEVICE_RESET) | + (0 << MPU9250_PWR_MGMT_1_SLEEP) | + (0 << MPU9250_PWR_MGMT_1_CYCLE) | + (0 << MPU9250_PWR_MGMT_1_TEMP_DIS) | + (MPU9250_PWR_MGMT_1_CLKSEL_PLL_X_AXIS << MPU9250_PWR_MGMT_1_CLKSEL)); + + /* Set sample rate divider to sample at full speed */ + _ao_mpu9250_reg_write(MPU9250_SMPRT_DIV, 0); + + /* Disable filtering */ + _ao_mpu9250_reg_write(MPU9250_CONFIG, + (MPU9250_CONFIG_EXT_SYNC_SET_DISABLED << MPU9250_CONFIG_EXT_SYNC_SET) | + (MPU9250_CONFIG_DLPF_CFG_250 << MPU9250_CONFIG_DLPF_CFG)); + + for (st_tries = 0; st_tries < ST_TRIES; st_tries++) { + errors = 0; + + /* Configure accelerometer to +/-16G in self-test mode */ + _ao_mpu9250_reg_write(MPU9250_ACCEL_CONFIG, + (1 << MPU9250_ACCEL_CONFIG_XA_ST) | + (1 << MPU9250_ACCEL_CONFIG_YA_ST) | + (1 << MPU9250_ACCEL_CONFIG_ZA_ST) | + (MPU9250_ACCEL_CONFIG_AFS_SEL_16G << MPU9250_ACCEL_CONFIG_AFS_SEL)); + + /* Configure gyro to +/- 2000°/s in self-test mode */ + _ao_mpu9250_reg_write(MPU9250_GYRO_CONFIG, + (1 << MPU9250_GYRO_CONFIG_XG_ST) | + (1 << MPU9250_GYRO_CONFIG_YG_ST) | + (1 << MPU9250_GYRO_CONFIG_ZG_ST) | + (MPU9250_GYRO_CONFIG_FS_SEL_2000 << MPU9250_GYRO_CONFIG_FS_SEL)); + + ao_delay(AO_MS_TO_TICKS(200)); + _ao_mpu9250_sample(&test_mode); + + /* Configure accelerometer to +/-16G */ + _ao_mpu9250_reg_write(MPU9250_ACCEL_CONFIG, + (0 << MPU9250_ACCEL_CONFIG_XA_ST) | + (0 << MPU9250_ACCEL_CONFIG_YA_ST) | + (0 << MPU9250_ACCEL_CONFIG_ZA_ST) | + (MPU9250_ACCEL_CONFIG_AFS_SEL_16G << MPU9250_ACCEL_CONFIG_AFS_SEL)); + + /* Configure gyro to +/- 2000°/s */ + _ao_mpu9250_reg_write(MPU9250_GYRO_CONFIG, + (0 << MPU9250_GYRO_CONFIG_XG_ST) | + (0 << MPU9250_GYRO_CONFIG_YG_ST) | + (0 << MPU9250_GYRO_CONFIG_ZG_ST) | + (MPU9250_GYRO_CONFIG_FS_SEL_2000 << MPU9250_GYRO_CONFIG_FS_SEL)); + + ao_delay(AO_MS_TO_TICKS(200)); + _ao_mpu9250_sample(&normal_mode); + + errors += ao_mpu9250_accel_check(normal_mode.accel_x, test_mode.accel_x); + errors += ao_mpu9250_accel_check(normal_mode.accel_y, test_mode.accel_y); + errors += ao_mpu9250_accel_check(normal_mode.accel_z, test_mode.accel_z); + + errors += ao_mpu9250_gyro_check(normal_mode.gyro_x, test_mode.gyro_x); + errors += ao_mpu9250_gyro_check(normal_mode.gyro_y, test_mode.gyro_y); + errors += ao_mpu9250_gyro_check(normal_mode.gyro_z, test_mode.gyro_z); + if (!errors) + break; + } + + if (st_tries == ST_TRIES) + ao_sensor_errors = 1; + + /* Filter to about 100Hz, which also sets the gyro rate to 1000Hz */ + _ao_mpu9250_reg_write(MPU9250_CONFIG, + (MPU9250_CONFIG_FIFO_MODE_REPLACE << MPU9250_CONFIG_FIFO_MODE) | + (MPU9250_CONFIG_EXT_SYNC_SET_DISABLED << MPU9250_CONFIG_EXT_SYNC_SET) | + (MPU9250_CONFIG_DLPF_CFG_92 << MPU9250_CONFIG_DLPF_CFG)); + + /* Set sample rate divider to sample at 200Hz (v = gyro/rate - 1) */ + _ao_mpu9250_reg_write(MPU9250_SMPRT_DIV, + 1000 / 200 - 1); + + ao_delay(AO_MS_TO_TICKS(100)); + ao_mpu9250_configured = 1; +} + +struct ao_mpu9250_sample ao_mpu9250_current; + +static void +ao_mpu9250(void) +{ + struct ao_mpu9250_sample sample; + /* ao_mpu9250_init already grabbed the SPI bus and mutex */ + _ao_mpu9250_setup(); +#if AO_MPU9250_SPI + ao_mpu9250_spi_put(); +#endif + for (;;) + { +#if AO_MPU9250_SPI + ao_mpu9250_spi_get(); +#endif + _ao_mpu9250_sample(&sample); +#if AO_MPU9250_SPI + ao_mpu9250_spi_put(); +#endif + ao_arch_block_interrupts(); + ao_mpu9250_current = sample; + AO_DATA_PRESENT(AO_DATA_MPU9250); + AO_DATA_WAIT(); + ao_arch_release_interrupts(); + } +} + +static struct ao_task ao_mpu9250_task; + +static void +ao_mpu9250_show(void) +{ + printf ("Accel: %7d %7d %7d Gyro: %7d %7d %7d\n", + ao_mpu9250_current.accel_x, + ao_mpu9250_current.accel_y, + ao_mpu9250_current.accel_z, + ao_mpu9250_current.gyro_x, + ao_mpu9250_current.gyro_y, + ao_mpu9250_current.gyro_z); +} + +static void +ao_mpu9250_read(void) +{ + uint8_t addr; + uint8_t val; + + ao_cmd_hex(); + if (ao_cmd_status != ao_cmd_success) + return; + addr = ao_cmd_lex_i; + ao_mpu9250_spi_get(); + val = _ao_mpu9250_reg_read(addr); + ao_mpu9250_spi_put(); + printf("Addr %02x val %02x\n", addr, val); +} + +static void +ao_mpu9250_write(void) +{ + uint8_t addr; + uint8_t val; + + ao_cmd_hex(); + if (ao_cmd_status != ao_cmd_success) + return; + addr = ao_cmd_lex_i; + ao_cmd_hex(); + if (ao_cmd_status != ao_cmd_success) + return; + val = ao_cmd_lex_i; + printf("Addr %02x val %02x\n", addr, val); + ao_mpu9250_spi_get(); + _ao_mpu9250_reg_write(addr, val); + ao_mpu9250_spi_put(); +} + +static const struct ao_cmds ao_mpu9250_cmds[] = { + { ao_mpu9250_show, "I\0Show MPU9250 status" }, + { ao_mpu9250_read, "R \0Read MPU9250 register" }, + { ao_mpu9250_write, "W \0Write MPU9250 register" }, + { 0, NULL } +}; + +void +ao_mpu9250_init(void) +{ + ao_mpu9250_configured = 0; + + ao_add_task(&ao_mpu9250_task, ao_mpu9250, "mpu9250"); + +#if AO_MPU9250_SPI + ao_spi_init_cs(AO_MPU9250_SPI_CS_PORT, (1 << AO_MPU9250_SPI_CS_PIN)); + + /* Pretend to be the mpu9250 task. Grab the SPI bus right away and + * hold it for the task so that nothing else uses the SPI bus before + * we get the I2C mode disabled in the chip + */ + + ao_cur_task = &ao_mpu9250_task; + ao_spi_get(AO_MPU9250_SPI_BUS, AO_SPI_SPEED_1MHz); + ao_cur_task = NULL; +#endif + ao_cmd_register(&ao_mpu9250_cmds[0]); +} +#endif diff --git a/src/drivers/ao_mpu9250.h b/src/drivers/ao_mpu9250.h new file mode 100644 index 00000000..a124d799 --- /dev/null +++ b/src/drivers/ao_mpu9250.h @@ -0,0 +1,220 @@ +/* + * Copyright © 2012 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * 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_MPU9250_H_ +#define _AO_MPU9250_H_ + +#ifndef M_PI +#define M_PI 3.1415926535897832384626433 +#endif + +#define MPU9250_ADDR_WRITE 0xd0 +#define MPU9250_ADDR_READ 0xd1 + +/* From Tridge */ +#define MPUREG_XG_OFFS_TC 0x00 +#define MPUREG_YG_OFFS_TC 0x01 +#define MPUREG_ZG_OFFS_TC 0x02 +#define MPUREG_X_FINE_GAIN 0x03 +#define MPUREG_Y_FINE_GAIN 0x04 +#define MPUREG_Z_FINE_GAIN 0x05 +#define MPUREG_XA_OFFS_H 0x06 // X axis accelerometer offset (high byte) +#define MPUREG_XA_OFFS_L 0x07 // X axis accelerometer offset (low byte) +#define MPUREG_YA_OFFS_H 0x08 // Y axis accelerometer offset (high byte) +#define MPUREG_YA_OFFS_L 0x09 // Y axis accelerometer offset (low byte) +#define MPUREG_ZA_OFFS_H 0x0A // Z axis accelerometer offset (high byte) +#define MPUREG_ZA_OFFS_L 0x0B // Z axis accelerometer offset (low byte) +#define MPUREG_PRODUCT_ID 0x0C // Product ID Register +#define MPUREG_XG_OFFS_USRH 0x13 // X axis gyro offset (high byte) +#define MPUREG_XG_OFFS_USRL 0x14 // X axis gyro offset (low byte) +#define MPUREG_YG_OFFS_USRH 0x15 // Y axis gyro offset (high byte) +#define MPUREG_YG_OFFS_USRL 0x16 // Y axis gyro offset (low byte) +#define MPUREG_ZG_OFFS_USRH 0x17 // Z axis gyro offset (high byte) +#define MPUREG_ZG_OFFS_USRL 0x18 // Z axis gyro offset (low byte) + +#define MPU9250_SMPRT_DIV 0x19 + +#define MPU9250_CONFIG 0x1a + +#define MPU9250_CONFIG_FIFO_MODE 6 +# define MPU9250_CONFIG_FIFO_MODE_REPLACE 0 +# define MPU9250_CONFIG_FIFO_MODE_DROP 1 + +#define MPU9250_CONFIG_EXT_SYNC_SET 3 +#define MPU9250_CONFIG_EXT_SYNC_SET_DISABLED 0 +#define MPU9250_CONFIG_EXT_SYNC_SET_TEMP_OUT_L 1 +#define MPU9250_CONFIG_EXT_SYNC_SET_GYRO_XOUT_L 2 +#define MPU9250_CONFIG_EXT_SYNC_SET_GYRO_YOUT_L 3 +#define MPU9250_CONFIG_EXT_SYNC_SET_GYRO_ZOUT_L 4 +#define MPU9250_CONFIG_EXT_SYNC_SET_ACCEL_XOUT_L 5 +#define MPU9250_CONFIG_EXT_SYNC_SET_ACCEL_YOUT_L 6 +#define MPU9250_CONFIG_EXT_SYNC_SET_ACCEL_ZOUT_L 7 +#define MPU9250_CONFIG_EXT_SYNC_SET_MASK 7 + +#define MPU9250_CONFIG_DLPF_CFG 0 +#define MPU9250_CONFIG_DLPF_CFG_250 0 +#define MPU9250_CONFIG_DLPF_CFG_184 1 +#define MPU9250_CONFIG_DLPF_CFG_92 2 +#define MPU9250_CONFIG_DLPF_CFG_41 3 +#define MPU9250_CONFIG_DLPF_CFG_20 4 +#define MPU9250_CONFIG_DLPF_CFG_10 5 +#define MPU9250_CONFIG_DLPF_CFG_5 6 +#define MPU9250_CONFIG_DLPF_CFG_MASK 7 + +#define MPU9250_GYRO_CONFIG 0x1b +# define MPU9250_GYRO_CONFIG_XG_ST 7 +# define MPU9250_GYRO_CONFIG_YG_ST 6 +# define MPU9250_GYRO_CONFIG_ZG_ST 5 +# define MPU9250_GYRO_CONFIG_FS_SEL 3 +# define MPU9250_GYRO_CONFIG_FS_SEL_250 0 +# define MPU9250_GYRO_CONFIG_FS_SEL_500 1 +# define MPU9250_GYRO_CONFIG_FS_SEL_1000 2 +# define MPU9250_GYRO_CONFIG_FS_SEL_2000 3 +# define MPU9250_GYRO_CONFIG_FS_SEL_MASK 3 +# define MPU9250_GYRO_CONFIG_FCHOICE_B 0 +# define MPU9250_GYRO_CONFIG_FCHOICE_B_8800 3 +# define MPU9250_GYRO_CONFIG_FCHOICE_B_3600 2 +# define MPU9250_GYRO_CONFIG_FCHOICE_B_LOW 0 + +#define MPU9250_ACCEL_CONFIG 0x1c +# define MPU9250_ACCEL_CONFIG_XA_ST 7 +# define MPU9250_ACCEL_CONFIG_YA_ST 6 +# define MPU9250_ACCEL_CONFIG_ZA_ST 5 +# define MPU9250_ACCEL_CONFIG_AFS_SEL 3 +# define MPU9250_ACCEL_CONFIG_AFS_SEL_2G 0 +# define MPU9250_ACCEL_CONFIG_AFS_SEL_4G 1 +# define MPU9250_ACCEL_CONFIG_AFS_SEL_8G 2 +# define MPU9250_ACCEL_CONFIG_AFS_SEL_16G 3 +# define MPU9250_ACCEL_CONFIG_AFS_SEL_MASK 3 + +#define MPU9250_INT_ENABLE 0x38 +#define MPU9250_INT_ENABLE_FF_EN 7 +#define MPU9250_INT_ENABLE_MOT_EN 6 +#define MPU9250_INT_ENABLE_ZMOT_EN 5 +#define MPU9250_INT_ENABLE_FIFO_OFLOW_EN 4 +#define MPU9250_INT_ENABLE_I2C_MST_INT_EN 3 +#define MPU9250_INT_ENABLE_DATA_RDY_EN 0 + +#define MPU9250_INT_STATUS 0x3a +#define MPU9250_INT_STATUS_FF_EN 7 +#define MPU9250_INT_STATUS_MOT_EN 6 +#define MPU9250_INT_STATUS_ZMOT_EN 5 +#define MPU9250_INT_STATUS_FIFO_OFLOW_EN 4 +#define MPU9250_INT_STATUS_I2C_MST_INT_EN 3 +#define MPU9250_INT_STATUS_DATA_RDY_EN 0 + +#define MPU9250_ACCEL_XOUT_H 0x3b +#define MPU9250_ACCEL_XOUT_L 0x3c +#define MPU9250_ACCEL_YOUT_H 0x3d +#define MPU9250_ACCEL_YOUT_L 0x3e +#define MPU9250_ACCEL_ZOUT_H 0x3f +#define MPU9250_ACCEL_ZOUT_L 0x40 +#define MPU9250_TEMP_H 0x41 +#define MPU9250_TEMP_L 0x42 +#define MPU9250_GYRO_XOUT_H 0x43 +#define MPU9250_GYRO_XOUT_L 0x44 +#define MPU9250_GYRO_YOUT_H 0x45 +#define MPU9250_GYRO_YOUT_L 0x46 +#define MPU9250_GYRO_ZOUT_H 0x47 +#define MPU9250_GYRO_ZOUT_L 0x48 + +#define MPU9250_SIGNAL_PATH_RESET 0x68 +#define MPU9250_SIGNAL_PATH_RESET_GYRO_RESET 2 +#define MPU9250_SIGNAL_PATH_RESET_ACCEL_RESET 1 +#define MPU9250_SIGNAL_PATH_RESET_TEMP_RESET 0 + +#define MPU9250_USER_CTRL 0x6a +#define MPU9250_USER_CTRL_FIFO_EN 6 +#define MPU9250_USER_CTRL_I2C_MST_EN 5 +#define MPU9250_USER_CTRL_I2C_IF_DIS 4 +#define MPU9250_USER_CTRL_FIFO_RESET 2 +#define MPU9250_USER_CTRL_I2C_MST_RESET 1 +#define MPU9250_USER_CTRL_SIG_COND_RESET 0 + +#define MPU9250_PWR_MGMT_1 0x6b +#define MPU9250_PWR_MGMT_1_DEVICE_RESET 7 +#define MPU9250_PWR_MGMT_1_SLEEP 6 +#define MPU9250_PWR_MGMT_1_CYCLE 5 +#define MPU9250_PWR_MGMT_1_TEMP_DIS 3 +#define MPU9250_PWR_MGMT_1_CLKSEL 0 +#define MPU9250_PWR_MGMT_1_CLKSEL_INTERNAL 0 +#define MPU9250_PWR_MGMT_1_CLKSEL_PLL_X_AXIS 1 +#define MPU9250_PWR_MGMT_1_CLKSEL_PLL_Y_AXIS 2 +#define MPU9250_PWR_MGMT_1_CLKSEL_PLL_Z_AXIS 3 +#define MPU9250_PWR_MGMT_1_CLKSEL_PLL_EXTERNAL_32K 4 +#define MPU9250_PWR_MGMT_1_CLKSEL_PLL_EXTERNAL_19M 5 +#define MPU9250_PWR_MGMT_1_CLKSEL_STOP 7 +#define MPU9250_PWR_MGMT_1_CLKSEL_MASK 7 + +#define MPU9250_PWR_MGMT_2 0x6c + +#define MPU9250_WHO_AM_I 0x75 +#define MPU9250_I_AM_9250 0x71 + +/* Self test acceleration is approximately 0.5g */ +#define MPU9250_ST_ACCEL(full_scale) (32767 / ((full_scale) * 2)) + +/* Self test gyro is approximately 50°/s */ +#define MPU9250_ST_GYRO(full_scale) ((int16_t) (((int32_t) 32767 * (int32_t) 50) / (full_scale))) + +#define MPU9250_GYRO_FULLSCALE ((float) 2000 * M_PI/180.0) + +static inline float +ao_mpu9250_gyro(float sensor) { + return sensor * ((float) (MPU9250_GYRO_FULLSCALE / 32767.0)); +} + +#define MPU9250_ACCEL_FULLSCALE 16 + +static inline float +ao_mpu9250_accel(int16_t sensor) { + return (float) sensor * ((float) (MPU9250_ACCEL_FULLSCALE * GRAVITY / 32767.0)); +} + +struct ao_mpu9250_sample { + int16_t accel_x; + int16_t accel_y; + int16_t accel_z; + int16_t temp; + int16_t gyro_x; + int16_t gyro_y; + int16_t gyro_z; +}; + +extern struct ao_mpu9250_sample ao_mpu9250_current; + +void +ao_mpu9250_init(void); + +/* Product ID Description for MPU9250 + * high 4 bits low 4 bits + * Product Name Product Revision + */ +#define MPU9250ES_REV_C4 0x14 /* 0001 0100 */ +#define MPU9250ES_REV_C5 0x15 /* 0001 0101 */ +#define MPU9250ES_REV_D6 0x16 /* 0001 0110 */ +#define MPU9250ES_REV_D7 0x17 /* 0001 0111 */ +#define MPU9250ES_REV_D8 0x18 /* 0001 1000 */ +#define MPU9250_REV_C4 0x54 /* 0101 0100 */ +#define MPU9250_REV_C5 0x55 /* 0101 0101 */ +#define MPU9250_REV_D6 0x56 /* 0101 0110 */ +#define MPU9250_REV_D7 0x57 /* 0101 0111 */ +#define MPU9250_REV_D8 0x58 /* 0101 1000 */ +#define MPU9250_REV_D9 0x59 /* 0101 1001 */ + +#endif /* _AO_MPU9250_H_ */ -- cgit v1.2.3 From a69d5773a63dbe5d6d758cea8eca2bf724e9d672 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 12 Oct 2017 00:26:31 -0700 Subject: altoslib: Allow gps time later than requested if it's first When generating a KML file, we want to position markers near the start of the flight section. This is done by looking for a GPS coordinate 'before' the starting point of the flight, which doesn't work well when the first GPS coordinate is later than that. Pick the first point after the chosen time if there isn't an earlier one. Signed-off-by: Keith Packard --- altoslib/AltosFlightSeries.java | 25 ++++++++++++++++++------- 1 file changed, 18 insertions(+), 7 deletions(-) diff --git a/altoslib/AltosFlightSeries.java b/altoslib/AltosFlightSeries.java index 02bf64ff..2eaf8033 100644 --- a/altoslib/AltosFlightSeries.java +++ b/altoslib/AltosFlightSeries.java @@ -489,13 +489,24 @@ public class AltosFlightSeries extends AltosDataListener { public ArrayList gps_series; public AltosGPS gps_before(double time) { - AltosGPS gps = null; - for (AltosGPSTimeValue gtv : gps_series) - if (gtv.time <= time) - gps = gtv.gps; - else - break; - return gps; + AltosGPSTimeValue nearest = null; + for (AltosGPSTimeValue gtv : gps_series) { + if (nearest == null) + nearest = gtv; + else { + if (gtv.time <= time) { + if (nearest.time <= time && gtv.time > nearest.time) + nearest = gtv; + } else { + if (nearest.time > time && gtv.time < nearest.time) + nearest = gtv; + } + } + } + if (nearest != null) + return nearest.gps; + else + return null; } public AltosTimeSeries sats_in_view; -- cgit v1.2.3 From e04679ba52761d5531037117a21ab1f1896358b0 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 12 Oct 2017 00:29:07 -0700 Subject: altoslib: Don't crash if there's no GPS coord to write KML Just check for null before writing as a precaution. Signed-off-by: Keith Packard --- altoslib/AltosKML.java | 2 ++ 1 file changed, 2 insertions(+) diff --git a/altoslib/AltosKML.java b/altoslib/AltosKML.java index 4738ac91..aa98f0e6 100644 --- a/altoslib/AltosKML.java +++ b/altoslib/AltosKML.java @@ -244,6 +244,8 @@ public class AltosKML implements AltosWriter { public void write(AltosGPS gps, double alt) { + if (gps == null) + return; if (gps.lat == AltosLib.MISSING) return; if (gps.lon == AltosLib.MISSING) -- cgit v1.2.3 From 77d1aee917306ad59492c4c8352fe2125b430d0c Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 12 Oct 2017 00:30:23 -0700 Subject: altoslib: Fix time series filter window computation Small floating point rounding errors could lead to NaNs. Signed-off-by: Keith Packard --- altoslib/AltosTimeSeries.java | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/altoslib/AltosTimeSeries.java b/altoslib/AltosTimeSeries.java index 7208c176..c6a780a3 100644 --- a/altoslib/AltosTimeSeries.java +++ b/altoslib/AltosTimeSeries.java @@ -294,7 +294,7 @@ public class AltosTimeSeries implements Iterable, Comparable 1) + if (t > 1 || t < -1) t = 1; double k = i0 (beta * Math.sqrt (1 - t*t)) / i0(beta); return k; -- cgit v1.2.3 From 4431f70044f4e1120d606f0ded1845349295d68e Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 12 Oct 2017 00:31:26 -0700 Subject: altos: Add MPU9250 support to self test and data The remaining hooks to make the MPU9250 work in flight. Signed-off-by: Keith Packard --- src/kernel/ao.h | 1 + src/kernel/ao_data.h | 12 +++++++++++- 2 files changed, 12 insertions(+), 1 deletion(-) diff --git a/src/kernel/ao.h b/src/kernel/ao.h index e56fbb2e..139050cf 100644 --- a/src/kernel/ao.h +++ b/src/kernel/ao.h @@ -78,6 +78,7 @@ typedef AO_PORT_TYPE ao_port_t; #define AO_PANIC_SELF_TEST_CC1120 0x40 | 1 /* Self test failure */ #define AO_PANIC_SELF_TEST_HMC5883 0x40 | 2 /* Self test failure */ #define AO_PANIC_SELF_TEST_MPU6000 0x40 | 3 /* Self test failure */ +#define AO_PANIC_SELF_TEST_MPU9250 0x40 | 3 /* Self test failure */ #define AO_PANIC_SELF_TEST_MS5607 0x40 | 4 /* Self test failure */ /* Stop the operating system, beeping and blinking the reason */ diff --git a/src/kernel/ao_data.h b/src/kernel/ao_data.h index d62852ef..9a3b389c 100644 --- a/src/kernel/ao_data.h +++ b/src/kernel/ao_data.h @@ -41,6 +41,13 @@ #define AO_DATA_MPU6000 0 #endif +#if HAS_MPU9250 +#include +#define AO_DATA_MPU9250 (1 << 2) +#else +#define AO_DATA_MPU9250 0 +#endif + #if HAS_HMC5883 #include #define AO_DATA_HMC5883 (1 << 3) @@ -57,7 +64,7 @@ #ifdef AO_DATA_RING -#define AO_DATA_ALL (AO_DATA_ADC|AO_DATA_MS5607|AO_DATA_MPU6000|AO_DATA_HMC5883|AO_DATA_MMA655X) +#define AO_DATA_ALL (AO_DATA_ADC|AO_DATA_MS5607|AO_DATA_MPU6000|AO_DATA_HMC5883|AO_DATA_MMA655X|AO_DATA_MPU9250) struct ao_data { uint16_t tick; @@ -74,6 +81,9 @@ struct ao_data { int16_t z_accel; #endif #endif +#if HAS_MPU9250 + struct ao_mpu9250_sample mpu9250; +#endif #if HAS_HMC5883 struct ao_hmc5883_sample hmc5883; #endif -- cgit v1.2.3 From 964a14568b73296194f84c728cc7e01d6f0e2f64 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 14 Oct 2017 12:05:07 -0700 Subject: altoslib: Report un-adjusted ground accel in idle IMU monitor The ground accel is the basis of the accel adjustment, so it needs to be delivered in un-adjusted form. Signed-off-by: Keith Packard --- altoslib/AltosIMU.java | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/altoslib/AltosIMU.java b/altoslib/AltosIMU.java index dee28a92..ba6f1a82 100644 --- a/altoslib/AltosIMU.java +++ b/altoslib/AltosIMU.java @@ -83,9 +83,9 @@ public class AltosIMU implements Cloneable { listener.set_gyro(cal_data.gyro_roll(imu.gyro_y), cal_data.gyro_pitch(imu.gyro_x), cal_data.gyro_yaw(imu.gyro_z)); - listener.set_accel_ground(cal_data.accel_along(imu.accel_y), - cal_data.accel_across(imu.accel_x), - cal_data.accel_through(imu.accel_z)); + listener.set_accel_ground(imu.accel_y, + imu.accel_x, + imu.accel_z); } } catch (TimeoutException te) { } -- cgit v1.2.3 From e98235e314ac764509af26c93da9e6d1de8184ea Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 14 Oct 2017 12:18:26 -0700 Subject: altoslib: Save separate config for local and remote. Use in idle When using the remote link, there are two separate configuration data blocks, that for the local device and for remote. Make the link report both versions, depending on whether it is in remote mode or not. Request config data in remote mode when running idle monitoring so that the presented data is for the remote device, not the local one. Signed-off-by: Keith Packard --- altoslib/AltosIdleMonitor.java | 17 +++++------ altoslib/AltosLink.java | 63 +++++++++++++++++++++++++++-------------- altosui/AltosIdleMonitorUI.java | 2 +- 3 files changed, 52 insertions(+), 30 deletions(-) diff --git a/altoslib/AltosIdleMonitor.java b/altoslib/AltosIdleMonitor.java index fc5d4cc8..834d9aa5 100644 --- a/altoslib/AltosIdleMonitor.java +++ b/altoslib/AltosIdleMonitor.java @@ -33,6 +33,7 @@ public class AltosIdleMonitor extends Thread { double frequency; String callsign; + AltosState state; AltosListenerState listener_state; AltosConfigData config_data; AltosGPS gps; @@ -52,20 +53,23 @@ public class AltosIdleMonitor extends Thread { return link.reply_abort; } - boolean provide_data(AltosDataListener listener) throws InterruptedException, TimeoutException, AltosUnknownProduct { + boolean provide_data() throws InterruptedException, TimeoutException, AltosUnknownProduct { boolean worked = false; boolean aborted = false; try { start_link(); - fetch.provide_data(listener); + link.config_data(); + if (state == null) + state = new AltosState(new AltosCalData(link.config_data())); + fetch.provide_data(state); if (!link.has_error && !link.reply_abort) worked = true; } finally { aborted = stop_link(); if (worked) { if (remote) - listener.set_rssi(link.rssi(), 0); + state.set_rssi(link.rssi(), 0); listener_state.battery = link.monitor_battery(); } } @@ -92,14 +96,11 @@ public class AltosIdleMonitor extends Thread { } public void run() { - AltosState state = null; + state = null; try { for (;;) { try { - link.config_data(); - if (state == null) - state = new AltosState(new AltosCalData(link.config_data())); - provide_data(state); + provide_data(); listener.update(state, listener_state); } catch (TimeoutException te) { } catch (AltosUnknownProduct ae) { diff --git a/altoslib/AltosLink.java b/altoslib/AltosLink.java index 5413de9d..829a1a63 100644 --- a/altoslib/AltosLink.java +++ b/altoslib/AltosLink.java @@ -355,7 +355,8 @@ public abstract class AltosLink implements Runnable { public int telemetry_rate = -1; public double frequency; public String callsign; - AltosConfigData config_data; + private AltosConfigData config_data_local; + private AltosConfigData config_data_remote; private Object config_data_lock = new Object(); @@ -390,7 +391,7 @@ public abstract class AltosLink implements Runnable { public void set_radio_frequency(double in_frequency) throws InterruptedException, TimeoutException { frequency = in_frequency; - config_data(); + AltosConfigData config_data = config_data(); set_radio_frequency(frequency, config_data.radio_frequency > 0, config_data.radio_setting > 0, @@ -446,11 +447,24 @@ public abstract class AltosLink implements Runnable { public AltosConfigData config_data() throws InterruptedException, TimeoutException { synchronized(config_data_lock) { - if (config_data == null) { - printf("m 0\n"); - config_data = new AltosConfigData(this); - if (monitor_mode) - set_monitor(true); + AltosConfigData config_data; + + if (remote) { + if (config_data_remote == null) { + printf("m 0\n"); + config_data_remote = new AltosConfigData(this); + if (monitor_mode) + set_monitor(true); + } + config_data = config_data_remote; + } else { + if (config_data_local == null) { + printf("m 0\n"); + config_data_local = new AltosConfigData(this); + if (monitor_mode) + set_monitor(true); + } + config_data = config_data_local; } return config_data; } @@ -551,14 +565,23 @@ public abstract class AltosLink implements Runnable { } public boolean has_monitor_battery() { - return config_data.has_monitor_battery(); + try { + return config_data().has_monitor_battery(); + } catch (InterruptedException ie) { + return false; + } catch (TimeoutException te) { + return false; + } } public double monitor_battery() throws InterruptedException { - int monitor_batt = AltosLib.MISSING; + double volts = AltosLib.MISSING; - if (config_data.has_monitor_battery()) { - try { + try { + AltosConfigData config_data = config_data(); + int monitor_batt = AltosLib.MISSING; + + if (config_data.has_monitor_battery()) { String[] items = adc(); for (int i = 0; i < items.length;) { if (items[i].equals("batt")) { @@ -568,19 +591,17 @@ public abstract class AltosLink implements Runnable { } i++; } - } catch (TimeoutException te) { } - } - if (monitor_batt == AltosLib.MISSING) - return AltosLib.MISSING; + if (monitor_batt != AltosLib.MISSING) { + if (config_data.product.startsWith("TeleBT-v3") || config_data.product.startsWith("TeleBT-v4")) { + volts = AltosConvert.tele_bt_3_battery(monitor_batt); + } else { + volts = AltosConvert.cc_battery_to_voltage(monitor_batt); + } + } - double volts = AltosLib.MISSING; - if (config_data.product.startsWith("TeleBT-v3") || config_data.product.startsWith("TeleBT-v4")) { - volts = AltosConvert.tele_bt_3_battery(monitor_batt); - } else { - volts = AltosConvert.cc_battery_to_voltage(monitor_batt); + } catch (TimeoutException te) { } - return volts; } diff --git a/altosui/AltosIdleMonitorUI.java b/altosui/AltosIdleMonitorUI.java index a2696f15..584f143a 100644 --- a/altosui/AltosIdleMonitorUI.java +++ b/altosui/AltosIdleMonitorUI.java @@ -295,7 +295,7 @@ public class AltosIdleMonitorUI extends AltosUIFrame implements AltosFlightDispl pack(); setVisible(true); - thread = new AltosIdleMonitor((AltosIdleMonitorListener) this, link, (boolean) remote); + thread = new AltosIdleMonitor(this, link, (boolean) remote); status_update = new AltosFlightStatusUpdate(flightStatus); -- cgit v1.2.3 From 749400fd244eba38806c623d2a35722642230698 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 22 Oct 2017 14:04:09 -0500 Subject: altoslib: Move temp GPS API from cal_data to data_listener This makes the API more consistent, and means that the listener is responsible for mangaing the temp gps state. In particular, the AltosDataListener set_gps API now calls the cal_data function. Signed-off-by: Keith Packard --- altoslib/AltosCalData.java | 39 ++++---- altoslib/AltosDataListener.java | 13 ++- altoslib/AltosEepromDownload.java | 1 + altoslib/AltosEepromRecord.java | 6 +- altoslib/AltosEepromRecordFull.java | 12 +-- altoslib/AltosEepromRecordMega.java | 4 +- altoslib/AltosEepromRecordMetrum.java | 6 +- altoslib/AltosFlightListener.java | 162 ---------------------------------- altoslib/AltosFlightSeries.java | 1 + altoslib/AltosReplayReader.java | 2 +- altoslib/AltosState.java | 1 + altoslib/AltosTelemetryLocation.java | 7 +- altoslib/AltosTelemetrySatellite.java | 3 +- 13 files changed, 47 insertions(+), 210 deletions(-) delete mode 100644 altoslib/AltosFlightListener.java diff --git a/altoslib/AltosCalData.java b/altoslib/AltosCalData.java index 7415d5ad..fdea5e21 100644 --- a/altoslib/AltosCalData.java +++ b/altoslib/AltosCalData.java @@ -199,7 +199,6 @@ public class AltosCalData { tick = AltosLib.MISSING; prev_tick = AltosLib.MISSING; temp_gps = null; - prev_gps = null; temp_gps_sat_tick = AltosLib.MISSING; accel = AltosLib.MISSING; } @@ -244,11 +243,14 @@ public class AltosCalData { public double gps_pad_altitude = AltosLib.MISSING; - public void set_gps(AltosGPS gps) { - if ((state != AltosLib.MISSING && state < AltosLib.ao_flight_boost) || gps_pad == null) - gps_pad = gps; - if (gps_pad_altitude == AltosLib.MISSING && gps.alt != AltosLib.MISSING) - gps_pad_altitude = gps.alt; + public void set_cal_gps(AltosGPS gps) { + if (gps.locked && gps.nsat >= 4) { + if ((state != AltosLib.MISSING && state < AltosLib.ao_flight_boost) || gps_pad == null) + gps_pad = gps; + if (gps_pad_altitude == AltosLib.MISSING && gps.alt != AltosLib.MISSING) + gps_pad_altitude = gps.alt; + } + temp_gps = null; } /* @@ -256,33 +258,24 @@ public class AltosCalData { * object and then deliver the result atomically to the listener */ AltosGPS temp_gps = null; - AltosGPS prev_gps = null; int temp_gps_sat_tick = AltosLib.MISSING; - public AltosGPS temp_gps() { + public AltosGPS temp_cal_gps() { return temp_gps; } - public void reset_temp_gps() { - if (temp_gps != null) { - if (temp_gps.locked && temp_gps.nsat >= 4) - set_gps(temp_gps); - prev_gps = temp_gps; - temp_gps = null; - } + public void reset_temp_cal_gps() { + if (temp_gps != null) + set_cal_gps(temp_gps); } - public boolean gps_pending() { + public boolean cal_gps_pending() { return temp_gps != null; } - public AltosGPS make_temp_gps(int tick, boolean sats) { - if (temp_gps == null) { - if (prev_gps != null) - temp_gps = prev_gps.clone(); - else - temp_gps = new AltosGPS(); - } + public AltosGPS make_temp_cal_gps(int tick, boolean sats) { + if (temp_gps == null) + temp_gps = new AltosGPS(); if (sats) { if (tick != temp_gps_sat_tick) temp_gps.cc_gps_sat = null; diff --git a/altoslib/AltosDataListener.java b/altoslib/AltosDataListener.java index 359d04c9..9a1e1465 100644 --- a/altoslib/AltosDataListener.java +++ b/altoslib/AltosDataListener.java @@ -111,7 +111,18 @@ public abstract class AltosDataListener { public abstract void set_apogee_voltage(double volts); public abstract void set_main_voltage(double volts); - public abstract void set_gps(AltosGPS gps); + public void set_gps(AltosGPS gps) { + AltosCalData cal_data = cal_data(); + cal_data.set_cal_gps(gps); + } + + public AltosGPS make_temp_gps(boolean sats) { + return cal_data().make_temp_cal_gps(tick(), sats); + } + + public AltosGPS temp_gps() { + return cal_data().temp_cal_gps(); + } public abstract void set_orient(double orient); public abstract void set_gyro(double roll, double pitch, double yaw); diff --git a/altoslib/AltosEepromDownload.java b/altoslib/AltosEepromDownload.java index 33f0dd17..3df8a5b4 100644 --- a/altoslib/AltosEepromDownload.java +++ b/altoslib/AltosEepromDownload.java @@ -40,6 +40,7 @@ class AltosEepromNameData extends AltosDataListener { public void set_main_voltage(double volts) { } public void set_gps(AltosGPS gps) { + super.set_gps(gps); if (gps != null && gps.year != AltosLib.MISSING && gps.month != AltosLib.MISSING && diff --git a/altoslib/AltosEepromRecord.java b/altoslib/AltosEepromRecord.java index e937c3d0..12519e6b 100644 --- a/altoslib/AltosEepromRecord.java +++ b/altoslib/AltosEepromRecord.java @@ -90,11 +90,9 @@ public abstract class AltosEepromRecord implements Comparable /* Flush any pending GPS changes */ if (!AltosLib.is_gps_cmd(cmd())) { - AltosGPS gps = cal_data.temp_gps(); - if (gps != null) { + AltosGPS gps = listener.temp_gps(); + if (gps != null) listener.set_gps(gps); - cal_data.reset_temp_gps(); - } } } diff --git a/altoslib/AltosEepromRecordFull.java b/altoslib/AltosEepromRecordFull.java index 32df9578..7e92d353 100644 --- a/altoslib/AltosEepromRecordFull.java +++ b/altoslib/AltosEepromRecordFull.java @@ -53,7 +53,7 @@ public class AltosEepromRecordFull extends AltosEepromRecord { listener.set_state(data16(0)); break; case AltosLib.AO_LOG_GPS_TIME: - gps = cal_data.make_temp_gps(tick(),false); + gps = listener.make_temp_gps(false); gps.hour = data8(0); gps.minute = data8(1); @@ -67,29 +67,29 @@ public class AltosEepromRecordFull extends AltosEepromRecord { AltosLib.AO_GPS_NUM_SAT_SHIFT; break; case AltosLib.AO_LOG_GPS_LAT: - gps = cal_data.make_temp_gps(tick(),false); + gps = listener.make_temp_gps(false); int lat32 = data32(0); gps.lat = (double) lat32 / 1e7; break; case AltosLib.AO_LOG_GPS_LON: - gps = cal_data.make_temp_gps(tick(),false); + gps = listener.make_temp_gps(false); int lon32 = data32(0); gps.lon = (double) lon32 / 1e7; break; case AltosLib.AO_LOG_GPS_ALT: - gps = cal_data.make_temp_gps(tick(),false); + gps = listener.make_temp_gps(false); gps.alt = data16(0); break; case AltosLib.AO_LOG_GPS_SAT: - gps = cal_data.make_temp_gps(tick(),true); + gps = listener.make_temp_gps(true); int svid = data16(0); int c_n0 = data16(2); gps.add_sat(svid, c_n0); break; case AltosLib.AO_LOG_GPS_DATE: - gps = cal_data.make_temp_gps(tick(),false); + gps = listener.make_temp_gps(false); gps.year = data8(0) + 2000; gps.month = data8(1); gps.day = data8(2); diff --git a/altoslib/AltosEepromRecordMega.java b/altoslib/AltosEepromRecordMega.java index ad3e23fd..ea5aff5c 100644 --- a/altoslib/AltosEepromRecordMega.java +++ b/altoslib/AltosEepromRecordMega.java @@ -188,7 +188,7 @@ public class AltosEepromRecordMega extends AltosEepromRecord { listener.set_pyro_fired(pyro()); break; case AltosLib.AO_LOG_GPS_TIME: - gps = cal_data.make_temp_gps(tick(), false); + gps = listener.make_temp_gps(false); gps.lat = latitude() / 1e7; gps.lon = longitude() / 1e7; @@ -231,7 +231,7 @@ public class AltosEepromRecordMega extends AltosEepromRecord { } break; case AltosLib.AO_LOG_GPS_SAT: - gps = cal_data.make_temp_gps(tick(), true); + gps = listener.make_temp_gps(true); int n = nsat(); if (n > max_sat) diff --git a/altoslib/AltosEepromRecordMetrum.java b/altoslib/AltosEepromRecordMetrum.java index 3da50544..888a06cc 100644 --- a/altoslib/AltosEepromRecordMetrum.java +++ b/altoslib/AltosEepromRecordMetrum.java @@ -91,7 +91,7 @@ public class AltosEepromRecordMetrum extends AltosEepromRecord { listener.set_main_voltage(AltosConvert.mega_pyro_voltage(sense_m())); break; case AltosLib.AO_LOG_GPS_POS: - gps = cal_data.make_temp_gps(tick(), false); + gps = listener.make_temp_gps(false); gps.lat = latitude() / 1e7; gps.lon = longitude() / 1e7; if (config_data().altitude_32()) @@ -100,7 +100,7 @@ public class AltosEepromRecordMetrum extends AltosEepromRecord { gps.alt = altitude_low(); break; case AltosLib.AO_LOG_GPS_TIME: - gps = cal_data.make_temp_gps(tick(), false); + gps = listener.make_temp_gps(false); gps.hour = hour(); gps.minute = minute(); @@ -119,7 +119,7 @@ public class AltosEepromRecordMetrum extends AltosEepromRecord { gps.pdop = pdop() / 10.0; break; case AltosLib.AO_LOG_GPS_SAT: - gps = cal_data.make_temp_gps(tick(), true); + gps = listener.make_temp_gps(true); int n = nsat(); for (int i = 0; i < n; i++) diff --git a/altoslib/AltosFlightListener.java b/altoslib/AltosFlightListener.java deleted file mode 100644 index d61831a9..00000000 --- a/altoslib/AltosFlightListener.java +++ /dev/null @@ -1,162 +0,0 @@ -/* - * Copyright © 2017 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -package org.altusmetrum.altoslib_12; - -public abstract class AltosFlightListener { - - public int flight; - public int serial; - public int tick; - public int boost_tick; - public int state; - - public double accel_plus_g; - public double accel_minus_g; - public double accel; - - public double ground_pressure; - public double ground_altitude; - - AltosGPS temp_gps; - int temp_gps_sat_tick; - int gps_sequence; - - /* AltosEepromRecord */ - public void set_boost_tick(int boost_tick) { - if (boost_tick != AltosLib.MISSING) - this.boost_tick = boost_tick; - } - - public void set_tick(int tick) { - if (tick != AltosLib.MISSING) - this.tick = tick; - } - - public double time() { - if (tick == AltosLib.MISSING) - return AltosLib.MISSING; - if (boost_tick != AltosLib.MISSING) - return (tick - boost_tick) / 100.0; - else - return tick / 100.0; - } - - public double boost_time() { - if (boost_tick == AltosLib.MISSING) - return AltosLib.MISSING; - return boost_tick / 100.0; - } - - public abstract void set_rssi(int rssi, int status); - public abstract void set_received_time(long received_time); - - /* AltosEepromRecordFull */ - - public void set_serial(int serial) { - if (serial != AltosLib.MISSING) - this.serial = serial; - } - - public void set_state(int state) { - if (state != AltosLib.MISSING) - this.state = state; - } - - public int state() { return state; } - - public abstract void set_ground_accel(double ground_accel); - public void set_flight(int flight) { - if (flight != AltosLib.MISSING) - this.flight = flight; - } - public int flight() { - return flight; - } - - public abstract void set_accel(double accel); - public abstract void set_acceleration(double accel); - public abstract void set_accel_g(double accel_plus_g, double accel_minus_g); - public abstract void set_pressure(double pa); - public abstract void set_thrust(double N); - - public abstract void set_temperature(double deg_c); - public abstract void set_battery_voltage(double volts); - - public abstract void set_apogee_voltage(double volts); - public abstract void set_main_voltage(double volts); - - public void set_temp_gps() { - temp_gps = null; - } - - public boolean gps_pending() { - return temp_gps != null; - } - - public AltosGPS make_temp_gps(boolean sats) { - if (temp_gps == null) { - temp_gps = new AltosGPS(); - } - if (sats) { - if (tick != temp_gps_sat_tick) - temp_gps.cc_gps_sat = null; - temp_gps_sat_tick = tick; - } - return temp_gps; - } - - public void set_ground_pressure(double ground_pressure) { - if (ground_pressure != AltosLib.MISSING) { - this.ground_pressure = ground_pressure; - this.ground_altitude = AltosConvert.pressure_to_altitude(ground_pressure); - } - } - - public abstract void set_accel_ground(double along, double across, double through); - public abstract void set_gyro_zero(double roll, double pitch, double yaw); - public abstract void check_imu_wrap(AltosIMU imu); - public abstract void set_imu(AltosIMU imu); - public abstract void set_mag(AltosMag mag); - public abstract void set_pyro_voltage(double volts); - public abstract void set_igniter_voltage(double[] voltage); - public abstract void set_pyro_fired(int pyro_mask); - - public void copy(AltosFlightListener old) { - flight = old.flight; - serial = old.serial; - tick = old.tick; - boost_tick = old.boost_tick; - accel_plus_g = old.accel_plus_g; - accel_minus_g = old.accel_minus_g; - ground_pressure = old.ground_pressure; - ground_altitude = old.ground_altitude; - temp_gps = old.temp_gps; - temp_gps_sat_tick = old.temp_gps_sat_tick; - } - - public void init() { - flight = AltosLib.MISSING; - serial = AltosLib.MISSING; - tick = AltosLib.MISSING; - boost_tick = AltosLib.MISSING; - accel_plus_g = AltosLib.MISSING; - accel_minus_g = AltosLib.MISSING; - accel = AltosLib.MISSING; - ground_pressure = AltosLib.MISSING; - ground_altitude = AltosLib.MISSING; - temp_gps = null; - temp_gps_sat_tick = AltosLib.MISSING; - } -} diff --git a/altoslib/AltosFlightSeries.java b/altoslib/AltosFlightSeries.java index 2eaf8033..d130d3ad 100644 --- a/altoslib/AltosFlightSeries.java +++ b/altoslib/AltosFlightSeries.java @@ -532,6 +532,7 @@ public class AltosFlightSeries extends AltosDataListener { public static final String gps_hdop_name = "GPS Horizontal Dilution of Precision"; public void set_gps(AltosGPS gps) { + super.set_gps(gps); if (gps_series == null) gps_series = new ArrayList(); gps_series.add(new AltosGPSTimeValue(time(), gps)); diff --git a/altoslib/AltosReplayReader.java b/altoslib/AltosReplayReader.java index 24b425b7..7ce4197b 100644 --- a/altoslib/AltosReplayReader.java +++ b/altoslib/AltosReplayReader.java @@ -70,7 +70,7 @@ class AltosReplay extends AltosDataListener implements Runnable { public void set_apogee_voltage(double volts) { state.set_apogee_voltage(volts); } public void set_main_voltage(double volts) { state.set_main_voltage(volts); } - public void set_gps(AltosGPS gps) { state.set_gps(gps); } + public void set_gps(AltosGPS gps) { super.set_gps(gps); state.set_gps(gps); } public void set_orient(double orient) { state.set_orient(orient); } public void set_gyro(double roll, double pitch, double yaw) { state.set_gyro(roll, pitch, yaw); } diff --git a/altoslib/AltosState.java b/altoslib/AltosState.java index 54c70094..68097faf 100644 --- a/altoslib/AltosState.java +++ b/altoslib/AltosState.java @@ -887,6 +887,7 @@ public class AltosState extends AltosDataListener { } public void set_gps(AltosGPS gps) { + super.set_gps(gps); if (gps != null) { this.gps = gps; update_gps(); diff --git a/altoslib/AltosTelemetryLocation.java b/altoslib/AltosTelemetryLocation.java index f4366e33..e2925a58 100644 --- a/altoslib/AltosTelemetryLocation.java +++ b/altoslib/AltosTelemetryLocation.java @@ -54,7 +54,7 @@ public class AltosTelemetryLocation extends AltosTelemetryStandard { AltosCalData cal_data = listener.cal_data(); - AltosGPS gps = cal_data.make_temp_gps(tick(), false); + AltosGPS gps = listener.make_temp_gps(false); int flags = flags(); gps.nsat = flags & 0xf; @@ -77,12 +77,7 @@ public class AltosTelemetryLocation extends AltosTelemetryStandard { gps.ground_speed = ground_speed() * 1.0e-2; gps.course = course() * 2; gps.climb_rate = climb_rate() * 1.0e-2; - - if (gps.nsat >= 4) - cal_data.set_gps(gps); } listener.set_gps(gps); - cal_data.set_gps(gps); - cal_data.reset_temp_gps(); } } diff --git a/altoslib/AltosTelemetrySatellite.java b/altoslib/AltosTelemetrySatellite.java index 60bc4a51..0965df9f 100644 --- a/altoslib/AltosTelemetrySatellite.java +++ b/altoslib/AltosTelemetrySatellite.java @@ -49,10 +49,9 @@ public class AltosTelemetrySatellite extends AltosTelemetryStandard { AltosCalData cal_data = listener.cal_data(); - AltosGPS gps = cal_data.make_temp_gps(tick(), true); + AltosGPS gps = listener.make_temp_gps(true); gps.cc_gps_sat = sats(); listener.set_gps(gps); - cal_data.reset_temp_gps(); } } -- cgit v1.2.3 From 15af16ad21f67019065763a93d52cea6097a69d1 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 22 Oct 2017 15:39:25 -0500 Subject: altos: Remove cross-block storage I/O on cc1111 We don't ever need to be able to do storage read/write across chunks of flash on the old cc1111 products, so remove the loops that support it to save space. Signed-off-by: Keith Packard --- src/cc1111/Makefile.cc1111 | 2 +- src/kernel/ao_storage.c | 161 ++++++++++++++++++++++++++++++++++++++++++++- 2 files changed, 161 insertions(+), 2 deletions(-) diff --git a/src/cc1111/Makefile.cc1111 b/src/cc1111/Makefile.cc1111 index 0ea30e1d..cb2d3db4 100644 --- a/src/cc1111/Makefile.cc1111 +++ b/src/cc1111/Makefile.cc1111 @@ -1,7 +1,7 @@ include ../Makedefs CC=$(SDCC) -CFLAGS=--model-small --debug --opt-code-speed -DCODESIZE=$(CODESIZE) +CFLAGS=--model-small --debug --opt-code-speed -DCODESIZE=$(CODESIZE) -DCC1111 CFLAGS += $(PRODUCT_DEF) -I. -I.. -I../kernel -I../cc1111 -I../drivers -I../product diff --git a/src/kernel/ao_storage.c b/src/kernel/ao_storage.c index bee9293e..400751de 100644 --- a/src/kernel/ao_storage.c +++ b/src/kernel/ao_storage.c @@ -22,6 +22,9 @@ uint8_t ao_storage_read(ao_pos_t pos, __xdata void *buf, uint16_t len) __reentrant { +#ifdef CC1111 + return ao_storage_device_read(pos, buf, len); +#else uint16_t this_len; uint16_t this_off; @@ -47,11 +50,15 @@ ao_storage_read(ao_pos_t pos, __xdata void *buf, uint16_t len) __reentrant pos += this_len; } return 1; +#endif } uint8_t ao_storage_write(ao_pos_t pos, __xdata void *buf, uint16_t len) __reentrant { +#ifdef CC1111 + return ao_storage_device_write(pos, buf, len); +#else uint16_t this_len; uint16_t this_off; @@ -77,9 +84,10 @@ ao_storage_write(ao_pos_t pos, __xdata void *buf, uint16_t len) __reentrant pos += this_len; } return 1; +#endif } -static __xdata uint8_t storage_data[8]; +static __xdata uint8_t storage_data[128]; static void ao_storage_dump(void) __reentrant @@ -159,6 +167,154 @@ ao_storage_zapall(void) __reentrant ao_storage_erase(pos); } +#if AO_STORAGE_TEST + +static void +ao_storage_failure(uint32_t pos, char *format, ...) +{ + va_list a; + printf("TEST FAILURE AT %08x: ", pos); + va_start(a, format); + vprintf(format, a); + va_end(a); +} + +static uint8_t +ao_storage_check_block(uint32_t pos, uint8_t value) +{ + uint32_t offset; + uint32_t byte; + + for (offset = 0; offset < ao_storage_block; offset += sizeof (storage_data)) { + if (!ao_storage_read(pos + offset, storage_data, sizeof (storage_data))) { + ao_storage_failure(pos + offset, "read failed\n"); + return 0; + } + for (byte = 0; byte < sizeof (storage_data); byte++) + if (storage_data[byte] != value) { + ao_storage_failure(pos + offset + byte, + "want %02x got %02x\n", + value, storage_data[byte]); + return 0; + } + } + return 1; +} + +static uint8_t +ao_storage_fill_block(uint32_t pos, uint8_t value) +{ + uint32_t offset; + uint32_t byte; + + for (byte = 0; byte < sizeof (storage_data); byte++) + storage_data[byte] = value; + for (offset = 0; offset < ao_storage_block; offset += sizeof (storage_data)) { + if (!ao_storage_write(pos + offset, storage_data, sizeof (storage_data))) { + ao_storage_failure(pos + offset, "write failed\n"); + return 0; + } + } + return 1; +} + +static uint8_t +ao_storage_check_incr_block(uint32_t pos) +{ + uint32_t offset; + uint32_t byte; + + for (offset = 0; offset < ao_storage_block; offset += sizeof (storage_data)) { + if (!ao_storage_read(pos + offset, storage_data, sizeof (storage_data))) { + ao_storage_failure(pos + offset, "read failed\n"); + return 0; + } + for (byte = 0; byte < sizeof (storage_data); byte++) { + uint8_t value = offset + byte; + if (storage_data[byte] != value) { + ao_storage_failure(pos + offset + byte, + "want %02x got %02x\n", + value, storage_data[byte]); + return 0; + } + } + } + return 1; +} + +static uint8_t +ao_storage_fill_incr_block(uint32_t pos) +{ + uint32_t offset; + uint32_t byte; + + for (offset = 0; offset < ao_storage_block; offset += sizeof (storage_data)) { + for (byte = 0; byte < sizeof (storage_data); byte++) + storage_data[byte] = offset + byte; + if (!ao_storage_write(pos + offset, storage_data, sizeof (storage_data))) { + ao_storage_failure(pos + offset, "write failed\n"); + return 0; + } + } + return 1; +} + +static uint8_t +ao_storage_fill_check_block(uint32_t pos, uint8_t value) +{ + return ao_storage_fill_block(pos, value) && ao_storage_check_block(pos, value); +} + +static uint8_t +ao_storage_incr_check_block(uint32_t pos) +{ + return ao_storage_fill_incr_block(pos) && ao_storage_check_incr_block(pos); +} + +static uint8_t +ao_storage_test_block(uint32_t pos) __reentrant +{ + ao_storage_erase(pos); + printf(" erase"); flush(); + if (!ao_storage_check_block(pos, 0xff)) + return 0; + printf(" zero"); flush(); + if (!ao_storage_fill_check_block(pos, 0x00)) + return 0; + ao_storage_erase(pos); + printf(" 0xaa"); flush(); + if (!ao_storage_fill_check_block(pos, 0xaa)) + return 0; + ao_storage_erase(pos); + printf(" 0x55"); flush(); + if (!ao_storage_fill_check_block(pos, 0x55)) + return 0; + ao_storage_erase(pos); + printf(" increment"); flush(); + if (!ao_storage_incr_check_block(pos)) + return 0; + ao_storage_erase(pos); + printf(" pass\n"); flush(); + return 1; +} + +static void +ao_storage_test(void) __reentrant +{ + uint32_t pos; + + ao_cmd_white(); + if (!ao_match_word("DoIt")) + return; + for (pos = 0; pos < ao_storage_log_max; pos += ao_storage_block) { + printf("Testing block 0x%08x:", pos); flush(); + if (!ao_storage_test_block(pos)) + break; + } + printf("Test complete\n"); +} +#endif /* AO_STORAGE_TEST */ + void ao_storage_info(void) __reentrant { @@ -176,6 +332,9 @@ __code struct ao_cmds ao_storage_cmds[] = { #endif { ao_storage_zap, "z \0Erase " }, { ao_storage_zapall,"Z \0Erase all. is doit with D&I" }, +#if AO_STORAGE_TEST + { ao_storage_test, "V \0Validate flash (destructive). is doit with D&I" }, +#endif { 0, NULL }, }; -- cgit v1.2.3 From 256ddea8c430b4b5dcb8bb95c19ad26032129e1b Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 22 Oct 2017 15:43:07 -0500 Subject: altos: Define AO_LOG_FORMAT in */ao_pins.h. Use in ao_cmd.c Instead of having a global variable define the log format, use a macro instead to save data space. Signed-off-by: Keith Packard --- src/cc1111/ao_pins.h | 5 +++++ src/easymega-v1.0/ao_pins.h | 4 +++- src/kernel/ao_cmd.c | 2 +- src/teleballoon-v2.0/ao_pins.h | 1 + src/telegps-v0.3/ao_pins.h | 1 + src/telegps-v1.0/ao_pins.h | 1 + src/telegps-v2.0/ao_pins.h | 1 + src/telemega-v0.1/ao_pins.h | 1 + src/telemega-v1.0/ao_pins.h | 1 + src/telemega-v2.0/ao_pins.h | 1 + src/telemetrum-v2.0/ao_pins.h | 1 + src/telemetrum-v3.0/ao_pins.h | 1 + src/telescience-v0.2/ao_pins.h | 1 + src/teleterra-v0.2/ao_pins.h | 2 ++ 14 files changed, 21 insertions(+), 2 deletions(-) diff --git a/src/cc1111/ao_pins.h b/src/cc1111/ao_pins.h index 10b1f802..9d6e1c1d 100644 --- a/src/cc1111/ao_pins.h +++ b/src/cc1111/ao_pins.h @@ -63,6 +63,7 @@ #define HAS_RADIO_RATE 0 /* not enough space for this */ #define HAS_MUTEX_TRY 0 #define HAS_TASK_INFO 0 /* not enough space for this either */ + #define AO_LOG_FORMAT AO_LOG_FORMAT_FULL #endif #if defined(TELEMETRUM_V_1_1) @@ -106,6 +107,7 @@ #define HAS_TELEMETRY 1 #define HAS_RADIO_RATE 0 /* not enough space for this */ #define HAS_MUTEX_TRY 0 + #define AO_LOG_FORMAT AO_LOG_FORMAT_FULL #endif #if defined(TELEMETRUM_V_1_2) @@ -149,6 +151,7 @@ #define HAS_TELEMETRY 1 #define HAS_RADIO_RATE 0 /* not enough space for this */ #define HAS_MUTEX_TRY 0 + #define AO_LOG_FORMAT AO_LOG_FORMAT_FULL #endif #if defined(TELEDONGLE_V_0_2) @@ -210,6 +213,7 @@ #define HAS_MONITOR 0 #define HAS_TELEMETRY 1 #define HAS_RADIO_RATE 0 /* not enough space for this */ + #define AO_LOG_FORMAT AO_LOG_FORMAT_TINY #endif #if defined(TELENANO_V_0_1) @@ -274,6 +278,7 @@ #define HAS_TELEMETRY 1 #define HAS_RADIO_RATE 0 /* not enough space for this */ #define AO_CONFIG_DEFAULT_FLIGHT_LOG_MAX ((uint32_t) 127 * (uint32_t) 1024) + #define AO_LOG_FORMAT AO_LOG_FORMAT_FULL #endif #if defined(TELEDONGLE_V_0_1) diff --git a/src/easymega-v1.0/ao_pins.h b/src/easymega-v1.0/ao_pins.h index 42a8b09c..b8016478 100644 --- a/src/easymega-v1.0/ao_pins.h +++ b/src/easymega-v1.0/ao_pins.h @@ -69,6 +69,8 @@ #define AO_CONFIG_MAX_SIZE 1024 #define LOG_ERASE_MARK 0x55 #define LOG_MAX_ERASE 128 +#define AO_LOG_FORMAT AO_LOG_FORMAT_TELEMEGA + #define HAS_EEPROM 1 #define USE_INTERNAL_FLASH 0 #define USE_EEPROM_CONFIG 1 @@ -84,7 +86,7 @@ #define HAS_SPI_1 1 #define SPI_1_PA5_PA6_PA7 1 /* Barometer */ #define SPI_1_PB3_PB4_PB5 1 /* Accelerometer, Gyro */ -#define SPI_1_PE13_PE14_PE15 0 +#define SPI_1_PE13_PE14_PE15 0 #define SPI_1_OSPEEDR STM_OSPEEDR_10MHz #define HAS_SPI_2 1 diff --git a/src/kernel/ao_cmd.c b/src/kernel/ao_cmd.c index 881f3500..c1e9cef2 100644 --- a/src/kernel/ao_cmd.c +++ b/src/kernel/ao_cmd.c @@ -304,7 +304,7 @@ version(void) , ao_flight_number #endif #if HAS_LOG - , ao_log_format + , AO_LOG_FORMAT #if !DISABLE_LOG_SPACE , (unsigned long) ao_storage_log_max #endif diff --git a/src/teleballoon-v2.0/ao_pins.h b/src/teleballoon-v2.0/ao_pins.h index 746bb3ee..d98e85d7 100644 --- a/src/teleballoon-v2.0/ao_pins.h +++ b/src/teleballoon-v2.0/ao_pins.h @@ -64,6 +64,7 @@ #define AO_CONFIG_MAX_SIZE 1024 #define LOG_ERASE_MARK 0x55 #define LOG_MAX_ERASE 128 +#define AO_LOG_FORMAT AO_LOG_FORMAT_TELEMETRUM #define HAS_EEPROM 1 #define USE_INTERNAL_FLASH 0 diff --git a/src/telegps-v0.3/ao_pins.h b/src/telegps-v0.3/ao_pins.h index 28ae30a4..873474bb 100644 --- a/src/telegps-v0.3/ao_pins.h +++ b/src/telegps-v0.3/ao_pins.h @@ -75,6 +75,7 @@ #define AO_CONFIG_DEFAULT_APRS_INTERVAL 0 #define AO_CONFIG_DEFAULT_RADIO_POWER 0xc0 #define AO_CONFIG_DEFAULT_FLIGHT_LOG_MAX 496 * 1024 +#define AO_LOG_FORMAT AO_LOG_FORMAT_TELEGPS /* * GPS diff --git a/src/telegps-v1.0/ao_pins.h b/src/telegps-v1.0/ao_pins.h index 9672ab03..f3bdc0ac 100644 --- a/src/telegps-v1.0/ao_pins.h +++ b/src/telegps-v1.0/ao_pins.h @@ -77,6 +77,7 @@ #define AO_CONFIG_DEFAULT_APRS_INTERVAL 0 #define AO_CONFIG_DEFAULT_RADIO_POWER 0xc0 +#define AO_LOG_FORMAT AO_LOG_FORMAT_TELEGPS /* * GPS diff --git a/src/telegps-v2.0/ao_pins.h b/src/telegps-v2.0/ao_pins.h index fa175371..a2e812fa 100644 --- a/src/telegps-v2.0/ao_pins.h +++ b/src/telegps-v2.0/ao_pins.h @@ -136,6 +136,7 @@ struct ao_adc { #define AO_CONFIG_DEFAULT_APRS_INTERVAL 0 #define AO_CONFIG_DEFAULT_RADIO_POWER 0xc0 +#define AO_LOG_FORMAT AO_LOG_FORMAT_TELEGPS /* * GPS diff --git a/src/telemega-v0.1/ao_pins.h b/src/telemega-v0.1/ao_pins.h index 11c4267c..94e77f98 100644 --- a/src/telemega-v0.1/ao_pins.h +++ b/src/telemega-v0.1/ao_pins.h @@ -69,6 +69,7 @@ #define AO_CONFIG_MAX_SIZE 1024 #define LOG_ERASE_MARK 0x55 #define LOG_MAX_ERASE 128 +#define AO_LOG_FORMAT AO_LOG_FORMAT_TELEMEGA #define HAS_EEPROM 1 #define USE_INTERNAL_FLASH 0 diff --git a/src/telemega-v1.0/ao_pins.h b/src/telemega-v1.0/ao_pins.h index 4decbbf7..d44394f0 100644 --- a/src/telemega-v1.0/ao_pins.h +++ b/src/telemega-v1.0/ao_pins.h @@ -69,6 +69,7 @@ #define AO_CONFIG_MAX_SIZE 1024 #define LOG_ERASE_MARK 0x55 #define LOG_MAX_ERASE 128 +#define AO_LOG_FORMAT AO_LOG_FORMAT_TELEMEGA #define HAS_EEPROM 1 #define USE_INTERNAL_FLASH 0 diff --git a/src/telemega-v2.0/ao_pins.h b/src/telemega-v2.0/ao_pins.h index c7c8ad19..42c00c94 100644 --- a/src/telemega-v2.0/ao_pins.h +++ b/src/telemega-v2.0/ao_pins.h @@ -69,6 +69,7 @@ #define AO_CONFIG_MAX_SIZE 1024 #define LOG_ERASE_MARK 0x55 #define LOG_MAX_ERASE 128 +#define AO_LOG_FORMAT AO_LOG_FORMAT_TELEMEGA #define HAS_EEPROM 1 #define USE_INTERNAL_FLASH 0 diff --git a/src/telemetrum-v2.0/ao_pins.h b/src/telemetrum-v2.0/ao_pins.h index d9063173..d26a5193 100644 --- a/src/telemetrum-v2.0/ao_pins.h +++ b/src/telemetrum-v2.0/ao_pins.h @@ -64,6 +64,7 @@ #define AO_CONFIG_MAX_SIZE 1024 #define LOG_ERASE_MARK 0x55 #define LOG_MAX_ERASE 128 +#define AO_LOG_FORMAT AO_LOG_FORMAT_TELEMETRUM #define HAS_EEPROM 1 #define USE_INTERNAL_FLASH 0 diff --git a/src/telemetrum-v3.0/ao_pins.h b/src/telemetrum-v3.0/ao_pins.h index b937b422..6d4369c9 100644 --- a/src/telemetrum-v3.0/ao_pins.h +++ b/src/telemetrum-v3.0/ao_pins.h @@ -64,6 +64,7 @@ #define AO_CONFIG_MAX_SIZE 1024 #define LOG_ERASE_MARK 0x55 #define LOG_MAX_ERASE 128 +#define AO_LOG_FORMAT AO_LOG_FORMAT_TELEMETRUM #define HAS_EEPROM 1 #define USE_INTERNAL_FLASH 0 diff --git a/src/telescience-v0.2/ao_pins.h b/src/telescience-v0.2/ao_pins.h index c78766cd..29f16114 100644 --- a/src/telescience-v0.2/ao_pins.h +++ b/src/telescience-v0.2/ao_pins.h @@ -111,6 +111,7 @@ #define HAS_ADC 1 #define HAS_ADC_TEMP 1 #define HAS_LOG 1 +#define AO_LOG_FORMAT AO_LOG_FORMAT_TELESCIENCE /* * SPI Flash memory diff --git a/src/teleterra-v0.2/ao_pins.h b/src/teleterra-v0.2/ao_pins.h index 8d9f7a2f..5bcf2c8a 100644 --- a/src/teleterra-v0.2/ao_pins.h +++ b/src/teleterra-v0.2/ao_pins.h @@ -75,6 +75,8 @@ #define HAS_TELEMETRY 0 #define AO_VALUE_32 0 + + #define AO_LOG_FORMAT AO_LOG_FORMAT_TELEMETRY #endif #if DBG_ON_P1 -- cgit v1.2.3 From 83929cd290279963b01b2ccd52c70d61bdeff6b0 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 22 Oct 2017 15:44:32 -0500 Subject: altos: Share common logging code. Deal with corrupt initial flight records Move common logging APIs from per-format files into ao_log.c. Then, change that code to check the first log record in a slot (containing the flight number) to see if it's invalid and deal with it. That involves not re-using that slot, and allowing it to be erased. Corrupted log blocks are reported with a negative flight number. Signed-off-by: Keith Packard --- src/kernel/ao_gps_report.c | 12 ++-- src/kernel/ao_gps_report_mega.c | 4 +- src/kernel/ao_gps_report_metrum.c | 8 +-- src/kernel/ao_log.c | 125 ++++++++++++++++++++++++++++++++------ src/kernel/ao_log.h | 69 ++++++++++++++++----- src/kernel/ao_log_big.c | 67 ++------------------ src/kernel/ao_log_gps.c | 77 ++++------------------- src/kernel/ao_log_mega.c | 64 ++----------------- src/kernel/ao_log_metrum.c | 65 ++------------------ src/kernel/ao_log_mini.c | 63 +------------------ src/kernel/ao_log_tiny.c | 4 +- 11 files changed, 199 insertions(+), 359 deletions(-) diff --git a/src/kernel/ao_gps_report.c b/src/kernel/ao_gps_report.c index 39688fea..75c2f367 100644 --- a/src/kernel/ao_gps_report.c +++ b/src/kernel/ao_gps_report.c @@ -45,13 +45,13 @@ ao_gps_report(void) gps_log.u.gps_time.minute = gps_data.minute; gps_log.u.gps_time.second = gps_data.second; gps_log.u.gps_time.flags = gps_data.flags; - ao_log_data(&gps_log); + ao_log_write(&gps_log); gps_log.type = AO_LOG_GPS_LAT; gps_log.u.gps_latitude = gps_data.latitude; - ao_log_data(&gps_log); + ao_log_write(&gps_log); gps_log.type = AO_LOG_GPS_LON; gps_log.u.gps_longitude = gps_data.longitude; - ao_log_data(&gps_log); + ao_log_write(&gps_log); gps_log.type = AO_LOG_GPS_ALT; gps_log.u.gps_altitude.altitude_low = gps_data.altitude_low; #if HAS_WIDE_GPS @@ -59,14 +59,14 @@ ao_gps_report(void) #else gps_log.u.gps_altitude.altitude_high = 0xffff; #endif - ao_log_data(&gps_log); + ao_log_write(&gps_log); if (!date_reported && (gps_data.flags & AO_GPS_DATE_VALID)) { gps_log.type = AO_LOG_GPS_DATE; gps_log.u.gps_date.year = gps_data.year; gps_log.u.gps_date.month = gps_data.month; gps_log.u.gps_date.day = gps_data.day; gps_log.u.gps_date.extra = 0; - date_reported = ao_log_data(&gps_log); + date_reported = ao_log_write(&gps_log); } } if (new & AO_GPS_NEW_TRACKING) { @@ -78,7 +78,7 @@ ao_gps_report(void) if ((gps_log.u.gps_sat.svid = gps_tracking_data.sats[c].svid)) { gps_log.u.gps_sat.c_n = gps_tracking_data.sats[c].c_n_1; - ao_log_data(&gps_log); + ao_log_write(&gps_log); } } } diff --git a/src/kernel/ao_gps_report_mega.c b/src/kernel/ao_gps_report_mega.c index 8a298655..85614b85 100644 --- a/src/kernel/ao_gps_report_mega.c +++ b/src/kernel/ao_gps_report_mega.c @@ -105,7 +105,7 @@ ao_gps_report_mega(void) gps_log.u.gps.hdop = gps_data.hdop; gps_log.u.gps.vdop = gps_data.vdop; gps_log.u.gps.mode = gps_data.mode; - ao_log_mega(&gps_log); + ao_log_write(&gps_log); } if ((new & AO_GPS_NEW_TRACKING) && (n = gps_tracking_data.channels) != 0) { gps_log.tick = ao_gps_tick; @@ -120,7 +120,7 @@ ao_gps_report_mega(void) break; } gps_log.u.gps_sat.channels = i; - ao_log_mega(&gps_log); + ao_log_write(&gps_log); } } } diff --git a/src/kernel/ao_gps_report_metrum.c b/src/kernel/ao_gps_report_metrum.c index 508f1519..523fb17f 100644 --- a/src/kernel/ao_gps_report_metrum.c +++ b/src/kernel/ao_gps_report_metrum.c @@ -47,7 +47,7 @@ ao_gps_report_metrum(void) gps_log.u.gps.longitude = gps_data.longitude; gps_log.u.gps.altitude_low = gps_data.altitude_low; gps_log.u.gps.altitude_high = gps_data.altitude_high; - ao_log_metrum(&gps_log); + ao_log_write(&gps_log); gps_log.type = AO_LOG_GPS_TIME; gps_log.u.gps_time.hour = gps_data.hour; @@ -58,7 +58,7 @@ ao_gps_report_metrum(void) gps_log.u.gps_time.month = gps_data.month; gps_log.u.gps_time.day = gps_data.day; gps_log.u.gps_time.pdop = gps_data.pdop; - ao_log_metrum(&gps_log); + ao_log_write(&gps_log); } if ((new & AO_GPS_NEW_TRACKING) && (n = gps_tracking_data.channels)) { @@ -71,7 +71,7 @@ ao_gps_report_metrum(void) if (i == 4) { gps_log.u.gps_sat.channels = i; gps_log.u.gps_sat.more = 1; - ao_log_metrum(&gps_log); + ao_log_write(&gps_log); i = 0; } gps_log.u.gps_sat.sats[i].svid = svid; @@ -82,7 +82,7 @@ ao_gps_report_metrum(void) if (i) { gps_log.u.gps_sat.channels = i; gps_log.u.gps_sat.more = 0; - ao_log_metrum(&gps_log); + ao_log_write(&gps_log); } } } diff --git a/src/kernel/ao_log.c b/src/kernel/ao_log.c index 0589b4b0..08af5b58 100644 --- a/src/kernel/ao_log.c +++ b/src/kernel/ao_log.c @@ -29,7 +29,7 @@ __pdata uint32_t ao_log_end_pos; __pdata uint32_t ao_log_start_pos; __xdata uint8_t ao_log_running; __pdata enum ao_flight_state ao_log_state; -__xdata uint16_t ao_flight_number; +__xdata int16_t ao_flight_number; void ao_log_flush(void) @@ -111,6 +111,85 @@ ao_log_erase_mark(void) ao_config_put(); } +#ifndef AO_LOG_UNCOMMON +/* + * Common logging functions which depend on the type of the log data + * structure. + */ + +__xdata ao_log_type log; + +static uint8_t +ao_log_csum(__xdata uint8_t *b) __reentrant +{ + uint8_t sum = 0x5a; + uint8_t i; + + for (i = 0; i < sizeof (ao_log_type); i++) + sum += *b++; + return -sum; +} + +uint8_t +ao_log_write(__xdata ao_log_type *log) __reentrant +{ + uint8_t wrote = 0; + /* set checksum */ + log->csum = 0; + log->csum = ao_log_csum((__xdata uint8_t *) log); + ao_mutex_get(&ao_log_mutex); { + if (ao_log_current_pos >= ao_log_end_pos && ao_log_running) + ao_log_stop(); + if (ao_log_running) { + wrote = 1; + ao_storage_write(ao_log_current_pos, + log, + sizeof (ao_log_type)); + ao_log_current_pos += sizeof (ao_log_type); + } + } ao_mutex_put(&ao_log_mutex); + return wrote; +} + +uint8_t +ao_log_check_data(void) +{ + if (ao_log_csum((uint8_t *) &log) != 0) + return 0; + return 1; +} + +uint8_t +ao_log_check_clear(void) +{ + uint8_t *b = (uint8_t *) &log; + uint8_t i; + + for (i = 0; i < sizeof (ao_log_type); i++) { + if (*b++ != 0xff) + return 0; + } + return 1; +} + +int16_t +ao_log_flight(uint8_t slot) +{ + if (!ao_storage_read(ao_log_pos(slot), + &log, + sizeof (ao_log_type))) + return -(int16_t) (slot + 1); + + if (ao_log_check_clear()) + return 0; + + if (ao_log_check_data() || log.type != AO_LOG_FLIGHT) + return -(int16_t) (slot + 1); + + return log.u.flight.flight; +} +#endif + static uint8_t ao_log_slots() { @@ -123,21 +202,21 @@ ao_log_pos(uint8_t slot) return ((slot) * ao_config.flight_log_max); } -static uint16_t +static int16_t ao_log_max_flight(void) { uint8_t log_slot; uint8_t log_slots; - uint16_t log_flight; - uint16_t max_flight = 0; + int16_t log_flight; + int16_t max_flight = 0; /* Scan the log space looking for the biggest flight number */ log_slots = ao_log_slots(); for (log_slot = 0; log_slot < log_slots; log_slot++) { log_flight = ao_log_flight(log_slot); - if (!log_flight) + if (log_flight <= 0) continue; - if (max_flight == 0 || (int16_t) (log_flight - max_flight) > 0) + if (max_flight == 0 || log_flight > max_flight) max_flight = log_flight; } return max_flight; @@ -228,24 +307,24 @@ ao_log_scan(void) __reentrant if (ao_flight_number) { uint32_t full = ao_log_current_pos; - uint32_t empty = ao_log_end_pos - ao_log_size; + uint32_t empty = ao_log_end_pos - AO_LOG_SIZE; /* If there's already a flight started, then find the * end of it */ for (;;) { ao_log_current_pos = (full + empty) >> 1; - ao_log_current_pos -= ao_log_current_pos % ao_log_size; + ao_log_current_pos -= ao_log_current_pos % AO_LOG_SIZE; if (ao_log_current_pos == full) { - if (ao_log_check(ao_log_current_pos)) - ao_log_current_pos += ao_log_size; + if (ao_log_check(ao_log_current_pos) != AO_LOG_EMPTY) + ao_log_current_pos += AO_LOG_SIZE; break; } if (ao_log_current_pos == empty) break; - if (ao_log_check(ao_log_current_pos)) { + if (ao_log_check(ao_log_current_pos) != AO_LOG_EMPTY) { full = ao_log_current_pos; } else { empty = ao_log_current_pos; @@ -259,10 +338,11 @@ ao_log_scan(void) __reentrant ao_wakeup(&ao_flight_number); return ret; #else - - if (ao_flight_number) - if (++ao_flight_number == 0) + if (ao_flight_number) { + ++ao_flight_number; + if (ao_flight_number <= 0) ao_flight_number = 1; + } ao_log_find_max_erase_flight(); @@ -330,7 +410,7 @@ ao_log_list(void) __reentrant { uint8_t slot; uint8_t slots; - uint16_t flight; + int16_t flight; slots = ao_log_slots(); for (slot = 0; slot < slots; slot++) @@ -350,18 +430,25 @@ ao_log_delete(void) __reentrant { uint8_t slot; uint8_t slots; + int16_t cmd_flight = 1; + ao_cmd_white(); + if (ao_cmd_lex_c == '-') { + cmd_flight = -1; + ao_cmd_lex(); + } ao_cmd_decimal(); if (ao_cmd_status != ao_cmd_success) return; + cmd_flight *= (int16_t) ao_cmd_lex_i; slots = ao_log_slots(); /* Look for the flight log matching the requested flight */ - if (ao_cmd_lex_i) { + if (cmd_flight) { for (slot = 0; slot < slots; slot++) { - if (ao_log_flight(slot) == ao_cmd_lex_i) { + if (ao_log_flight(slot) == cmd_flight) { #if HAS_TRACKER - ao_tracker_erase_start(ao_cmd_lex_i); + ao_tracker_erase_start(cmd_flight); #endif ao_log_erase(slot); #if HAS_TRACKER @@ -372,7 +459,7 @@ ao_log_delete(void) __reentrant } } } - printf("No such flight: %d\n", ao_cmd_lex_i); + printf("No such flight: %d\n", cmd_flight); } __code struct ao_cmds ao_log_cmds[] = { diff --git a/src/kernel/ao_log.h b/src/kernel/ao_log.h index aca669db..1c186364 100644 --- a/src/kernel/ao_log.h +++ b/src/kernel/ao_log.h @@ -29,7 +29,7 @@ * the log. Tasks may wait for this to be initialized * by sleeping on this variable. */ -extern __xdata uint16_t ao_flight_number; +extern __xdata int16_t ao_flight_number; extern __xdata uint8_t ao_log_mutex; extern __pdata uint32_t ao_log_current_pos; extern __pdata uint32_t ao_log_end_pos; @@ -56,15 +56,25 @@ extern __pdata enum ao_flight_state ao_log_state; #define AO_LOG_FORMAT_EASYMINI2 14 /* 16-byte MS5607 baro only, 3.3V supply, stm32f042 SoC */ #define AO_LOG_FORMAT_NONE 127 /* No log at all */ -extern __code uint8_t ao_log_format; -extern __code uint8_t ao_log_size; +/* Return the flight number from the given log slot, 0 if none, -slot on failure */ -/* Return the flight number from the given log slot, 0 if none */ -uint16_t +int16_t ao_log_flight(uint8_t slot); -/* Check if there is valid log data at the specified location */ +/* Checksum the loaded log record */ +uint8_t +ao_log_check_data(void); + +/* Check to see if the loaded log record is empty */ uint8_t +ao_log_check_clear(void); + +/* Check if there is valid log data at the specified location */ +#define AO_LOG_VALID 1 +#define AO_LOG_EMPTY 0 +#define AO_LOG_INVALID -1 + +int8_t ao_log_check(uint32_t pos); /* Flush the log */ @@ -463,21 +473,48 @@ struct ao_log_gps { } u; }; -/* Write a record to the eeprom log */ -uint8_t -ao_log_data(__xdata struct ao_log_record *log) __reentrant; +#if AO_LOG_FORMAT == AO_LOG_FOMAT_TELEMEGA_OLD || AO_LOG_FORMAT == AO_LOG_FORMAT_TELEMEGA +typedef struct ao_log_mega ao_log_type; +#endif -uint8_t -ao_log_mega(__xdata struct ao_log_mega *log) __reentrant; +#if AO_LOG_FORMAT == AO_LOG_FORMAT_TELEMETRUM +typedef struct ao_log_metrum ao_log_type; +#endif -uint8_t -ao_log_metrum(__xdata struct ao_log_metrum *log) __reentrant; +#if AO_LOG_FORMAT == AO_LOG_FORMAT_EASYMINI1 || AO_LOG_FORMAT == AO_LOG_FORMAT_EASYMINI2 || AO_LOG_FORMAT == AO_LOG_FORMAT_TELEMINI2 || AO_LOG_FORMAT == AO_LOG_FORMAT_TELEMINI3 +typedef struct ao_log_mini ao_log_type; +#endif -uint8_t -ao_log_mini(__xdata struct ao_log_mini *log) __reentrant; +#if AO_LOG_FORMAT == AO_LOG_FORMAT_TELEGPS +typedef struct ao_log_gps ao_log_type; +#endif + +#if AO_LOG_FORMAT == AO_LOG_FORMAT_FULL +typedef struct ao_log_record ao_log_type; +#endif + +#if AO_LOG_FORMAT == AO_LOG_FORMAT_TINY +#define AO_LOG_UNCOMMON 1 +#endif + +#if AO_LOG_FORMAT == AO_LOG_FORMAT_TELEMETRY +#define AO_LOG_UNCOMMON 1 +#endif + +#if AO_LOG_FORMAT == AO_LOG_FORMAT_TELESCIENCE +#define AO_LOG_UNCOMMON 1 +#endif + +#ifndef AO_LOG_UNCOMMON +extern __xdata ao_log_type log; + +#define AO_LOG_SIZE sizeof(ao_log_type) + +/* Write a record to the eeprom log */ uint8_t -ao_log_gps(__xdata struct ao_log_gps *log) __reentrant; +ao_log_write(__xdata ao_log_type *log) __reentrant; +#endif void ao_log_flush(void); diff --git a/src/kernel/ao_log_big.c b/src/kernel/ao_log_big.c index e32abd1a..28a893c7 100644 --- a/src/kernel/ao_log_big.c +++ b/src/kernel/ao_log_big.c @@ -18,50 +18,6 @@ #include "ao.h" -static __xdata struct ao_log_record log; - -__code uint8_t ao_log_format = AO_LOG_FORMAT_FULL; - -static uint8_t -ao_log_csum(__xdata uint8_t *b) __reentrant -{ - uint8_t sum = 0x5a; - uint8_t i; - - for (i = 0; i < sizeof (struct ao_log_record); i++) - sum += *b++; - return -sum; -} - -uint8_t -ao_log_data(__xdata struct ao_log_record *log) __reentrant -{ - uint8_t wrote = 0; - /* set checksum */ - log->csum = 0; - log->csum = ao_log_csum((__xdata uint8_t *) log); - ao_mutex_get(&ao_log_mutex); { - if (ao_log_current_pos >= ao_log_end_pos && ao_log_running) - ao_log_stop(); - if (ao_log_running) { - wrote = 1; - ao_storage_write(ao_log_current_pos, - log, - sizeof (struct ao_log_record)); - ao_log_current_pos += sizeof (struct ao_log_record); - } - } ao_mutex_put(&ao_log_mutex); - return wrote; -} - -static uint8_t -ao_log_dump_check_data(void) -{ - if (ao_log_csum((uint8_t *) &log) != 0) - return 0; - return 1; -} - static __data uint8_t ao_log_data_pos; /* a hack to make sure that ao_log_records fill the eeprom block in even units */ @@ -91,7 +47,7 @@ ao_log(void) log.u.flight.ground_accel = ao_ground_accel; #endif log.u.flight.flight = ao_flight_number; - ao_log_data(&log); + ao_log_write(&log); /* Write the whole contents of the ring to the log * when starting up. @@ -107,7 +63,7 @@ ao_log(void) log.type = AO_LOG_SENSOR; log.u.sensor.accel = ao_data_ring[ao_log_data_pos].adc.accel; log.u.sensor.pres = ao_data_ring[ao_log_data_pos].adc.pres; - ao_log_data(&log); + ao_log_write(&log); if (ao_log_state <= ao_flight_coast) next_sensor = log.tick + AO_SENSOR_INTERVAL_ASCENT; else @@ -117,11 +73,11 @@ ao_log(void) log.type = AO_LOG_TEMP_VOLT; log.u.temp_volt.temp = ao_data_ring[ao_log_data_pos].adc.temp; log.u.temp_volt.v_batt = ao_data_ring[ao_log_data_pos].adc.v_batt; - ao_log_data(&log); + ao_log_write(&log); log.type = AO_LOG_DEPLOY; log.u.deploy.drogue = ao_data_ring[ao_log_data_pos].adc.sense_d; log.u.deploy.main = ao_data_ring[ao_log_data_pos].adc.sense_m; - ao_log_data(&log); + ao_log_write(&log); next_other = log.tick + AO_OTHER_INTERVAL; } ao_log_data_pos = ao_data_ring_next(ao_log_data_pos); @@ -133,7 +89,7 @@ ao_log(void) log.tick = ao_sample_tick; log.u.state.state = ao_log_state; log.u.state.reason = 0; - ao_log_data(&log); + ao_log_write(&log); if (ao_log_state == ao_flight_landed) ao_log_stop(); @@ -147,16 +103,3 @@ ao_log(void) ao_sleep(&ao_log_running); } } - -uint16_t -ao_log_flight(uint8_t slot) -{ - if (!ao_storage_read(ao_log_pos(slot), - &log, - sizeof (struct ao_log_record))) - return 0; - - if (ao_log_dump_check_data() && log.type == AO_LOG_FLIGHT) - return log.u.flight.flight; - return 0; -} diff --git a/src/kernel/ao_log_gps.c b/src/kernel/ao_log_gps.c index 02551169..a55d93f1 100644 --- a/src/kernel/ao_log_gps.c +++ b/src/kernel/ao_log_gps.c @@ -24,50 +24,13 @@ #include #include -static __xdata struct ao_log_gps log; - -__code uint8_t ao_log_format = AO_LOG_FORMAT_TELEGPS; -__code uint8_t ao_log_size = sizeof (struct ao_log_gps); - -static uint8_t -ao_log_csum(__xdata uint8_t *b) __reentrant -{ - uint8_t sum = 0x5a; - uint8_t i; - - for (i = 0; i < sizeof (struct ao_log_gps); i++) - sum += *b++; - return -sum; -} - -uint8_t -ao_log_gps(__xdata struct ao_log_gps *log) __reentrant -{ - uint8_t wrote = 0; - /* set checksum */ - log->csum = 0; - log->csum = ao_log_csum((__xdata uint8_t *) log); - ao_mutex_get(&ao_log_mutex); { - if (ao_log_current_pos >= ao_log_end_pos && ao_log_running) - ao_log_stop(); - if (ao_log_running) { - wrote = 1; - ao_storage_write(ao_log_current_pos, - log, - sizeof (struct ao_log_gps)); - ao_log_current_pos += sizeof (struct ao_log_gps); - } - } ao_mutex_put(&ao_log_mutex); - return wrote; -} - void ao_log_gps_flight(void) { log.type = AO_LOG_FLIGHT; log.tick = ao_time(); log.u.flight.flight = ao_flight_number; - ao_log_gps(&log); + ao_log_write(&log); } void @@ -94,7 +57,7 @@ ao_log_gps_data(uint16_t tick, struct ao_telemetry_location *gps_data) log.u.gps.hdop = gps_data->hdop; log.u.gps.vdop = gps_data->vdop; log.u.gps.mode = gps_data->mode; - ao_log_gps(&log); + ao_log_write(&log); } void @@ -115,39 +78,21 @@ ao_log_gps_tracking(uint16_t tick, struct ao_telemetry_satellite *gps_tracking_d break; } log.u.gps_sat.channels = i; - ao_log_gps(&log); + ao_log_write(&log); } -static uint8_t -ao_log_dump_check_data(void) -{ - if (ao_log_csum((uint8_t *) &log) != 0) - return 0; - return 1; -} - -uint16_t -ao_log_flight(uint8_t slot) -{ - if (!ao_storage_read(ao_log_pos(slot), - &log, - sizeof (struct ao_log_gps))) - return 0; - - if (ao_log_dump_check_data() && log.type == AO_LOG_FLIGHT) - return log.u.flight.flight; - return 0; -} - -uint8_t +int8_t ao_log_check(uint32_t pos) { if (!ao_storage_read(pos, &log, sizeof (struct ao_log_gps))) - return 0; + return AO_LOG_INVALID; + + if (ao_log_check_clear()) + return AO_LOG_EMPTY; - if (ao_log_dump_check_data()) - return 1; - return 0; + if (!ao_log_check_data()) + return AO_LOG_INVALID; + return AO_LOG_VALID; } diff --git a/src/kernel/ao_log_mega.c b/src/kernel/ao_log_mega.c index b86abe7a..d1cf4f13 100644 --- a/src/kernel/ao_log_mega.c +++ b/src/kernel/ao_log_mega.c @@ -21,50 +21,6 @@ #include #include -static __xdata struct ao_log_mega log; - -__code uint8_t ao_log_format = AO_LOG_FORMAT_TELEMEGA; - -static uint8_t -ao_log_csum(__xdata uint8_t *b) __reentrant -{ - uint8_t sum = 0x5a; - uint8_t i; - - for (i = 0; i < sizeof (struct ao_log_mega); i++) - sum += *b++; - return -sum; -} - -uint8_t -ao_log_mega(__xdata struct ao_log_mega *log) __reentrant -{ - uint8_t wrote = 0; - /* set checksum */ - log->csum = 0; - log->csum = ao_log_csum((__xdata uint8_t *) log); - ao_mutex_get(&ao_log_mutex); { - if (ao_log_current_pos >= ao_log_end_pos && ao_log_running) - ao_log_stop(); - if (ao_log_running) { - wrote = 1; - ao_storage_write(ao_log_current_pos, - log, - sizeof (struct ao_log_mega)); - ao_log_current_pos += sizeof (struct ao_log_mega); - } - } ao_mutex_put(&ao_log_mutex); - return wrote; -} - -static uint8_t -ao_log_dump_check_data(void) -{ - if (ao_log_csum((uint8_t *) &log) != 0) - return 0; - return 1; -} - #if HAS_FLIGHT static __data uint8_t ao_log_data_pos; @@ -106,7 +62,7 @@ ao_log(void) #endif log.u.flight.ground_pres = ao_ground_pres; log.u.flight.flight = ao_flight_number; - ao_log_mega(&log); + ao_log_write(&log); #endif /* Write the whole contents of the ring to the log @@ -139,7 +95,7 @@ ao_log(void) log.u.sensor.mag_y = ao_data_ring[ao_log_data_pos].hmc5883.y; #endif log.u.sensor.accel = ao_data_accel(&ao_data_ring[ao_log_data_pos]); - ao_log_mega(&log); + ao_log_write(&log); if (ao_log_state <= ao_flight_coast) next_sensor = log.tick + AO_SENSOR_INTERVAL_ASCENT; else @@ -153,7 +109,7 @@ ao_log(void) for (i = 0; i < AO_ADC_NUM_SENSE; i++) log.u.volt.sense[i] = ao_data_ring[ao_log_data_pos].adc.sense[i]; log.u.volt.pyro = ao_pyro_fired; - ao_log_mega(&log); + ao_log_write(&log); next_other = log.tick + AO_OTHER_INTERVAL; } ao_log_data_pos = ao_data_ring_next(ao_log_data_pos); @@ -166,7 +122,7 @@ ao_log(void) log.tick = ao_time(); log.u.state.state = ao_log_state; log.u.state.reason = 0; - ao_log_mega(&log); + ao_log_write(&log); if (ao_log_state == ao_flight_landed) ao_log_stop(); @@ -185,15 +141,3 @@ ao_log(void) } #endif /* HAS_FLIGHT */ -uint16_t -ao_log_flight(uint8_t slot) -{ - if (!ao_storage_read(ao_log_pos(slot), - &log, - sizeof (struct ao_log_mega))) - return 0; - - if (ao_log_dump_check_data() && log.type == AO_LOG_FLIGHT) - return log.u.flight.flight; - return 0; -} diff --git a/src/kernel/ao_log_metrum.c b/src/kernel/ao_log_metrum.c index 154b1740..afb8f637 100644 --- a/src/kernel/ao_log_metrum.c +++ b/src/kernel/ao_log_metrum.c @@ -21,50 +21,6 @@ #include #include -static __xdata struct ao_log_metrum log; - -__code uint8_t ao_log_format = AO_LOG_FORMAT_TELEMETRUM; - -static uint8_t -ao_log_csum(__xdata uint8_t *b) __reentrant -{ - uint8_t sum = 0x5a; - uint8_t i; - - for (i = 0; i < sizeof (struct ao_log_metrum); i++) - sum += *b++; - return -sum; -} - -uint8_t -ao_log_metrum(__xdata struct ao_log_metrum *log) __reentrant -{ - uint8_t wrote = 0; - /* set checksum */ - log->csum = 0; - log->csum = ao_log_csum((__xdata uint8_t *) log); - ao_mutex_get(&ao_log_mutex); { - if (ao_log_current_pos >= ao_log_end_pos && ao_log_running) - ao_log_stop(); - if (ao_log_running) { - wrote = 1; - ao_storage_write(ao_log_current_pos, - log, - sizeof (struct ao_log_metrum)); - ao_log_current_pos += sizeof (struct ao_log_metrum); - } - } ao_mutex_put(&ao_log_mutex); - return wrote; -} - -static uint8_t -ao_log_dump_check_data(void) -{ - if (ao_log_csum((uint8_t *) &log) != 0) - return 0; - return 1; -} - #if HAS_ADC static __data uint8_t ao_log_data_pos; @@ -97,7 +53,7 @@ ao_log(void) #endif log.u.flight.ground_pres = ao_ground_pres; log.u.flight.flight = ao_flight_number; - ao_log_metrum(&log); + ao_log_write(&log); #endif /* Write the whole contents of the ring to the log @@ -119,7 +75,7 @@ ao_log(void) #if HAS_ACCEL log.u.sensor.accel = ao_data_accel(&ao_data_ring[ao_log_data_pos]); #endif - ao_log_metrum(&log); + ao_log_write(&log); if (ao_log_state <= ao_flight_coast) next_sensor = log.tick + AO_SENSOR_INTERVAL_ASCENT; else @@ -130,7 +86,7 @@ ao_log(void) log.u.volt.v_batt = ao_data_ring[ao_log_data_pos].adc.v_batt; log.u.volt.sense_a = ao_data_ring[ao_log_data_pos].adc.sense_a; log.u.volt.sense_m = ao_data_ring[ao_log_data_pos].adc.sense_m; - ao_log_metrum(&log); + ao_log_write(&log); next_other = log.tick + AO_OTHER_INTERVAL; } ao_log_data_pos = ao_data_ring_next(ao_log_data_pos); @@ -143,7 +99,7 @@ ao_log(void) log.tick = ao_time(); log.u.state.state = ao_log_state; log.u.state.reason = 0; - ao_log_metrum(&log); + ao_log_write(&log); if (ao_log_state == ao_flight_landed) ao_log_stop(); @@ -161,16 +117,3 @@ ao_log(void) } } #endif - -uint16_t -ao_log_flight(uint8_t slot) -{ - if (!ao_storage_read(ao_log_pos(slot), - &log, - sizeof (struct ao_log_metrum))) - return 0; - - if (ao_log_dump_check_data() && log.type == AO_LOG_FLIGHT) - return log.u.flight.flight; - return 0; -} diff --git a/src/kernel/ao_log_mini.c b/src/kernel/ao_log_mini.c index d5735cdc..af2fa605 100644 --- a/src/kernel/ao_log_mini.c +++ b/src/kernel/ao_log_mini.c @@ -21,50 +21,6 @@ #include #include -static __xdata struct ao_log_mini log; - -__code uint8_t ao_log_format = AO_LOG_FORMAT; - -static uint8_t -ao_log_csum(__xdata uint8_t *b) __reentrant -{ - uint8_t sum = 0x5a; - uint8_t i; - - for (i = 0; i < sizeof (struct ao_log_mini); i++) - sum += *b++; - return -sum; -} - -uint8_t -ao_log_mini(__xdata struct ao_log_mini *log) __reentrant -{ - uint8_t wrote = 0; - /* set checksum */ - log->csum = 0; - log->csum = ao_log_csum((__xdata uint8_t *) log); - ao_mutex_get(&ao_log_mutex); { - if (ao_log_current_pos >= ao_log_end_pos && ao_log_running) - ao_log_stop(); - if (ao_log_running) { - wrote = 1; - ao_storage_write(ao_log_current_pos, - log, - sizeof (struct ao_log_mini)); - ao_log_current_pos += sizeof (struct ao_log_mini); - } - } ao_mutex_put(&ao_log_mutex); - return wrote; -} - -static uint8_t -ao_log_dump_check_data(void) -{ - if (ao_log_csum((uint8_t *) &log) != 0) - return 0; - return 1; -} - static __data uint8_t ao_log_data_pos; /* a hack to make sure that ao_log_minis fill the eeprom block in even units */ @@ -92,7 +48,7 @@ ao_log(void) log.tick = ao_sample_tick; log.u.flight.flight = ao_flight_number; log.u.flight.ground_pres = ao_ground_pres; - ao_log_mini(&log); + ao_log_write(&log); #endif /* Write the whole contents of the ring to the log @@ -116,7 +72,7 @@ ao_log(void) log.u.sensor.sense_m = ao_data_ring[ao_log_data_pos].adc.sense_m; log.u.sensor.v_batt = ao_data_ring[ao_log_data_pos].adc.v_batt; #endif - ao_log_mini(&log); + ao_log_write(&log); if (ao_log_state <= ao_flight_coast) next_sensor = log.tick + AO_SENSOR_INTERVAL_ASCENT; else @@ -132,7 +88,7 @@ ao_log(void) log.tick = ao_time(); log.u.state.state = ao_log_state; log.u.state.reason = 0; - ao_log_mini(&log); + ao_log_write(&log); if (ao_log_state == ao_flight_landed) ao_log_stop(); @@ -149,16 +105,3 @@ ao_log(void) ao_sleep(&ao_log_running); } } - -uint16_t -ao_log_flight(uint8_t slot) -{ - if (!ao_storage_read(ao_log_pos(slot), - &log, - sizeof (struct ao_log_mini))) - return 0; - - if (ao_log_dump_check_data() && log.type == AO_LOG_FLIGHT) - return log.u.flight.flight; - return 0; -} diff --git a/src/kernel/ao_log_tiny.c b/src/kernel/ao_log_tiny.c index 7769b7b5..0b8e39d6 100644 --- a/src/kernel/ao_log_tiny.c +++ b/src/kernel/ao_log_tiny.c @@ -29,8 +29,6 @@ static __data uint16_t ao_log_tiny_interval; #define AO_PAD_RING 2 #endif -__code uint8_t ao_log_format = AO_LOG_FORMAT_TINY; - void ao_log_tiny_set_interval(uint16_t ticks) { @@ -149,7 +147,7 @@ ao_log(void) } } -uint16_t +int16_t ao_log_flight(uint8_t slot) { static __xdata uint16_t flight; -- cgit v1.2.3 From 5460d7ff46116901bceacd43282b406c446dded5 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 2 Nov 2017 09:11:39 -0700 Subject: altos: whitespace cleanup in ao_adc_stm.c Signed-off-by: Keith Packard --- src/stm/ao_adc_stm.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/stm/ao_adc_stm.c b/src/stm/ao_adc_stm.c index 77f121dc..c3cca5e4 100644 --- a/src/stm/ao_adc_stm.c +++ b/src/stm/ao_adc_stm.c @@ -377,7 +377,7 @@ ao_adc_init(void) #if AO_NUM_ADC > 18 #error "need to finish stm_adc.sqr settings" #endif - + /* Turn ADC on */ stm_adc.cr2 = AO_ADC_CR2_VAL; -- cgit v1.2.3 From 82e552d194216b41d27d805bee2947127c2d555b Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 2 Nov 2017 09:12:18 -0700 Subject: altos/stm: Add AO_EXTI_MODE_PULL_NONE This is clearer than using '0'. Signed-off-by: Keith Packard --- src/stm/ao_exti.h | 1 + 1 file changed, 1 insertion(+) diff --git a/src/stm/ao_exti.h b/src/stm/ao_exti.h index 4f3e6132..8aa2bdca 100644 --- a/src/stm/ao_exti.h +++ b/src/stm/ao_exti.h @@ -21,6 +21,7 @@ #define AO_EXTI_MODE_RISING 1 #define AO_EXTI_MODE_FALLING 2 +#define AO_EXTI_MODE_PULL_NONE 0 #define AO_EXTI_MODE_PULL_UP 4 #define AO_EXTI_MODE_PULL_DOWN 8 #define AO_EXTI_PRIORITY_LOW 16 -- cgit v1.2.3 From 5b6805d1a6a91a26a1892f414a99f0184871ac1a Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 11 Nov 2017 16:08:32 -0800 Subject: altosuilib: New line styles and colors for graphs. Selectable line width Improve the readability of graphs by offering a better selection of colors and adding line styles. Let the user configure the line width as desired. Signed-off-by: Keith Packard --- altosuilib/AltosEepromGrapher.java | 22 +++++++ altosuilib/AltosGraph.java | 116 ++++++++++++++++++++---------------- altosuilib/AltosShapeListener.java | 1 + altosuilib/AltosUIAxis.java | 23 +++---- altosuilib/AltosUIEnable.java | 36 ++++++++++- altosuilib/AltosUIFlightSeries.java | 52 +++++++++------- altosuilib/AltosUIGraph.java | 13 ++-- altosuilib/AltosUILineStyle.java | 84 ++++++++++++++++++++++++++ altosuilib/AltosUITimeSeries.java | 54 +++++++++++------ altosuilib/Makefile.am | 2 + 10 files changed, 297 insertions(+), 106 deletions(-) create mode 100644 altosuilib/AltosEepromGrapher.java create mode 100644 altosuilib/AltosUILineStyle.java diff --git a/altosuilib/AltosEepromGrapher.java b/altosuilib/AltosEepromGrapher.java new file mode 100644 index 00000000..a29f64ea --- /dev/null +++ b/altosuilib/AltosEepromGrapher.java @@ -0,0 +1,22 @@ +/* + * Copyright © 2017 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +package org.altusmetrum.altosuilib_12; + +import org.altusmetrum.altoslib_12.*; + +public interface AltosEepromGrapher { + + public void graph_flights(AltosEepromList list); +} diff --git a/altosuilib/AltosGraph.java b/altosuilib/AltosGraph.java index 3f610285..a758bcde 100644 --- a/altosuilib/AltosGraph.java +++ b/altosuilib/AltosGraph.java @@ -37,47 +37,53 @@ import org.jfree.data.*; public class AltosGraph extends AltosUIGraph { - static final private Color height_color = new Color(194,31,31); - static final private Color kalman_height_color = new Color(255,0,0); - static final private Color gps_height_color = new Color(150,31,31); - static final private Color pressure_color = new Color (225,31,31); - static final private Color range_color = new Color(100, 31, 31); - static final private Color distance_color = new Color(100, 31, 194); - static final private Color speed_color = new Color(31,194,31); - static final private Color kalman_speed_color = new Color(0,255,0); - static final private Color thrust_color = new Color(31,194,31); - static final private Color accel_color = new Color(31,31,194); - static final private Color vert_accel_color = new Color(64,164,164); - static final private Color kalman_accel_color = new Color(0,0,255); - static final private Color voltage_color = new Color(194, 194, 31); - static final private Color battery_voltage_color = new Color(194, 194, 31); - static final private Color drogue_voltage_color = new Color(150, 150, 31); - static final private Color main_voltage_color = new Color(100, 100, 31); - static final private Color igniter_voltage_color = new Color(80, 80, 31); - static final private Color igniter_marker_color = new Color(255, 0, 0); - static final private Color gps_nsat_color = new Color (194, 31, 194); - static final private Color gps_nsat_solution_color = new Color (194, 31, 194); - static final private Color gps_nsat_view_color = new Color (150, 31, 150); - static final private Color gps_course_color = new Color (100, 31, 112); - static final private Color gps_ground_speed_color = new Color (31, 112, 100); - static final private Color gps_speed_color = new Color (31, 112, 100); - static final private Color gps_climb_rate_color = new Color (31, 31, 112); - static final private Color gps_pdop_color = new Color(50, 194, 0); - static final private Color gps_hdop_color = new Color(50, 0, 194); - static final private Color gps_vdop_color = new Color(194, 0, 50); - static final private Color temperature_color = new Color (31, 194, 194); - static final private Color dbm_color = new Color(31, 100, 100); - static final private Color state_color = new Color(0,0,0); - static final private Color accel_along_color = new Color(255, 0, 0); - static final private Color accel_across_color = new Color(0, 255, 0); - static final private Color accel_through_color = new Color(0, 0, 255); - static final private Color gyro_roll_color = new Color(192, 0, 0); - static final private Color gyro_pitch_color = new Color(0, 192, 0); - static final private Color gyro_yaw_color = new Color(0, 0, 192); - static final private Color mag_along_color = new Color(128, 0, 0); - static final private Color mag_across_color = new Color(0, 128, 0); - static final private Color mag_through_color = new Color(0, 0, 128); - static final private Color orient_color = new Color(31, 31, 31); + /* These are in 'priority' order so that earlier ones get simpler line styles, + * then they are grouped so that adjacent ones get sequential colors + */ + static final private AltosUILineStyle height_color = new AltosUILineStyle(); + static final private AltosUILineStyle speed_color = new AltosUILineStyle(); + static final private AltosUILineStyle accel_color = new AltosUILineStyle(); + static final private AltosUILineStyle vert_accel_color = new AltosUILineStyle(); + static final private AltosUILineStyle orient_color = new AltosUILineStyle(); + + static final private AltosUILineStyle gps_height_color = new AltosUILineStyle(); + static final private AltosUILineStyle altitude_color = new AltosUILineStyle(); + + static final private AltosUILineStyle battery_voltage_color = new AltosUILineStyle(); + static final private AltosUILineStyle pyro_voltage_color = new AltosUILineStyle(); + static final private AltosUILineStyle drogue_voltage_color = new AltosUILineStyle(); + static final private AltosUILineStyle main_voltage_color = new AltosUILineStyle(); + static final private AltosUILineStyle igniter_marker_color = new AltosUILineStyle(1); + + static final private AltosUILineStyle kalman_height_color = new AltosUILineStyle(); + static final private AltosUILineStyle kalman_speed_color = new AltosUILineStyle(); + static final private AltosUILineStyle kalman_accel_color = new AltosUILineStyle(); + + static final private AltosUILineStyle gps_nsat_color = new AltosUILineStyle (); + static final private AltosUILineStyle gps_nsat_solution_color = new AltosUILineStyle (); + static final private AltosUILineStyle gps_nsat_view_color = new AltosUILineStyle (); + static final private AltosUILineStyle gps_course_color = new AltosUILineStyle (); + static final private AltosUILineStyle gps_ground_speed_color = new AltosUILineStyle (); + static final private AltosUILineStyle gps_speed_color = new AltosUILineStyle (); + static final private AltosUILineStyle gps_climb_rate_color = new AltosUILineStyle (); + static final private AltosUILineStyle gps_pdop_color = new AltosUILineStyle(); + static final private AltosUILineStyle gps_hdop_color = new AltosUILineStyle(); + static final private AltosUILineStyle gps_vdop_color = new AltosUILineStyle(); + + static final private AltosUILineStyle temperature_color = new AltosUILineStyle (); + static final private AltosUILineStyle dbm_color = new AltosUILineStyle(); + static final private AltosUILineStyle pressure_color = new AltosUILineStyle (); + + static final private AltosUILineStyle state_color = new AltosUILineStyle(0); + static final private AltosUILineStyle accel_along_color = new AltosUILineStyle(); + static final private AltosUILineStyle accel_across_color = new AltosUILineStyle(); + static final private AltosUILineStyle accel_through_color = new AltosUILineStyle(); + static final private AltosUILineStyle gyro_roll_color = new AltosUILineStyle(); + static final private AltosUILineStyle gyro_pitch_color = new AltosUILineStyle(); + static final private AltosUILineStyle gyro_yaw_color = new AltosUILineStyle(); + static final private AltosUILineStyle mag_along_color = new AltosUILineStyle(); + static final private AltosUILineStyle mag_across_color = new AltosUILineStyle(); + static final private AltosUILineStyle mag_through_color = new AltosUILineStyle(); static AltosUnits dop_units = null; static AltosUnits tick_units = null; @@ -88,7 +94,7 @@ public class AltosGraph extends AltosUIGraph { AltosCalData cal_data = flight_series.cal_data(); AltosUIAxis height_axis, speed_axis, accel_axis, voltage_axis, temperature_axis, nsat_axis, dbm_axis; - AltosUIAxis distance_axis, pressure_axis, thrust_axis; + AltosUIAxis pressure_axis, thrust_axis; AltosUIAxis gyro_axis, orient_axis, mag_axis; AltosUIAxis course_axis, dop_axis, tick_axis; @@ -98,15 +104,14 @@ public class AltosGraph extends AltosUIGraph { height_axis = newAxis("Height", AltosConvert.height, height_color); pressure_axis = newAxis("Pressure", AltosConvert.pressure, pressure_color, 0); speed_axis = newAxis("Speed", AltosConvert.speed, speed_color); - thrust_axis = newAxis("Thrust", AltosConvert.force, thrust_color); + thrust_axis = newAxis("Thrust", AltosConvert.force, accel_color); tick_axis = newAxis("Tick", tick_units, accel_color, 0); accel_axis = newAxis("Acceleration", AltosConvert.accel, accel_color); - voltage_axis = newAxis("Voltage", AltosConvert.voltage, voltage_color); + voltage_axis = newAxis("Voltage", AltosConvert.voltage, battery_voltage_color); temperature_axis = newAxis("Temperature", AltosConvert.temperature, temperature_color, 0); nsat_axis = newAxis("Satellites", null, gps_nsat_color, AltosUIAxis.axis_include_zero | AltosUIAxis.axis_integer); dbm_axis = newAxis("Signal Strength", null, dbm_color, 0); - distance_axis = newAxis("Distance", AltosConvert.distance, range_color); gyro_axis = newAxis("Rotation Rate", AltosConvert.rotation_rate, gyro_roll_color, 0); orient_axis = newAxis("Tilt Angle", AltosConvert.orient, orient_color, 0); @@ -177,7 +182,7 @@ public class AltosGraph extends AltosUIGraph { height_axis); flight_series.register_axis(AltosUIFlightSeries.altitude_name, - height_color, + altitude_color, false, height_axis); @@ -197,6 +202,11 @@ public class AltosGraph extends AltosUIGraph { false, voltage_axis); + flight_series.register_axis(AltosUIFlightSeries.pyro_voltage_name, + pyro_voltage_color, + false, + voltage_axis); + flight_series.register_axis(AltosUIFlightSeries.apogee_voltage_name, drogue_voltage_color, false, @@ -312,17 +322,19 @@ public class AltosGraph extends AltosUIGraph { false, orient_axis); - for (int channel = 0; channel < 26; channel++) { + flight_series.register_axis(AltosUIFlightSeries.thrust_name, + accel_color, + true, + thrust_axis); + + for (int channel = 0; channel < 8; channel++) { flight_series.register_axis(flight_series.igniter_voltage_name(channel), - igniter_voltage_color, + new AltosUILineStyle(), false, voltage_axis); } - flight_series.register_axis(AltosUIFlightSeries.thrust_name, - thrust_color, - true, - thrust_axis); + flight_series.check_axes(); return flight_series.series(cal_data); } diff --git a/altosuilib/AltosShapeListener.java b/altosuilib/AltosShapeListener.java index 082b6135..6bf52fd4 100644 --- a/altosuilib/AltosShapeListener.java +++ b/altosuilib/AltosShapeListener.java @@ -16,4 +16,5 @@ package org.altusmetrum.altosuilib_12; public interface AltosShapeListener { void set_shapes_visible(boolean visible); + void set_line_width(float width); } diff --git a/altosuilib/AltosUIAxis.java b/altosuilib/AltosUIAxis.java index fe94f161..52873363 100644 --- a/altosuilib/AltosUIAxis.java +++ b/altosuilib/AltosUIAxis.java @@ -36,12 +36,12 @@ import org.jfree.data.xy.*; import org.jfree.data.*; public class AltosUIAxis extends NumberAxis { - String label; - AltosUnits units; - Color color; - int ref; - int visible; - int index; + String label; + AltosUnits units; + AltosUILineStyle line_style; + int ref; + int visible; + int index; public final static int axis_integer = 1; public final static int axis_include_zero = 2; @@ -82,21 +82,22 @@ public class AltosUIAxis extends NumberAxis { } } - public AltosUIAxis(String label, AltosUnits units, Color color, int index, int flags) { + public AltosUIAxis(String label, AltosUnits units, AltosUILineStyle line_style, int index, int flags) { this.label = label; this.units = units; + this.line_style = line_style; this.index = index; this.visible = 0; this.ref = 0; - setLabelPaint(color); - setTickLabelPaint(color); + setLabelPaint(line_style.color); + setTickLabelPaint(line_style.color); setVisible(false); if ((flags & axis_integer) != 0) setStandardTickUnits(NumberAxis.createIntegerTickUnits()); setAutoRangeIncludesZero((flags & axis_include_zero) != 0); } - public AltosUIAxis(String label, AltosUnits units, Color color, int index) { - this(label, units, color, index, axis_default); + public AltosUIAxis(String label, AltosUnits units, AltosUILineStyle line_style, int index) { + this(label, units, line_style, index, axis_default); } } diff --git a/altosuilib/AltosUIEnable.java b/altosuilib/AltosUIEnable.java index ed1e6c53..851e831f 100644 --- a/altosuilib/AltosUIEnable.java +++ b/altosuilib/AltosUIEnable.java @@ -44,6 +44,8 @@ public class AltosUIEnable extends Container implements ChangeListener { int x; JCheckBox imperial_units; JCheckBox show_shapes; + JLabel line_width_label; + JSpinner line_width; JLabel speed_filter_label; JSlider speed_filter; JLabel accel_filter_label; @@ -114,11 +116,15 @@ public class AltosUIEnable extends Container implements ChangeListener { } public void set_shapes_visible(boolean visible) { - System.out.printf("set shapes %b\n", visible); if (shape_listener != null) shape_listener.set_shapes_visible(visible); } + public void set_line_width(float width) { + if (shape_listener != null) + shape_listener.set_line_width(width); + } + public void register_shape_listener(AltosShapeListener shape_listener) { this.shape_listener = shape_listener; } @@ -160,6 +166,34 @@ public class AltosUIEnable extends Container implements ChangeListener { add(show_shapes, c); + line_width_label = new JLabel("Line Width"); + c = new GridBagConstraints(); + c.gridx = 1; c.gridy = 1001; + c.fill = GridBagConstraints.NONE; + c.anchor = GridBagConstraints.LINE_START; + c.insets = il; + add(line_width_label, c); + + line_width = new JSpinner(); + line_width.setValue(new Integer(1)); + line_width.addChangeListener(new ChangeListener() { + public void stateChanged(ChangeEvent e) { + int w = (Integer) line_width.getValue(); + if (w < 1) { + w = 1; + line_width.setValue(new Integer(w)); + } + System.out.printf("line width set to %d\n", w); + set_line_width(w); + } + }); + c = new GridBagConstraints(); + c.gridx = 2; c.gridy = 1001; + c.fill = GridBagConstraints.NONE; + c.anchor = GridBagConstraints.LINE_START; + c.insets = il; + add(line_width, c); + speed_filter_label = new JLabel("Speed Filter(ms)"); c = new GridBagConstraints(); c.gridx = 0; c.gridy = 1002; diff --git a/altosuilib/AltosUIFlightSeries.java b/altosuilib/AltosUIFlightSeries.java index 19bed609..407e5ab4 100644 --- a/altosuilib/AltosUIFlightSeries.java +++ b/altosuilib/AltosUIFlightSeries.java @@ -30,15 +30,16 @@ import org.jfree.data.xy.*; import org.jfree.data.*; class AltosUITimeSeriesAxis { - Color color; - boolean enabled; - boolean marker; - boolean marker_top; - AltosUIAxis axis; - XYPlot plot; - - public AltosUITimeSeriesAxis(Color color, boolean enabled, AltosUIAxis axis, XYPlot plot, boolean marker, boolean marker_top) { - this.color = color; + AltosUILineStyle line_style; + boolean enabled; + boolean marker; + boolean marker_top; + AltosUIAxis axis; + XYPlot plot; + + public AltosUITimeSeriesAxis(AltosUILineStyle line_style, boolean enabled, + AltosUIAxis axis, XYPlot plot, boolean marker, boolean marker_top) { + this.line_style = line_style; this.enabled = enabled; this.axis = axis; this.plot = plot; @@ -51,26 +52,34 @@ public class AltosUIFlightSeries extends AltosFlightSeries { Hashtable axes; - AltosUIFlightSeries flight_series; - void fill_axes(String label, AltosUITimeSeriesAxis axis) { for (AltosTimeSeries ts : series) { AltosUITimeSeries uts = (AltosUITimeSeries) ts; - if (label.equals(ts.label) || (label.equals("default") && uts.color == null)) { + if (label.equals(ts.label) || (label.equals("default") && uts.line_style == null)) { + uts.custom_axis_set = true; if (axis.marker) - uts.set_marker(axis.color, axis.enabled, axis.plot, axis.marker_top); + uts.set_marker(axis.line_style, axis.enabled, axis.plot, axis.marker_top); else - uts.set_axis(axis.color, axis.enabled, axis.axis); + uts.set_axis(axis.line_style, axis.enabled, axis.axis); } } } + void check_axes() { + for (AltosTimeSeries ts : series) { + AltosUITimeSeries uts = (AltosUITimeSeries) ts; + + if (!uts.custom_axis_set) + System.out.printf("%s using default axis\n", ts.label); + } + } + public void register_axis(String label, - Color color, + AltosUILineStyle line_style, boolean enabled, AltosUIAxis axis) { - AltosUITimeSeriesAxis tsa = new AltosUITimeSeriesAxis(color, + AltosUITimeSeriesAxis tsa = new AltosUITimeSeriesAxis(line_style, enabled, axis, null, @@ -81,11 +90,11 @@ public class AltosUIFlightSeries extends AltosFlightSeries { } public void register_marker(String label, - Color color, + AltosUILineStyle line_style, boolean enabled, XYPlot plot, boolean marker_top) { - AltosUITimeSeriesAxis tsa = new AltosUITimeSeriesAxis(color, + AltosUITimeSeriesAxis tsa = new AltosUITimeSeriesAxis(line_style, enabled, null, plot, @@ -97,17 +106,18 @@ public class AltosUIFlightSeries extends AltosFlightSeries { public AltosTimeSeries make_series(String label, AltosUnits units) { - AltosUITimeSeries time_series = new AltosUITimeSeries(label, units); AltosUITimeSeriesAxis tsa = axes.get(label); if (tsa == null) tsa = axes.get("default"); + else + time_series.custom_axis_set = true; if (tsa != null) { if (tsa.marker) - time_series.set_marker(tsa.color, tsa.enabled, tsa.plot, tsa.marker_top); + time_series.set_marker(tsa.line_style, tsa.enabled, tsa.plot, tsa.marker_top); else - time_series.set_axis(tsa.color, tsa.enabled, tsa.axis); + time_series.set_axis(tsa.line_style, tsa.enabled, tsa.axis); } return time_series; } diff --git a/altosuilib/AltosUIGraph.java b/altosuilib/AltosUIGraph.java index 6328d40a..40f415f1 100644 --- a/altosuilib/AltosUIGraph.java +++ b/altosuilib/AltosUIGraph.java @@ -56,14 +56,14 @@ public class AltosUIGraph implements AltosUnitsListener, AltosShapeListener { return panel; } - public AltosUIAxis newAxis(String label, AltosUnits units, Color color, int flags) { - AltosUIAxis axis = new AltosUIAxis(label, units, color, axis_index++, flags); + public AltosUIAxis newAxis(String label, AltosUnits units, AltosUILineStyle line_style, int flags) { + AltosUIAxis axis = new AltosUIAxis(label, units, line_style, axis_index++, flags); plot.setRangeAxis(axis.index, axis); return axis; } - public AltosUIAxis newAxis(String label, AltosUnits units, Color color) { - return newAxis(label, units, color, AltosUIAxis.axis_default); + public AltosUIAxis newAxis(String label, AltosUnits units, AltosUILineStyle line_style) { + return newAxis(label, units, line_style, AltosUIAxis.axis_default); } void addAxis(AltosUIAxis axis) { @@ -104,6 +104,11 @@ public class AltosUIGraph implements AltosUnitsListener, AltosShapeListener { s.set_shapes_visible(visible); } + public void set_line_width(float width) { + for (AltosUITimeSeries s : series) + s.set_line_width(width); + } + public void setName (String name) { chart.setTitle(name); } diff --git a/altosuilib/AltosUILineStyle.java b/altosuilib/AltosUILineStyle.java new file mode 100644 index 00000000..387281a3 --- /dev/null +++ b/altosuilib/AltosUILineStyle.java @@ -0,0 +1,84 @@ +/* + * Copyright © 2017 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +package org.altusmetrum.altosuilib_12; + +import java.io.*; +import java.util.ArrayList; + +import java.awt.*; +import javax.swing.*; +import org.altusmetrum.altoslib_12.*; + +import org.jfree.ui.*; +import org.jfree.chart.*; +import org.jfree.chart.plot.*; +import org.jfree.chart.axis.*; +import org.jfree.chart.renderer.*; +import org.jfree.chart.renderer.xy.*; +import org.jfree.chart.labels.*; +import org.jfree.data.xy.*; +import org.jfree.data.*; + +public class AltosUILineStyle { + public Color color; + public float[] dash; + + static private Color color(int r, int g, int b) { + return new Color(r,g,b); + } + + static final private Color[] colors = { + new Color(0,0,0), + new Color(230,0,0), // red + new Color(216,103,0), // orange + new Color(200,200,0), // yellow + new Color(0,180,0), // green + new Color(0,140,140), // cyan + new Color(130,0,0), // dark red + new Color(0,100,0), // dark green + new Color(0,0,255), // blue + new Color(140,0,140), // magenta + new Color(150,150,150), // gray + }; + + static final private float[][] dashes = { + { 0 }, + { 2, 4 }, + { 4, 4 }, + { 6, 4 }, + { 6, 4, 2, 4 } + }; + + static int color_index, dash_index; + + public AltosUILineStyle () { + color = colors[color_index]; + dash = dashes[dash_index]; + color_index = (color_index + 1) % colors.length; + if (color_index == 0) { + dash_index = (dash_index + 1) % dashes.length; + if (dash_index == 0) + System.out.printf("too many line styles\n"); + } + } + + public AltosUILineStyle(int index) { + index = index % (colors.length * dashes.length); + int c = index % colors.length; + int d = index / colors.length; + color = colors[c]; + dash = dashes[d]; + } +} diff --git a/altosuilib/AltosUITimeSeries.java b/altosuilib/AltosUITimeSeries.java index b98c8376..e85e3c17 100644 --- a/altosuilib/AltosUITimeSeries.java +++ b/altosuilib/AltosUITimeSeries.java @@ -61,16 +61,17 @@ class AltosXYSeries extends XYSeries { } public class AltosUITimeSeries extends AltosTimeSeries implements AltosUIGrapher { - Color color; - boolean enable; - AltosUIAxis axis; - boolean marker; - boolean marker_top; + AltosUILineStyle line_style; + boolean enable; + boolean custom_axis_set; + AltosUIAxis axis; + boolean marker; + boolean marker_top; XYLineAndShapeRenderer renderer; - XYPlot plot; - AltosXYSeries xy_series; + XYPlot plot; + AltosXYSeries xy_series; ArrayList markers; - + float width; /* AltosUIGrapher interface */ public boolean need_reset() { @@ -107,7 +108,8 @@ public class AltosUITimeSeries extends AltosTimeSeries implements AltosUIGrapher marker.setLabelAnchor(RectangleAnchor.BOTTOM_RIGHT); marker.setLabelTextAnchor(TextAnchor.BOTTOM_LEFT); } - marker.setPaint(color); + marker.setPaint(line_style.color); + marker.setStroke(new BasicStroke(width, BasicStroke.CAP_BUTT, BasicStroke.JOIN_BEVEL)); if (enable) plot.addDomainMarker(marker); markers.add(marker); @@ -165,23 +167,41 @@ public class AltosUITimeSeries extends AltosTimeSeries implements AltosUIGrapher } } - public void set_axis(Color color, boolean enable, AltosUIAxis axis) { - this.color = color; + // public BasicStroke(float width, int cap, int join, float miterlimit, + // float dash[], float dash_phase) + + public void set_line_width(float width) { + this.width = width; + if (markers != null) { + for (ValueMarker marker : markers) { + marker.setStroke(new BasicStroke(width, BasicStroke.CAP_BUTT, BasicStroke.JOIN_BEVEL)); + } + } else { + if (line_style.dash[0] == 0.0) + renderer.setSeriesStroke(0, new BasicStroke(width, BasicStroke.CAP_ROUND, BasicStroke.JOIN_ROUND)); + else + renderer.setSeriesStroke(0, new BasicStroke(width, BasicStroke.CAP_ROUND, BasicStroke.JOIN_ROUND, 10.0f, line_style.dash, 0.0f)); + } + } + + public void set_axis(AltosUILineStyle line_style, boolean enable, AltosUIAxis axis) { + this.line_style = line_style; this.enable = enable; this.axis = axis; this.marker = false; + this.width = 1.0f; axis.ref(this.enable); renderer = new XYLineAndShapeRenderer(true, false); - renderer.setSeriesPaint(0, color); - renderer.setSeriesStroke(0, new BasicStroke(2, BasicStroke.CAP_ROUND, BasicStroke.JOIN_ROUND)); + renderer.setSeriesPaint(0, line_style.color); + set_line_width(this.width); renderer.setSeriesVisible(0, enable); xy_series = new AltosXYSeries(label); } - public void set_marker(Color color, boolean enable, XYPlot plot, boolean marker_top) { - this.color = color; + public void set_marker(AltosUILineStyle line_style, boolean enable, XYPlot plot, boolean marker_top) { + this.line_style = line_style; this.enable = enable; this.marker = true; this.plot = plot; @@ -197,9 +217,9 @@ public class AltosUITimeSeries extends AltosTimeSeries implements AltosUIGrapher } public AltosUITimeSeries(String label, AltosUnits units, - Color color, boolean enable, + AltosUILineStyle line_style, boolean enable, AltosUIAxis axis) { this(label, units); - set_axis(color, enable, axis); + set_axis(line_style, enable, axis); } } diff --git a/altosuilib/Makefile.am b/altosuilib/Makefile.am index 0f606225..c65a3d15 100644 --- a/altosuilib/Makefile.am +++ b/altosuilib/Makefile.am @@ -41,6 +41,7 @@ altosuilib_JAVA = \ AltosConfigFreqUI.java \ AltosScanUI.java \ AltosEepromDelete.java \ + AltosEepromGrapher.java \ AltosEepromManage.java \ AltosEepromMonitorUI.java \ AltosEepromSelect.java \ @@ -57,6 +58,7 @@ altosuilib_JAVA = \ AltosBTDeviceIterator.java \ AltosBTManage.java \ AltosBTKnown.java \ + AltosUILineStyle.java \ AltosUIMap.java \ AltosUIMapPreload.java \ AltosUIFlightTab.java \ -- cgit v1.2.3 From a2097545dec62cd0970725bf690128dad6baf22e Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 11 Nov 2017 16:38:40 -0800 Subject: altos/test: Adapt flight test to int16_t flight number type Flight numbers are now limited to 32767 to allow for negative values for corrupted slots. Signed-off-by: Keith Packard --- src/test/ao_flight_test.c | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src/test/ao_flight_test.c b/src/test/ao_flight_test.c index 298848d6..2d862f82 100644 --- a/src/test/ao_flight_test.c +++ b/src/test/ao_flight_test.c @@ -25,6 +25,7 @@ #include #include #include +#define log ao_log_data #define GRAVITY 9.80665 @@ -370,7 +371,7 @@ extern int16_t ao_accel_2g; typedef int16_t accel_t; uint16_t ao_serial_number; -uint16_t ao_flight_number; +int16_t ao_flight_number; extern uint16_t ao_sample_tick; @@ -998,7 +999,7 @@ main (int argc, char **argv) #else emulator_app="baro"; #endif - while ((c = getopt_long(argc, argv, "sdi:", options, NULL)) != -1) { + while ((c = getopt_long(argc, argv, "sdpi:", options, NULL)) != -1) { switch (c) { case 's': summary = 1; @@ -1006,6 +1007,11 @@ main (int argc, char **argv) case 'd': ao_flight_debug = 1; break; + case 'p': +#if PYRO_DBG + pyro_dbg = 1; +#endif + break; case 'i': info = optarg; break; -- cgit v1.2.3 From e80005ea63bb9b1eee33a8876ad74ed5d50478ed Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 11 Nov 2017 20:44:27 -0800 Subject: altoslib: Don't write KML record when height data is missing This avoids a crash dealing with corrupted flight data Signed-off-by: Keith Packard --- altoslib/AltosKML.java | 34 ++++++++++++++++++++-------------- 1 file changed, 20 insertions(+), 14 deletions(-) diff --git a/altoslib/AltosKML.java b/altoslib/AltosKML.java index aa98f0e6..d5248a17 100644 --- a/altoslib/AltosKML.java +++ b/altoslib/AltosKML.java @@ -308,19 +308,23 @@ public class AltosKML implements AltosWriter { stats = new AltosFlightStats(series); cal_data = series.cal_data(); start(); - folder_start("Barometric Altitude"); - path_style_start("baro", style_color(0)); - out.printf("Barometric Altitude\n"); - out.printf("Max height: %s\n", AltosConvert.height.show(6, stats.max_height)); - path_style_end(); - path_start("Barometric Altitude", "baro"); - for (AltosGPSTimeValue gtv : series.gps_series) - write(gtv.gps, baro_altitude(series, gtv.time)); - path_end(); - for (AltosTimeValue tv : series.state_series) { - write_point(tv, false); + if (series.height_series != null) { + folder_start("Barometric Altitude"); + path_style_start("baro", style_color(0)); + out.printf("Barometric Altitude\n"); + out.printf("Max height: %s\n", AltosConvert.height.show(6, stats.max_height)); + path_style_end(); + path_start("Barometric Altitude", "baro"); + for (AltosGPSTimeValue gtv : series.gps_series) + write(gtv.gps, baro_altitude(series, gtv.time)); + path_end(); + if (series.state_series != null) { + for (AltosTimeValue tv : series.state_series) { + write_point(tv, false); + } + } + folder_end(); } - folder_end(); folder_start("GPS Altitude"); path_style_start("gps", style_color(1)); out.printf("GPS Altitude"); @@ -330,8 +334,10 @@ public class AltosKML implements AltosWriter { for (AltosGPSTimeValue gtv : series.gps_series) write(gtv.gps, gtv.gps.alt); path_end(); - for (AltosTimeValue tv : series.state_series) { - write_point(tv, true); + if (series.state_series != null) { + for (AltosTimeValue tv : series.state_series) { + write_point(tv, true); + } } folder_end(); end(); -- cgit v1.2.3 From 10834eb60f7a44fee159d9e9ad5ffb2e013fe9cf Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 11 Nov 2017 20:46:45 -0800 Subject: altoslib: Remove spurious semicolon in AltosReplayReader.java Signed-off-by: Keith Packard --- altoslib/AltosReplayReader.java | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/altoslib/AltosReplayReader.java b/altoslib/AltosReplayReader.java index 7ce4197b..fab28cac 100644 --- a/altoslib/AltosReplayReader.java +++ b/altoslib/AltosReplayReader.java @@ -31,7 +31,7 @@ class AltosReplay extends AltosDataListener implements Runnable { AltosState state; AltosRecordSet record_set; double last_time = AltosLib.MISSING; - Semaphore semaphore = new Semaphore(1);; + Semaphore semaphore = new Semaphore(1); boolean done = false; public void set_time(double time) { -- cgit v1.2.3 From 9a7b4f02ad32ca43a45ed9fe446b8db96e60b5e5 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 11 Nov 2017 20:49:20 -0800 Subject: altoslib: Improve EEprom download * Catch and report CRC errors * Deal with corrupted flight records * Add ability to immediately graph new data * Check before overwriting existing files Signed-off-by: Keith Packard --- altoslib/AltosEeprom.java | 1 + altoslib/AltosEepromDownload.java | 42 +++++++++++++++----- altoslib/AltosEepromList.java | 4 +- altoslib/AltosEepromLog.java | 18 +++++++-- altoslib/AltosEepromMonitor.java | 6 ++- altoslib/AltosEepromRecord.java | 25 +++++++----- altoslib/AltosEepromRecordSet.java | 6 +-- altoslib/AltosFile.java | 17 +++++++- altosui/AltosUI.java | 13 +++++- altosuilib/AltosEepromDelete.java | 2 +- altosuilib/AltosEepromManage.java | 72 ++++++++++++++++++++------------- altosuilib/AltosEepromMonitorUI.java | 77 +++++++++++++++++------------------- altosuilib/AltosEepromSelect.java | 74 +++++++++++++++++++++++++++++----- telegps/TeleGPS.java | 19 ++++++++- 14 files changed, 260 insertions(+), 116 deletions(-) diff --git a/altoslib/AltosEeprom.java b/altoslib/AltosEeprom.java index ad7bf881..124bd478 100644 --- a/altoslib/AltosEeprom.java +++ b/altoslib/AltosEeprom.java @@ -22,6 +22,7 @@ public class AltosEeprom { private AltosJson config; ArrayList data; private AltosConfigData config_data; + int errors = 0; /* * Public accessor APIs diff --git a/altoslib/AltosEepromDownload.java b/altoslib/AltosEepromDownload.java index 3df8a5b4..547b523f 100644 --- a/altoslib/AltosEepromDownload.java +++ b/altoslib/AltosEepromDownload.java @@ -200,25 +200,47 @@ public class AltosEepromDownload implements Runnable { AltosFile f = MakeFile(flights.config_data.serial, log.flight, name_data); - monitor.set_filename(f.toString()); + log.set_file(f); - FileWriter w = new FileWriter(f); + boolean do_write = true; - eeprom.write(w); - w.close(); + if (f.exists()) + do_write = monitor.check_overwrite(f); + + if (do_write) { + FileWriter w = new FileWriter(f); + + eeprom.write(w); + w.close(); + } + + if (eeprom.errors != 0) + throw new ParseException(String.format("%d CRC Errors", eeprom.errors), 0); + } + + static String label(int flight) { + if (flight < 0) + return "Corrupt"; + else + return "Flight"; + } + + static int flight(int flight) { + if (flight < 0) + return -flight; + return flight; } public void run () { boolean success = false; try { - boolean failed = false; if (remote) link.start_remote(); for (AltosEepromLog log : flights) { parse_errors = null; - if (log.selected) { + if (log.download_selected) { monitor.reset(); try { CaptureLog(log); @@ -226,16 +248,16 @@ public class AltosEepromDownload implements Runnable { LogError(e.getMessage()); } } + success = true; if (parse_errors != null) { - failed = true; - monitor.show_message(String.format("Flight %d download error. Valid log data saved\n%s", - log.flight, + monitor.show_message(String.format("%s %d download error. Valid log data saved\n%s", + label(log.flight), + flight(log.flight), parse_errors), link.name, AltosEepromMonitor.WARNING_MESSAGE); } } - success = !failed; } catch (IOException ee) { monitor.show_message(ee.getLocalizedMessage(), link.name, diff --git a/altoslib/AltosEepromList.java b/altoslib/AltosEepromList.java index 55d47e20..c55bcaaa 100644 --- a/altoslib/AltosEepromList.java +++ b/altoslib/AltosEepromList.java @@ -87,7 +87,7 @@ public class AltosEepromList extends ArrayList { start = AltosParse.parse_hex(tokens[3]); if (tokens[4].equals("end")) end = AltosParse.parse_hex(tokens[5]); - if (flight > 0 && start >= 0 && end > 0) + if (flight != 0 && start >= 0 && end > 0) flights.add(new AltosEepromFlight(flight, start, end)); } catch (ParseException pe) { System.out.printf("Parse error %s\n", pe.toString()); } } @@ -115,4 +115,4 @@ public class AltosEepromList extends ArrayList { link.flush_output(); } } -} \ No newline at end of file +} diff --git a/altoslib/AltosEepromLog.java b/altoslib/AltosEepromLog.java index 8d1f3fc4..ba722b89 100644 --- a/altoslib/AltosEepromLog.java +++ b/altoslib/AltosEepromLog.java @@ -18,6 +18,7 @@ package org.altusmetrum.altoslib_12; +import java.io.*; import java.text.*; import java.util.concurrent.*; @@ -32,7 +33,15 @@ public class AltosEepromLog { public int start_block; public int end_block; - public boolean selected; + public boolean download_selected; + public boolean delete_selected; + public boolean graph_selected; + + public File file; + + public void set_file(File file) { + this.file = file; + } public AltosEepromLog(AltosConfigData config_data, AltosLink link, @@ -50,8 +59,11 @@ public class AltosEepromLog { serial = config_data.serial; /* - * Select all flights for download + * Select all flights for download and graph, but not + * for delete */ - selected = true; + download_selected = true; + delete_selected = false; + graph_selected = true; } } diff --git a/altoslib/AltosEepromMonitor.java b/altoslib/AltosEepromMonitor.java index a99ec687..11144a3a 100644 --- a/altoslib/AltosEepromMonitor.java +++ b/altoslib/AltosEepromMonitor.java @@ -18,6 +18,8 @@ package org.altusmetrum.altoslib_12; +import java.io.*; + public interface AltosEepromMonitor { public void set_block(int in_block); @@ -28,8 +30,6 @@ public interface AltosEepromMonitor { public void set_flight(int in_flight); - public void set_filename(String in_file); - public void set_thread(Thread eeprom_thread); final static int INFO_MESSAGE = 0; @@ -38,6 +38,8 @@ public interface AltosEepromMonitor { public void show_message(String message, String title, int message_type); + public Boolean check_overwrite(File file); + public void start(); public void done(boolean success); diff --git a/altoslib/AltosEepromRecord.java b/altoslib/AltosEepromRecord.java index 12519e6b..43e8ea4d 100644 --- a/altoslib/AltosEepromRecord.java +++ b/altoslib/AltosEepromRecord.java @@ -50,8 +50,22 @@ public abstract class AltosEepromRecord implements Comparable return data8(i) | (data8(i+1) << 8) | (data8(i+2) << 16) | (data8(i+3) << 24); } + public boolean empty(int s) { + for (int i = 0; i < length; i++) + if (eeprom.data8(s + i) != 0xff) + return false; + return true; + } + public boolean valid(int s) { - return AltosConvert.checksum(eeprom.data, s, length) == 0; + int ck = AltosConvert.checksum(eeprom.data, s, length); + + if (ck != 0) { + ++eeprom.errors; + System.out.printf("invalid checksum 0x%x at 0x%x\n", ck, s); + return false; + } + return true; } public boolean valid() { @@ -100,25 +114,18 @@ public abstract class AltosEepromRecord implements Comparable int s = start + length; while (s + length <= eeprom.data.size()) { - if (valid(s)) + if (!empty(s) && valid(s)) return s; s += length; } return -1; } - public boolean hasNext() { - return next_start() >= 0; - } - public abstract AltosEepromRecord next(); public AltosEepromRecord(AltosEeprom eeprom, int start, int length) { this.eeprom = eeprom; this.start = start; this.length = length; - - while (start + length < eeprom.data.size() && !valid()) - start += length; } } diff --git a/altoslib/AltosEepromRecordSet.java b/altoslib/AltosEepromRecordSet.java index d91ae3ac..82a5ea2a 100644 --- a/altoslib/AltosEepromRecordSet.java +++ b/altoslib/AltosEepromRecordSet.java @@ -97,7 +97,7 @@ public class AltosEepromRecordSet implements AltosRecordSet { int tick = 0; boolean first = true; - for (;;) { + do { int t = record.tick(); if (first) { @@ -110,10 +110,8 @@ public class AltosEepromRecordSet implements AltosRecordSet { } record.wide_tick = tick; ordered.add(record); - if (!record.hasNext()) - break; record = record.next(); - } + } while (record != null); } public AltosEepromRecordSet(InputStream input) throws IOException { diff --git a/altoslib/AltosFile.java b/altoslib/AltosFile.java index 69f779c1..6f98b87a 100644 --- a/altoslib/AltosFile.java +++ b/altoslib/AltosFile.java @@ -36,10 +36,23 @@ public class AltosFile extends File { return String.format("-via-%04d", receiver); } + static private String label(int flight) { + if (flight < 0) + return "corrupt"; + else + return "flight"; + } + + static private int flight(int flight) { + if (flight < 0) + return -flight; + return flight; + } + public AltosFile(int year, int month, int day, int serial, int flight, int receiver, String extension) { super (AltosPreferences.logdir(), - String.format("%04d-%02d-%02d-serial-%s-flight-%s%s.%s", - year, month, day, number(serial), number(flight), receiver(receiver), extension)); + String.format("%04d-%02d-%02d-serial-%s-%s-%s%s.%s", + year, month, day, number(serial), label(flight), number(flight(flight)), receiver(receiver), extension)); } public AltosFile(int year, int month, int day, int serial, int flight, String extension) { diff --git a/altosui/AltosUI.java b/altosui/AltosUI.java index bc8eaa71..02e49a94 100644 --- a/altosui/AltosUI.java +++ b/altosui/AltosUI.java @@ -26,7 +26,7 @@ import java.util.concurrent.*; import org.altusmetrum.altoslib_12.*; import org.altusmetrum.altosuilib_12.*; -public class AltosUI extends AltosUIFrame { +public class AltosUI extends AltosUIFrame implements AltosEepromGrapher { public AltosVoice voice = new AltosVoice(); public static boolean load_library(Frame frame) { @@ -320,8 +320,17 @@ public class AltosUI extends AltosUIFrame { /* Connect to TeleMetrum, either directly or through * a TeleDongle over the packet link */ + + public void graph_flights(AltosEepromList flights) { + for (AltosEepromLog flight : flights) { + if (flight.graph_selected && flight.file != null) { + process_graph(flight.file); + } + } + } + private void SaveFlightData() { - new AltosEepromManage(AltosUI.this, AltosLib.product_any); + new AltosEepromManage(this, this, AltosLib.product_any); } private static AltosFlightSeries make_series(AltosRecordSet set) { diff --git a/altosuilib/AltosEepromDelete.java b/altosuilib/AltosEepromDelete.java index 87e80a51..d7dde6df 100644 --- a/altosuilib/AltosEepromDelete.java +++ b/altosuilib/AltosEepromDelete.java @@ -84,7 +84,7 @@ public class AltosEepromDelete implements Runnable { serial_line.start_remote(); for (AltosEepromLog log : flights) { - if (log.selected) { + if (log.delete_selected) { DeleteLog(log); } } diff --git a/altosuilib/AltosEepromManage.java b/altosuilib/AltosEepromManage.java index 93827139..1adf1f0a 100644 --- a/altosuilib/AltosEepromManage.java +++ b/altosuilib/AltosEepromManage.java @@ -33,6 +33,7 @@ public class AltosEepromManage implements ActionListener { AltosEepromList flights; AltosEepromDownload download; AltosEepromDelete delete; + AltosEepromGrapher grapher; public void finish() { if (serial_line != null) { @@ -48,7 +49,7 @@ public class AltosEepromManage implements ActionListener { private int countDeletedFlights() { int count = 0; for (AltosEepromLog flight : flights) { - if (flight.selected) + if (flight.delete_selected) count++; } return count; @@ -58,7 +59,7 @@ public class AltosEepromManage implements ActionListener { String result = ""; for (AltosEepromLog flight : flights) { - if (flight.selected) { + if (flight.delete_selected) { if (result.equals("")) result = String.format("%d", flight.flight); else @@ -68,38 +69,49 @@ public class AltosEepromManage implements ActionListener { return result; } - public boolean download_done() { - AltosEepromSelect select = new AltosEepromSelect(frame, flights, "Delete"); - - if (select.run()) { - boolean any_selected = false; - for (AltosEepromLog flight : flights) - any_selected = any_selected || flight.selected; - if (any_selected) { - delete = new AltosEepromDelete(frame, - serial_line, - remote, - flights); - delete.addActionListener(this); - /* - * Start flight log delete - */ - - delete.start(); - return true; - } + public boolean delete_start() { + + boolean any_selected = false; + for (AltosEepromLog flight : flights) + any_selected = any_selected || flight.delete_selected; + if (any_selected) { + delete = new AltosEepromDelete(frame, + serial_line, + remote, + flights); + delete.addActionListener(this); + /* + * Start flight log delete + */ + + delete.start(); + return true; } return false; } + public void graph_start() { + boolean any_selected = false; + for (AltosEepromLog flight : flights) { + if (!flight.download_selected) + flight.graph_selected = false; + any_selected = any_selected || flight.graph_selected; + } + if (any_selected && grapher != null) + grapher.graph_flights(flights); + } + public void actionPerformed(ActionEvent e) { String cmd = e.getActionCommand(); boolean success = e.getID() != 0; boolean running = false; if (cmd.equals("download")) { - if (success) - running = download_done(); + if (success) { + running = delete_start(); + if (!running) + graph_start(); + } } else if (cmd.equals("delete")) { if (success) { JOptionPane.showMessageDialog(frame, @@ -108,6 +120,7 @@ public class AltosEepromManage implements ActionListener { showDeletedFlights()), serial_line.device.toShortString(), JOptionPane.INFORMATION_MESSAGE); + graph_start(); } } if (!running) @@ -126,12 +139,12 @@ public class AltosEepromManage implements ActionListener { serial_line.device.toShortString(), JOptionPane.INFORMATION_MESSAGE); } else { - AltosEepromSelect select = new AltosEepromSelect(frame, flights, "Download"); + AltosEepromSelect select = new AltosEepromSelect(frame, flights, grapher != null); if (select.run()) { boolean any_selected = false; for (AltosEepromLog flight : flights) - any_selected = any_selected || flight.selected; + any_selected = any_selected || flight.download_selected; if (any_selected) { AltosEepromMonitorUI monitor = new AltosEepromMonitorUI(frame); monitor.addActionListener(this); @@ -147,7 +160,9 @@ public class AltosEepromManage implements ActionListener { download.start(); running = true; } else { - running = download_done(); + running = delete_start(); + if (!running) + graph_start(); } } } @@ -205,11 +220,12 @@ public class AltosEepromManage implements ActionListener { } } - public AltosEepromManage(JFrame given_frame, int product) { + public AltosEepromManage(JFrame given_frame, AltosEepromGrapher grapher, int product) { //boolean running = false; frame = given_frame; + this.grapher = grapher; device = AltosDeviceUIDialog.show(frame, product); remote = false; diff --git a/altosuilib/AltosEepromMonitorUI.java b/altosuilib/AltosEepromMonitorUI.java index 3427fe0f..fc6c95c6 100644 --- a/altosuilib/AltosEepromMonitorUI.java +++ b/altosuilib/AltosEepromMonitorUI.java @@ -18,11 +18,18 @@ package org.altusmetrum.altosuilib_12; +import java.io.*; +import java.util.*; +import java.util.concurrent.*; import java.awt.*; import java.awt.event.*; import javax.swing.*; import org.altusmetrum.altoslib_12.*; + class result_holder { + static int result; + } + public class AltosEepromMonitorUI extends AltosUIDialog implements AltosEepromMonitor { JFrame owner; Container pane; @@ -32,7 +39,6 @@ public class AltosEepromMonitorUI extends AltosUIDialog implements AltosEepromMo JLabel file_label; JLabel serial_value; JLabel flight_value; - JLabel file_value; JButton cancel; JProgressBar pbar; ActionListener listener; @@ -42,6 +48,8 @@ public class AltosEepromMonitorUI extends AltosUIDialog implements AltosEepromMo public AltosEepromMonitorUI(JFrame owner) { super (owner, "Download Flight Data", false); + setMinimumSize(new Dimension(600, 100)); + this.owner = owner; GridBagConstraints c; @@ -85,30 +93,11 @@ public class AltosEepromMonitorUI extends AltosUIDialog implements AltosEepromMo flight_value = new JLabel(""); pane.add(flight_value, c); - c = new GridBagConstraints(); - c.fill = GridBagConstraints.NONE; - c.gridx = 0; c.gridy = 2; - c.anchor = GridBagConstraints.LINE_START; - c.insets = il; - file_label = new JLabel("File:"); - pane.add(file_label, c); - - c = new GridBagConstraints(); - c.fill = GridBagConstraints.HORIZONTAL; - c.weightx = 1; - c.gridx = 1; c.gridy = 2; - c.anchor = GridBagConstraints.LINE_START; - c.insets = ir; - file_value = new JLabel(""); - pane.add(file_value, c); - pbar = new JProgressBar(); pbar.setMinimum(0); pbar.setMaximum(progress_max); - pbar.setValue(0); - pbar.setString("startup"); pbar.setStringPainted(true); - pbar.setPreferredSize(new Dimension(600, 20)); + set_block_internal(0); c = new GridBagConstraints(); c.fill = GridBagConstraints.HORIZONTAL; c.anchor = GridBagConstraints.CENTER; @@ -118,7 +107,6 @@ public class AltosEepromMonitorUI extends AltosUIDialog implements AltosEepromMo c.insets = ib; pane.add(pbar, c); - cancel = new JButton("Cancel"); c = new GridBagConstraints(); c.fill = GridBagConstraints.NONE; @@ -141,8 +129,9 @@ public class AltosEepromMonitorUI extends AltosUIDialog implements AltosEepromMo final Thread eeprom_thread = in_eeprom_thread; cancel.addActionListener(new ActionListener() { public void actionPerformed(ActionEvent e) { - if (eeprom_thread != null) + if (eeprom_thread != null) { eeprom_thread.interrupt(); + } } }); } @@ -162,6 +151,7 @@ public class AltosEepromMonitorUI extends AltosUIDialog implements AltosEepromMo s = String.format("block %d of %d", block, max_block); pbar.setString(s); + pbar.setStringPainted(true); pbar.setValue((int) (pos * progress_max)); } @@ -216,23 +206,6 @@ public class AltosEepromMonitorUI extends AltosUIDialog implements AltosEepromMo SwingUtilities.invokeLater(r); } - private void set_filename_internal(String filename) { - file_value.setText(String.format("%s", filename)); - } - - public void set_filename(String in_filename) { - final String filename = in_filename; - Runnable r = new Runnable() { - public void run() { - try { - set_filename_internal(filename); - } catch (Exception ex) { - } - } - }; - SwingUtilities.invokeLater(r); - } - private void done_internal(boolean success) { listener.actionPerformed(new ActionEvent(this, success ? 1 : 0, @@ -258,7 +231,6 @@ public class AltosEepromMonitorUI extends AltosUIDialog implements AltosEepromMo set_max(1); set_block_internal(0); set_flight_internal(0); - set_filename_internal(""); } public void reset() { @@ -293,6 +265,29 @@ public class AltosEepromMonitorUI extends AltosUIDialog implements AltosEepromMo joption_message_type); } + public Boolean check_overwrite(File in_file) { + final Semaphore check_overwrite_done = new Semaphore(0); + final File file = in_file; + final result_holder result = new result_holder(); + + Runnable r = new Runnable() { + public void run() { + result_holder.result = JOptionPane.showConfirmDialog(owner, + String.format("\"%s\" already exists, overwrite?", + file.toString()), + "Overwrite Existing File?", + JOptionPane.YES_NO_OPTION); + check_overwrite_done.release(); + } + }; + + SwingUtilities.invokeLater(r); + try { + check_overwrite_done.acquire(); + } catch (Exception e) {} + return result_holder.result == JOptionPane.YES_OPTION; + } + public void show_message(String in_message, String in_title, int in_message_type) { final String message = in_message; final String title = in_title; diff --git a/altosuilib/AltosEepromSelect.java b/altosuilib/AltosEepromSelect.java index 0c890c8b..f88f2bd6 100644 --- a/altosuilib/AltosEepromSelect.java +++ b/altosuilib/AltosEepromSelect.java @@ -27,23 +27,35 @@ import org.altusmetrum.altoslib_12.*; class AltosEepromItem implements ActionListener { AltosEepromLog log; JLabel label; - JCheckBox action; + JCheckBox download; JCheckBox delete; + JCheckBox graph; public void actionPerformed(ActionEvent e) { - log.selected = action.isSelected(); + log.download_selected = download.isSelected(); + log.delete_selected = delete.isSelected(); + log.graph_selected = graph.isSelected(); } public AltosEepromItem(AltosEepromLog in_log) { log = in_log; String text; - text = String.format("Flight #%02d", log.flight); + if (log.flight >= 0) + text = String.format("Flight #%02d", log.flight); + else + text = String.format("Corrupt #%02d", -log.flight); label = new JLabel(text); - action = new JCheckBox("", log.selected); - action.addActionListener(this); + download = new JCheckBox("", log.download_selected); + download.addActionListener(this); + + delete = new JCheckBox("", log.delete_selected); + delete.addActionListener(this); + + graph = new JCheckBox("", log.graph_selected); + graph.addActionListener(this); } } @@ -72,7 +84,7 @@ public class AltosEepromSelect extends AltosUIDialog implements ActionListener { public AltosEepromSelect (JFrame in_frame, AltosEepromList flights, - String action) { + boolean has_graph) { super(in_frame, String.format("Flight list for serial %d", flights.config_data.serial), true); frame = in_frame; @@ -81,7 +93,7 @@ public class AltosEepromSelect extends AltosUIDialog implements ActionListener { Container contentPane = getContentPane(); /* First, we create a pane containing the dialog's header/title */ - JLabel selectLabel = new JLabel(String.format ("Select flights to %s", action), SwingConstants.CENTER); + JLabel selectLabel = new JLabel(String.format ("Select flights"), SwingConstants.CENTER); JPanel labelPane = new JPanel(); labelPane.setLayout(new BoxLayout(labelPane, BoxLayout.X_AXIS)); @@ -118,9 +130,31 @@ public class AltosEepromSelect extends AltosUIDialog implements ActionListener { c.weightx = 0.5; c.anchor = GridBagConstraints.CENTER; c.insets = i; - JLabel downloadHeaderLabel = new JLabel(action); + JLabel downloadHeaderLabel = new JLabel("Download"); flightPane.add(downloadHeaderLabel, c); + /* Delete Header */ + c = new GridBagConstraints(); + c.gridx = 2; c.gridy = 0; + c.fill = GridBagConstraints.NONE; + c.weightx = 0.5; + c.anchor = GridBagConstraints.CENTER; + c.insets = i; + JLabel deleteHeaderLabel = new JLabel("Delete"); + flightPane.add(deleteHeaderLabel, c); + + if (has_graph) { + /* Graph Header */ + c = new GridBagConstraints(); + c.gridx = 3; c.gridy = 0; + c.fill = GridBagConstraints.NONE; + c.weightx = 0.5; + c.anchor = GridBagConstraints.CENTER; + c.insets = i; + JLabel graphHeaderLabel = new JLabel("Graph"); + flightPane.add(graphHeaderLabel, c); + } + /* Add the flights to the GridBag */ AltosEepromItem item; int itemNumber = 1; @@ -139,14 +173,34 @@ public class AltosEepromSelect extends AltosUIDialog implements ActionListener { c.insets = i; flightPane.add(item.label, c); - /* Add action checkbox for the flight */ + /* Add download checkbox for the flight */ c = new GridBagConstraints(); c.gridx = 1; c.gridy = itemNumber; c.fill = GridBagConstraints.NONE; c.weightx = 0.5; c.anchor = GridBagConstraints.CENTER; c.insets = i; - flightPane.add(item.action, c); + flightPane.add(item.download, c); + + /* Add delete checkbox for the flight */ + c = new GridBagConstraints(); + c.gridx = 2; c.gridy = itemNumber; + c.fill = GridBagConstraints.NONE; + c.weightx = 0.5; + c.anchor = GridBagConstraints.CENTER; + c.insets = i; + flightPane.add(item.delete, c); + + if (has_graph) { + /* Add graph checkbox for the flight */ + c = new GridBagConstraints(); + c.gridx = 3; c.gridy = itemNumber; + c.fill = GridBagConstraints.NONE; + c.weightx = 0.5; + c.anchor = GridBagConstraints.CENTER; + c.insets = i; + flightPane.add(item.graph, c); + } itemNumber++; } diff --git a/telegps/TeleGPS.java b/telegps/TeleGPS.java index 3646f000..1433c9e1 100644 --- a/telegps/TeleGPS.java +++ b/telegps/TeleGPS.java @@ -30,7 +30,7 @@ import org.altusmetrum.altosuilib_12.*; public class TeleGPS extends AltosUIFrame - implements AltosFlightDisplay, AltosFontListener, AltosUnitsListener, ActionListener + implements AltosFlightDisplay, AltosFontListener, AltosUnitsListener, ActionListener, AltosEepromGrapher { static String[] telegps_icon_names = { @@ -280,7 +280,7 @@ public class TeleGPS } void download(){ - new AltosEepromManage(this, AltosLib.product_telegps); + new AltosEepromManage(this, this, AltosLib.product_telegps); } void configure() { @@ -316,6 +316,21 @@ public class TeleGPS } } + public void graph_flights(AltosEepromList list) { + for (AltosEepromLog log : list) { + if (log.file != null) { + AltosRecordSet set = record_set(log.file); + if (set != null) { + try { + new TeleGPSGraphUI(set, log.file); + } catch (InterruptedException ie) { + } catch (IOException ie) { + } + } + } + } + } + void flash() { AltosFlashUI.show(this); } -- cgit v1.2.3 From f3b279141cd30ad6a212ce75f5a7c2b8e3d33870 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 11 Nov 2017 20:50:45 -0800 Subject: altos: Fix inverted test for corrupt flight log Was reporting correct flight log as corrupted. Oops. Signed-off-by: Keith Packard --- src/kernel/ao_log.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/kernel/ao_log.c b/src/kernel/ao_log.c index 08af5b58..f70c7232 100644 --- a/src/kernel/ao_log.c +++ b/src/kernel/ao_log.c @@ -183,7 +183,7 @@ ao_log_flight(uint8_t slot) if (ao_log_check_clear()) return 0; - if (ao_log_check_data() || log.type != AO_LOG_FLIGHT) + if (!ao_log_check_data() || log.type != AO_LOG_FLIGHT) return -(int16_t) (slot + 1); return log.u.flight.flight; -- cgit v1.2.3 From 23cf8fb4d5745ad76d9517c9702d03d10c58144a Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 11 Nov 2017 20:52:01 -0800 Subject: altos: Fix new GCC warnings * Duplicate 'const' in test code. * Mis-formatted loop in kf_rem_pio2 * Unused 'one' in sf_cos Signed-off-by: Keith Packard --- src/kernel/ao_host.h | 2 +- src/math/kf_rem_pio2.c | 3 ++- src/math/sf_cos.c | 6 ------ 3 files changed, 3 insertions(+), 8 deletions(-) diff --git a/src/kernel/ao_host.h b/src/kernel/ao_host.h index a7fa5ec2..50583f52 100644 --- a/src/kernel/ao_host.h +++ b/src/kernel/ao_host.h @@ -111,7 +111,7 @@ ao_dump_state(void *wchan); void ao_sleep(void *wchan); -const char const * const ao_state_names[] = { +const char * const ao_state_names[] = { "startup", "idle", "pad", "boost", "fast", "coast", "drogue", "main", "landed", "invalid" }; diff --git a/src/math/kf_rem_pio2.c b/src/math/kf_rem_pio2.c index 261c4812..1573ca9f 100644 --- a/src/math/kf_rem_pio2.c +++ b/src/math/kf_rem_pio2.c @@ -77,7 +77,8 @@ twon8 = 3.9062500000e-03; /* 0x3b800000 */ /* compute q[0],q[1],...q[jk] */ for (i=0;i<=jk;i++) { - for(j=0,fw=0.0;j<=jx;j++) fw += x[j]*f[jx+i-j]; q[i] = fw; + for(j=0,fw=0.0;j<=jx;j++) fw += x[j]*f[jx+i-j]; + q[i] = fw; } jz = jk; diff --git a/src/math/sf_cos.c b/src/math/sf_cos.c index 4c0a9a53..2f46ec32 100644 --- a/src/math/sf_cos.c +++ b/src/math/sf_cos.c @@ -15,12 +15,6 @@ #include "fdlibm.h" -#ifdef __STDC__ -static const float one=1.0; -#else -static float one=1.0; -#endif - #ifdef __STDC__ float cosf(float x) #else -- cgit v1.2.3 From 50a095fbe828b6ec3159d27930712df6b1b519b4 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 11 Nov 2017 21:29:11 -0800 Subject: doc: Update for 1.8.3 Also added a pile of docinfo files for older release notes files. Signed-off-by: Keith Packard --- doc/Makefile | 1 + doc/altosui.inc | 23 +++++++++++++++++++++-- doc/altusmetrum-docinfo.xml | 8 ++++++++ doc/easymini-release-notes.inc | 30 ++++++++++++++++++++++++++++++ doc/graph-configure.png | Bin 45370 -> 104002 bytes doc/graph-map.png | Bin 443560 -> 2818882 bytes doc/graph-stats.png | Bin 73620 -> 115174 bytes doc/graph.png | Bin 85178 -> 211929 bytes doc/release-notes-1.6.3-docinfo.xml | 29 +++++++++++++++++++++++++++++ doc/release-notes-1.6.4-docinfo.xml | 29 +++++++++++++++++++++++++++++ doc/release-notes-1.6.5-docinfo.xml | 29 +++++++++++++++++++++++++++++ doc/release-notes-1.6.8-docinfo.xml | 29 +++++++++++++++++++++++++++++ doc/release-notes-1.7-docinfo.xml | 29 +++++++++++++++++++++++++++++ doc/release-notes-1.8-docinfo.xml | 29 +++++++++++++++++++++++++++++ doc/release-notes-1.8.1-docinfo.xml | 29 +++++++++++++++++++++++++++++ doc/release-notes-1.8.2-docinfo.xml | 29 +++++++++++++++++++++++++++++ doc/release-notes-1.8.3-docinfo.xml | 29 +++++++++++++++++++++++++++++ doc/release-notes-1.8.3.inc | 32 ++++++++++++++++++++++++++++++++ doc/release-notes.inc | 5 ++++- doc/telegps-release-notes.inc | 31 +++++++++++++++++++++++++++++++ 20 files changed, 388 insertions(+), 3 deletions(-) create mode 100644 doc/release-notes-1.6.3-docinfo.xml create mode 100644 doc/release-notes-1.6.4-docinfo.xml create mode 100644 doc/release-notes-1.6.5-docinfo.xml create mode 100644 doc/release-notes-1.6.8-docinfo.xml create mode 100644 doc/release-notes-1.7-docinfo.xml create mode 100644 doc/release-notes-1.8-docinfo.xml create mode 100644 doc/release-notes-1.8.1-docinfo.xml create mode 100644 doc/release-notes-1.8.2-docinfo.xml create mode 100644 doc/release-notes-1.8.3-docinfo.xml create mode 100644 doc/release-notes-1.8.3.inc diff --git a/doc/Makefile b/doc/Makefile index b1bff848..feb1de8f 100644 --- a/doc/Makefile +++ b/doc/Makefile @@ -3,6 +3,7 @@ # RELNOTES_INC=\ + release-notes-1.8.3.inc \ release-notes-1.8.2.inc \ release-notes-1.8.1.inc \ release-notes-1.8.inc \ diff --git a/doc/altosui.inc b/doc/altosui.inc index 88e7a035..adce6f27 100644 --- a/doc/altosui.inc +++ b/doc/altosui.inc @@ -395,8 +395,27 @@ image::graph-configure.png[width="5.5in"] This selects which graph elements to show, and, at the - very bottom, lets you switch between metric and - imperial units + very bottom. It also lets you configure how + the graph is drawn: + + * Whether to use metric or imperial units + + * Whether to show a marker at each data + point. When displaying a small section of + the graph, these can be useful to know what + data values were recorded. + + * How wide to draw the lines in the graph + + * How to filter speed and acceleration data + computed from barometric data. Flight + computers with accelerometers never display + computed acceleration data, and only use + barometric data to compute speed during + descent. Flight computers without + accelerometers always compute both speed and + acceleration from barometric data. A larger + value smooths the data more. ==== Flight Statistics diff --git a/doc/altusmetrum-docinfo.xml b/doc/altusmetrum-docinfo.xml index c2bc14d1..874c1dbd 100644 --- a/doc/altusmetrum-docinfo.xml +++ b/doc/altusmetrum-docinfo.xml @@ -46,6 +46,14 @@ + + 1.8.3 + 12 Nove 2017 + + Support TeleGPS v2.0 hardware. Add accelerometer recalibration + UI. + + 1.8.2 18 Sep 2017 diff --git a/doc/easymini-release-notes.inc b/doc/easymini-release-notes.inc index 7f578f71..f4f45fd7 100644 --- a/doc/easymini-release-notes.inc +++ b/doc/easymini-release-notes.inc @@ -1,5 +1,35 @@ [appendix] == Release Notes + :leveloffset: 2 + include::release-notes-1.8.3.raw[] + + <<<< + :leveloffset: 2 + include::release-notes-1.8.2.raw[] + + <<<< + :leveloffset: 2 + include::release-notes-1.8.1.raw[] + + <<<< + :leveloffset: 2 + include::release-notes-1.8.raw[] + + <<<< + :leveloffset: 2 + include::release-notes-1.7.raw[] + + <<<< + :leveloffset: 2 + include::release-notes-1.6.8.raw[] + + <<<< + :leveloffset: 2 + include::release-notes-1.6.5.raw[] + + <<<< + :leveloffset: 2 + include::release-notes-1.6.4.raw[] :leveloffset: 2 include::release-notes-1.6.3.raw[] diff --git a/doc/graph-configure.png b/doc/graph-configure.png index ed0d5112..4f9a23c5 100644 Binary files a/doc/graph-configure.png and b/doc/graph-configure.png differ diff --git a/doc/graph-map.png b/doc/graph-map.png index bcea5ff8..2363d251 100644 Binary files a/doc/graph-map.png and b/doc/graph-map.png differ diff --git a/doc/graph-stats.png b/doc/graph-stats.png index 6f5c9791..88d943b9 100644 Binary files a/doc/graph-stats.png and b/doc/graph-stats.png differ diff --git a/doc/graph.png b/doc/graph.png index c7c7b7d7..8c5d7d4b 100644 Binary files a/doc/graph.png and b/doc/graph.png differ diff --git a/doc/release-notes-1.6.3-docinfo.xml b/doc/release-notes-1.6.3-docinfo.xml new file mode 100644 index 00000000..ce22ebcb --- /dev/null +++ b/doc/release-notes-1.6.3-docinfo.xml @@ -0,0 +1,29 @@ + + Bdale + Garbee + bdale@gag.com + + + Keith + Packard + keithp@keithp.com + +6 May 2016 + + 2016 + Bdale Garbee and Keith Packard + + + + + + + + + This document is released under the terms of the + + Creative Commons ShareAlike 3.0 + + license. + + diff --git a/doc/release-notes-1.6.4-docinfo.xml b/doc/release-notes-1.6.4-docinfo.xml new file mode 100644 index 00000000..76af3557 --- /dev/null +++ b/doc/release-notes-1.6.4-docinfo.xml @@ -0,0 +1,29 @@ + + Bdale + Garbee + bdale@gag.com + + + Keith + Packard + keithp@keithp.com + +17 June 2016 + + 2016 + Bdale Garbee and Keith Packard + + + + + + + + + This document is released under the terms of the + + Creative Commons ShareAlike 3.0 + + license. + + diff --git a/doc/release-notes-1.6.5-docinfo.xml b/doc/release-notes-1.6.5-docinfo.xml new file mode 100644 index 00000000..a07d6f0f --- /dev/null +++ b/doc/release-notes-1.6.5-docinfo.xml @@ -0,0 +1,29 @@ + + Bdale + Garbee + bdale@gag.com + + + Keith + Packard + keithp@keithp.com + +4 July 2016 + + 2016 + Bdale Garbee and Keith Packard + + + + + + + + + This document is released under the terms of the + + Creative Commons ShareAlike 3.0 + + license. + + diff --git a/doc/release-notes-1.6.8-docinfo.xml b/doc/release-notes-1.6.8-docinfo.xml new file mode 100644 index 00000000..776c244c --- /dev/null +++ b/doc/release-notes-1.6.8-docinfo.xml @@ -0,0 +1,29 @@ + + Bdale + Garbee + bdale@gag.com + + + Keith + Packard + keithp@keithp.com + +5 September 2016 + + 2016 + Bdale Garbee and Keith Packard + + + + + + + + + This document is released under the terms of the + + Creative Commons ShareAlike 3.0 + + license. + + diff --git a/doc/release-notes-1.7-docinfo.xml b/doc/release-notes-1.7-docinfo.xml new file mode 100644 index 00000000..61d77d92 --- /dev/null +++ b/doc/release-notes-1.7-docinfo.xml @@ -0,0 +1,29 @@ + + Bdale + Garbee + bdale@gag.com + + + Keith + Packard + keithp@keithp.com + +24 April 2017 + + 2017 + Bdale Garbee and Keith Packard + + + + + + + + + This document is released under the terms of the + + Creative Commons ShareAlike 3.0 + + license. + + diff --git a/doc/release-notes-1.8-docinfo.xml b/doc/release-notes-1.8-docinfo.xml new file mode 100644 index 00000000..3b40421a --- /dev/null +++ b/doc/release-notes-1.8-docinfo.xml @@ -0,0 +1,29 @@ + + Bdale + Garbee + bdale@gag.com + + + Keith + Packard + keithp@keithp.com + +12 August 2017 + + 2017 + Bdale Garbee and Keith Packard + + + + + + + + + This document is released under the terms of the + + Creative Commons ShareAlike 3.0 + + license. + + diff --git a/doc/release-notes-1.8.1-docinfo.xml b/doc/release-notes-1.8.1-docinfo.xml new file mode 100644 index 00000000..29a4fe7a --- /dev/null +++ b/doc/release-notes-1.8.1-docinfo.xml @@ -0,0 +1,29 @@ + + Bdale + Garbee + bdale@gag.com + + + Keith + Packard + keithp@keithp.com + +28 August 2017 + + 2017 + Bdale Garbee and Keith Packard + + + + + + + + + This document is released under the terms of the + + Creative Commons ShareAlike 3.0 + + license. + + diff --git a/doc/release-notes-1.8.2-docinfo.xml b/doc/release-notes-1.8.2-docinfo.xml new file mode 100644 index 00000000..a5fbc6e2 --- /dev/null +++ b/doc/release-notes-1.8.2-docinfo.xml @@ -0,0 +1,29 @@ + + Bdale + Garbee + bdale@gag.com + + + Keith + Packard + keithp@keithp.com + +18 September 2017 + + 2017 + Bdale Garbee and Keith Packard + + + + + + + + + This document is released under the terms of the + + Creative Commons ShareAlike 3.0 + + license. + + diff --git a/doc/release-notes-1.8.3-docinfo.xml b/doc/release-notes-1.8.3-docinfo.xml new file mode 100644 index 00000000..91a03926 --- /dev/null +++ b/doc/release-notes-1.8.3-docinfo.xml @@ -0,0 +1,29 @@ + + Bdale + Garbee + bdale@gag.com + + + Keith + Packard + keithp@keithp.com + +12 November 2017 + + 2017 + Bdale Garbee and Keith Packard + + + + + + + + + This document is released under the terms of the + + Creative Commons ShareAlike 3.0 + + license. + + diff --git a/doc/release-notes-1.8.3.inc b/doc/release-notes-1.8.3.inc new file mode 100644 index 00000000..b298bf3b --- /dev/null +++ b/doc/release-notes-1.8.3.inc @@ -0,0 +1,32 @@ += Release Notes for Version 1.8.3 +:toc!: +:doctype: article + + Version 1.8.3 includes two important flight computer fixes, + changed KML export data for Tripoli Record reporting and some + updates to graph presentation and data downloading. + + == AltOS + + AltOS Bug Fixes + + * Ground testing EasyMega and TeleMega additional pyro + channels could result in a sticky 'fired' status which would + prevent these channels from firing on future flights. + + * Corrupted flight log records could prevent future flights + from capturing log data. + + == AltosUI and TeleGPS Applications + + AltosUI and TeleGPS Changes + + * KML export now reports both barometric and GPS altitude data + to make it more useful for Tripoli record reporting. + + * Graph lines have improved appearance to make them easier to + distinguish. + + * The download dialog now offers to graph new flights, checks + for existing files to avoid overwriting data and reports if + there are checksum errors in the downloaded data. diff --git a/doc/release-notes.inc b/doc/release-notes.inc index a102b2dc..1c177afa 100644 --- a/doc/release-notes.inc +++ b/doc/release-notes.inc @@ -1,6 +1,10 @@ [appendix] == Release Notes + :leveloffset: 2 + include::release-notes-1.8.3.raw[] + + <<<< :leveloffset: 2 include::release-notes-1.8.2.raw[] @@ -13,7 +17,6 @@ include::release-notes-1.8.raw[] <<<< - :leveloffset: 2 include::release-notes-1.7.raw[] diff --git a/doc/telegps-release-notes.inc b/doc/telegps-release-notes.inc index 4123c783..0c506c28 100644 --- a/doc/telegps-release-notes.inc +++ b/doc/telegps-release-notes.inc @@ -1,6 +1,37 @@ [appendix] == Release Notes + :leveloffset: 2 + include::release-notes-1.8.3.raw[] + + <<<< + :leveloffset: 2 + include::release-notes-1.8.2.raw[] + + <<<< + :leveloffset: 2 + include::release-notes-1.8.1.raw[] + + <<<< + :leveloffset: 2 + include::release-notes-1.8.raw[] + + <<<< + :leveloffset: 2 + include::release-notes-1.7.raw[] + + <<<< + :leveloffset: 2 + include::release-notes-1.6.8.raw[] + + <<<< + :leveloffset: 2 + include::release-notes-1.6.5.raw[] + + <<<< + :leveloffset: 2 + include::release-notes-1.6.4.raw[] + :leveloffset: 2 include::release-notes-1.6.3.raw[] -- cgit v1.2.3 From bd881a5b85d7cd4fb82127f92f32e089499b50cb Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 16 Nov 2017 13:02:07 -0800 Subject: altos/lisp: Add non-cons cdr support The cdr of a cons can be any value; add support for lexing and printing them. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 5 ++- src/lisp/ao_lisp_builtin.c | 14 +++---- src/lisp/ao_lisp_cons.c | 25 +++++++++--- src/lisp/ao_lisp_eval.c | 2 +- src/lisp/ao_lisp_mem.c | 2 +- src/lisp/ao_lisp_read.c | 96 ++++++++++++++++++++++++++++++---------------- src/lisp/ao_lisp_read.h | 4 +- src/lisp/ao_lisp_string.c | 2 +- 8 files changed, 98 insertions(+), 52 deletions(-) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 980514cc..79f8fcc3 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -499,7 +499,10 @@ ao_lisp_stack_fetch(int id) { extern const struct ao_lisp_type ao_lisp_cons_type; struct ao_lisp_cons * -ao_lisp_cons_cons(ao_poly car, struct ao_lisp_cons *cdr); +ao_lisp_cons_cons(ao_poly car, ao_poly cdr); + +ao_poly +ao_lisp__cons(ao_poly car, ao_poly cdr); extern struct ao_lisp_cons *ao_lisp_cons_free_list; diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 902f60e2..5a960873 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -190,11 +190,9 @@ ao_lisp_cons(struct ao_lisp_cons *cons) ao_poly car, cdr; if(!ao_lisp_check_argc(_ao_lisp_atom_cons, cons, 2, 2)) return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_cons, cons, 1, AO_LISP_CONS, 1)) - return AO_LISP_NIL; car = ao_lisp_arg(cons, 0); cdr = ao_lisp_arg(cons, 1); - return ao_lisp_cons_poly(ao_lisp_cons_cons(car, ao_lisp_poly_cons(cdr))); + return ao_lisp__cons(car, cdr); } ao_poly @@ -247,14 +245,12 @@ ao_lisp_set(struct ao_lisp_cons *cons) ao_poly ao_lisp_setq(struct ao_lisp_cons *cons) { - struct ao_lisp_cons *expand = 0; if (!ao_lisp_check_argc(_ao_lisp_atom_setq, cons, 2, 2)) return AO_LISP_NIL; - expand = ao_lisp_cons_cons(_ao_lisp_atom_set, - ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_cons_cons(_ao_lisp_atom_quote, - ao_lisp_cons_cons(cons->car, NULL))), - ao_lisp_poly_cons(cons->cdr))); - return ao_lisp_cons_poly(expand); + return ao_lisp__cons(_ao_lisp_atom_set, + ao_lisp__cons(ao_lisp__cons(_ao_lisp_atom_quote, + ao_lisp__cons(cons->car, AO_LISP_NIL)), + cons->cdr)); } ao_poly diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index d2b60c9a..81a16a7a 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -72,7 +72,7 @@ const struct ao_lisp_type ao_lisp_cons_type = { struct ao_lisp_cons *ao_lisp_cons_free_list; struct ao_lisp_cons * -ao_lisp_cons_cons(ao_poly car, struct ao_lisp_cons *cdr) +ao_lisp_cons_cons(ao_poly car, ao_poly cdr) { struct ao_lisp_cons *cons; @@ -81,18 +81,24 @@ ao_lisp_cons_cons(ao_poly car, struct ao_lisp_cons *cdr) ao_lisp_cons_free_list = ao_lisp_poly_cons(cons->cdr); } else { ao_lisp_poly_stash(0, car); - ao_lisp_cons_stash(0, cdr); + ao_lisp_poly_stash(1, cdr); cons = ao_lisp_alloc(sizeof (struct ao_lisp_cons)); car = ao_lisp_poly_fetch(0); - cdr = ao_lisp_cons_fetch(0); + cdr = ao_lisp_poly_fetch(1); if (!cons) return NULL; } cons->car = car; - cons->cdr = ao_lisp_cons_poly(cdr); + cons->cdr = cdr; return cons; } +ao_poly +ao_lisp__cons(ao_poly car, ao_poly cdr) +{ + return ao_lisp_cons_poly(ao_lisp_cons_cons(car, cdr)); +} + void ao_lisp_cons_free(struct ao_lisp_cons *cons) { @@ -114,8 +120,15 @@ ao_lisp_cons_print(ao_poly c) if (!first) printf(" "); ao_lisp_poly_print(cons->car); - cons = ao_lisp_poly_cons(cons->cdr); - first = 0; + c = cons->cdr; + if (ao_lisp_poly_type(c) == AO_LISP_CONS) { + cons = ao_lisp_poly_cons(c); + first = 0; + } else { + printf(" . "); + ao_lisp_poly_print(c); + cons = NULL; + } } printf(")"); } diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 3be7c9c4..3e68d14a 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -210,7 +210,7 @@ ao_lisp_eval_formal(void) } /* Append formal to list of values */ - formal = ao_lisp_cons_poly(ao_lisp_cons_cons(ao_lisp_v, NULL)); + formal = ao_lisp__cons(ao_lisp_v, AO_LISP_NIL); if (!formal) return 0; diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index d067ea07..d7c8d7a6 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -437,7 +437,7 @@ dump_busy(void) #define DUMP_BUSY() #endif -static const struct ao_lisp_type const *ao_lisp_types[AO_LISP_NUM_TYPE] = { +static const struct ao_lisp_type *ao_lisp_types[AO_LISP_NUM_TYPE] = { [AO_LISP_CONS] = &ao_lisp_cons_type, [AO_LISP_INT] = NULL, [AO_LISP_STRING] = &ao_lisp_string_type, diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index 84ef2a61..550f62c2 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -62,7 +62,7 @@ static const uint16_t lex_classes[128] = { PRINTABLE|SIGN, /* + */ PRINTABLE, /* , */ PRINTABLE|SIGN, /* - */ - PRINTABLE, /* . */ + PRINTABLE|DOTC, /* . */ PRINTABLE, /* / */ PRINTABLE|DIGIT, /* 0 */ PRINTABLE|DIGIT, /* 1 */ @@ -262,7 +262,7 @@ static inline void end_token(void) { } static int -lex(void) +_lex(void) { int c; @@ -295,6 +295,11 @@ lex(void) return QUOTE; } } + if (lex_class & (DOTC)) { + add_token(c); + end_token(); + return DOT; + } if (lex_class & TWIDDLE) { token_int = lexc(); return NUM; @@ -355,21 +360,32 @@ lex(void) } } +static inline int lex(void) +{ + int parse_token = _lex(); + DBGI("token %d (%s)\n", parse_token, token_string); + return parse_token; +} + static int parse_token; struct ao_lisp_cons *ao_lisp_read_cons; struct ao_lisp_cons *ao_lisp_read_cons_tail; struct ao_lisp_cons *ao_lisp_read_stack; +#define READ_IN_QUOTE 0x01 +#define READ_SAW_DOT 0x02 +#define READ_DONE_DOT 0x04 + static int -push_read_stack(int cons, int in_quote) +push_read_stack(int cons, int read_state) { - DBGI("push read stack %p %d\n", ao_lisp_read_cons, in_quote); + DBGI("push read stack %p 0x%x\n", ao_lisp_read_cons, read_state); DBG_IN(); if (cons) { ao_lisp_read_stack = ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_read_cons), - ao_lisp_cons_cons(ao_lisp_int_poly(in_quote), - ao_lisp_read_stack)); + ao_lisp__cons(ao_lisp_int_poly(read_state), + ao_lisp_cons_poly(ao_lisp_read_stack))); if (!ao_lisp_read_stack) return 0; } @@ -381,11 +397,11 @@ push_read_stack(int cons, int in_quote) static int pop_read_stack(int cons) { - int in_quote = 0; + int read_state = 0; if (cons) { ao_lisp_read_cons = ao_lisp_poly_cons(ao_lisp_read_stack->car); ao_lisp_read_stack = ao_lisp_poly_cons(ao_lisp_read_stack->cdr); - in_quote = ao_lisp_poly_int(ao_lisp_read_stack->car); + read_state = ao_lisp_poly_int(ao_lisp_read_stack->car); ao_lisp_read_stack = ao_lisp_poly_cons(ao_lisp_read_stack->cdr); for (ao_lisp_read_cons_tail = ao_lisp_read_cons; ao_lisp_read_cons_tail && ao_lisp_read_cons_tail->cdr; @@ -397,8 +413,8 @@ pop_read_stack(int cons) ao_lisp_read_stack = 0; } DBG_OUT(); - DBGI("pop read stack %p %d\n", ao_lisp_read_cons, in_quote); - return in_quote; + DBGI("pop read stack %p %d\n", ao_lisp_read_cons, read_state); + return read_state; } ao_poly @@ -407,23 +423,21 @@ ao_lisp_read(void) struct ao_lisp_atom *atom; char *string; int cons; - int in_quote; + int read_state; ao_poly v; - parse_token = lex(); - DBGI("token %d (%s)\n", parse_token, token_string); cons = 0; - in_quote = 0; + read_state = 0; ao_lisp_read_cons = ao_lisp_read_cons_tail = ao_lisp_read_stack = 0; for (;;) { + parse_token = lex(); while (parse_token == OPEN) { - if (!push_read_stack(cons, in_quote)) + if (!push_read_stack(cons, read_state)) return AO_LISP_NIL; cons++; - in_quote = 0; + read_state = 0; parse_token = lex(); - DBGI("token %d (%s)\n", parse_token, token_string); } switch (parse_token) { @@ -451,10 +465,10 @@ ao_lisp_read(void) v = AO_LISP_NIL; break; case QUOTE: - if (!push_read_stack(cons, in_quote)) + if (!push_read_stack(cons, read_state)) return AO_LISP_NIL; cons++; - in_quote = 1; + read_state |= READ_IN_QUOTE; v = _ao_lisp_atom_quote; break; case CLOSE: @@ -464,8 +478,19 @@ ao_lisp_read(void) } v = ao_lisp_cons_poly(ao_lisp_read_cons); --cons; - in_quote = pop_read_stack(cons); + read_state = pop_read_stack(cons); break; + case DOT: + if (!cons) { + ao_lisp_error(AO_LISP_INVALID, ". outside of cons"); + return AO_LISP_NIL; + } + if (!ao_lisp_read_cons) { + ao_lisp_error(AO_LISP_INVALID, ". first in cons"); + return AO_LISP_NIL; + } + read_state |= READ_SAW_DOT; + continue; } /* loop over QUOTE ends */ @@ -473,26 +498,33 @@ ao_lisp_read(void) if (!cons) return v; - struct ao_lisp_cons *read = ao_lisp_cons_cons(v, NULL); - if (!read) + if (read_state & READ_DONE_DOT) { + ao_lisp_error(AO_LISP_INVALID, ". not last in cons"); return AO_LISP_NIL; + } - if (ao_lisp_read_cons_tail) - ao_lisp_read_cons_tail->cdr = ao_lisp_cons_poly(read); - else - ao_lisp_read_cons = read; - ao_lisp_read_cons_tail = read; + if (read_state & READ_SAW_DOT) { + read_state |= READ_DONE_DOT; + ao_lisp_read_cons_tail->cdr = v; + } else { + struct ao_lisp_cons *read = ao_lisp_cons_cons(v, AO_LISP_NIL); + if (!read) + return AO_LISP_NIL; - if (!in_quote || !ao_lisp_read_cons->cdr) + if (ao_lisp_read_cons_tail) + ao_lisp_read_cons_tail->cdr = ao_lisp_cons_poly(read); + else + ao_lisp_read_cons = read; + ao_lisp_read_cons_tail = read; + } + + if (!(read_state & READ_IN_QUOTE) || !ao_lisp_read_cons->cdr) break; v = ao_lisp_cons_poly(ao_lisp_read_cons); --cons; - in_quote = pop_read_stack(cons); + read_state = pop_read_stack(cons); } - - parse_token = lex(); - DBGI("token %d (%s)\n", parse_token, token_string); } return v; } diff --git a/src/lisp/ao_lisp_read.h b/src/lisp/ao_lisp_read.h index 1c994d56..30dcac3f 100644 --- a/src/lisp/ao_lisp_read.h +++ b/src/lisp/ao_lisp_read.h @@ -22,6 +22,7 @@ # define QUOTE 4 # define STRING 5 # define NUM 6 +# define DOT 7 /* * character classes @@ -42,8 +43,9 @@ # define VBAR 0x00001000 /* | */ # define TWIDDLE 0x00002000 /* ~ */ # define STRINGC 0x00004000 /* " */ +# define DOTC 0x00008000 /* . */ -# define NOTNAME (STRINGC|TWIDDLE|VBAR|QUOTEC|COMMENT|ENDOFFILE|WHITE|KET|BRA) +# define NOTNAME (STRINGC|TWIDDLE|VBAR|QUOTEC|COMMENT|ENDOFFILE|WHITE|KET|BRA|DOTC) # define NUMBER (DIGIT|SIGN) #endif /* _AO_LISP_READ_H_ */ diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c index cd7b27a9..af23f7b3 100644 --- a/src/lisp/ao_lisp_string.c +++ b/src/lisp/ao_lisp_string.c @@ -103,7 +103,7 @@ ao_lisp_string_unpack(char *a) ao_lisp_cons_stash(0, cons); ao_lisp_cons_stash(1, tail); ao_lisp_string_stash(0, a); - struct ao_lisp_cons *n = ao_lisp_cons_cons(ao_lisp_int_poly(c), NULL); + struct ao_lisp_cons *n = ao_lisp_cons_cons(ao_lisp_int_poly(c), AO_LISP_NIL); a = ao_lisp_string_fetch(0); cons = ao_lisp_cons_fetch(0); tail = ao_lisp_cons_fetch(1); -- cgit v1.2.3 From b3b4731fcb89cb404433f37a7704a503567c43bd Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 16 Nov 2017 17:49:47 -0800 Subject: altos/lisp: Add scheme-style bools (#t and #f) Cond and while compare against #f, just like scheme says to. Signed-off-by: Keith Packard --- src/lisp/.gitignore | 1 + src/lisp/Makefile | 10 +- src/lisp/Makefile-inc | 5 +- src/lisp/ao_lisp.h | 165 ++++++++++++++------------------ src/lisp/ao_lisp_bool.c | 73 ++++++++++++++ src/lisp/ao_lisp_builtin.c | 216 ++++++++++++++++-------------------------- src/lisp/ao_lisp_builtin.txt | 40 ++++++++ src/lisp/ao_lisp_const.lisp | 29 +++--- src/lisp/ao_lisp_eval.c | 5 +- src/lisp/ao_lisp_lambda.c | 8 +- src/lisp/ao_lisp_make_builtin | 149 +++++++++++++++++++++++++++++ src/lisp/ao_lisp_make_const.c | 55 ++--------- src/lisp/ao_lisp_mem.c | 11 +++ src/lisp/ao_lisp_poly.c | 4 + src/lisp/ao_lisp_read.c | 39 +++++--- src/lisp/ao_lisp_read.h | 37 ++++---- src/lisp/ao_lisp_rep.c | 2 +- src/lisp/ao_lisp_save.c | 14 +-- src/lisp/ao_lisp_stack.c | 2 +- 19 files changed, 528 insertions(+), 337 deletions(-) create mode 100644 src/lisp/ao_lisp_bool.c create mode 100644 src/lisp/ao_lisp_builtin.txt create mode 100644 src/lisp/ao_lisp_make_builtin diff --git a/src/lisp/.gitignore b/src/lisp/.gitignore index 76a555ea..1faa9b67 100644 --- a/src/lisp/.gitignore +++ b/src/lisp/.gitignore @@ -1,2 +1,3 @@ ao_lisp_make_const ao_lisp_const.h +ao_lisp_builtin.h diff --git a/src/lisp/Makefile b/src/lisp/Makefile index 25796ec5..4563dad3 100644 --- a/src/lisp/Makefile +++ b/src/lisp/Makefile @@ -1,13 +1,16 @@ -all: ao_lisp_const.h +all: ao_lisp_builtin.h ao_lisp_const.h clean: - rm -f ao_lisp_const.h $(OBJS) ao_lisp_make_const + rm -f ao_lisp_const.h ao_lisp_builtin.h $(OBJS) ao_lisp_make_const ao_lisp_const.h: ao_lisp_const.lisp ao_lisp_make_const ./ao_lisp_make_const -o $@ ao_lisp_const.lisp +ao_lisp_builtin.h: ao_lisp_make_builtin ao_lisp_builtin.txt + nickle ./ao_lisp_make_builtin ao_lisp_builtin.txt > $@ + include Makefile-inc -SRCS=$(LISP_SRCS) +SRCS=$(LISP_SRCS) ao_lisp_make_const.c HDRS=$(LISP_HDRS) @@ -15,7 +18,6 @@ OBJS=$(SRCS:.c=.o) CFLAGS=-DAO_LISP_MAKE_CONST -O0 -g -I. -Wall -Wextra -no-pie - ao_lisp_make_const: $(OBJS) $(CC) $(CFLAGS) -o $@ $(OBJS) diff --git a/src/lisp/Makefile-inc b/src/lisp/Makefile-inc index 126deeb0..6c8702fb 100644 --- a/src/lisp/Makefile-inc +++ b/src/lisp/Makefile-inc @@ -1,11 +1,11 @@ LISP_SRCS=\ - ao_lisp_make_const.c\ ao_lisp_mem.c \ ao_lisp_cons.c \ ao_lisp_string.c \ ao_lisp_atom.c \ ao_lisp_int.c \ ao_lisp_poly.c \ + ao_lisp_bool.c \ ao_lisp_builtin.c \ ao_lisp_read.c \ ao_lisp_frame.c \ @@ -19,4 +19,5 @@ LISP_SRCS=\ LISP_HDRS=\ ao_lisp.h \ ao_lisp_os.h \ - ao_lisp_read.h + ao_lisp_read.h \ + ao_lisp_builtin.h diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 79f8fcc3..cd002cc2 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -54,35 +54,37 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4))); #define ao_lisp_pool ao_lisp_const #define AO_LISP_POOL AO_LISP_POOL_CONST -#define _atom(n) ao_lisp_atom_poly(ao_lisp_atom_intern(n)) - -#define _ao_lisp_atom_quote _atom("quote") -#define _ao_lisp_atom_set _atom("set") -#define _ao_lisp_atom_setq _atom("setq") -#define _ao_lisp_atom_t _atom("t") -#define _ao_lisp_atom_car _atom("car") -#define _ao_lisp_atom_cdr _atom("cdr") -#define _ao_lisp_atom_cons _atom("cons") -#define _ao_lisp_atom_last _atom("last") -#define _ao_lisp_atom_length _atom("length") -#define _ao_lisp_atom_cond _atom("cond") -#define _ao_lisp_atom_lambda _atom("lambda") -#define _ao_lisp_atom_led _atom("led") -#define _ao_lisp_atom_delay _atom("delay") -#define _ao_lisp_atom_pack _atom("pack") -#define _ao_lisp_atom_unpack _atom("unpack") -#define _ao_lisp_atom_flush _atom("flush") -#define _ao_lisp_atom_eval _atom("eval") -#define _ao_lisp_atom_read _atom("read") -#define _ao_lisp_atom_eof _atom("eof") -#define _ao_lisp_atom_save _atom("save") -#define _ao_lisp_atom_restore _atom("restore") -#define _ao_lisp_atom_call2fcc _atom("call/cc") -#define _ao_lisp_atom_collect _atom("collect") -#define _ao_lisp_atom_symbolp _atom("symbol?") -#define _ao_lisp_atom_builtin _atom("builtin?") -#define _ao_lisp_atom_symbolp _atom("symbol?") -#define _ao_lisp_atom_symbolp _atom("symbol?") +#define _atom(n) ao_lisp_atom_poly(ao_lisp_atom_intern(#n)) +#define _bool(v) ao_lisp_bool_poly(ao_lisp_bool_get(v)) + +#define _ao_lisp_bool_true _bool(1) +#define _ao_lisp_bool_false _bool(0) +#define _ao_lisp_atom_quote _atom(quote) +#define _ao_lisp_atom_set _atom(set) +#define _ao_lisp_atom_setq _atom(setq) +#define _ao_lisp_atom_car _atom(car) +#define _ao_lisp_atom_cdr _atom(cdr) +#define _ao_lisp_atom_cons _atom(cons) +#define _ao_lisp_atom_last _atom(last) +#define _ao_lisp_atom_length _atom(length) +#define _ao_lisp_atom_cond _atom(cond) +#define _ao_lisp_atom_lambda _atom(lambda) +#define _ao_lisp_atom_led _atom(led) +#define _ao_lisp_atom_delay _atom(delay) +#define _ao_lisp_atom_pack _atom(pack) +#define _ao_lisp_atom_unpack _atom(unpack) +#define _ao_lisp_atom_flush _atom(flush) +#define _ao_lisp_atom_eval _atom(eval) +#define _ao_lisp_atom_read _atom(read) +#define _ao_lisp_atom_eof _atom(eof) +#define _ao_lisp_atom_save _atom(save) +#define _ao_lisp_atom_restore _atom(restore) +#define _ao_lisp_atom_call2fcc _atom(call/cc) +#define _ao_lisp_atom_collect _atom(collect) +#define _ao_lisp_atom_symbolp _atom(symbol?) +#define _ao_lisp_atom_builtin _atom(builtin?) +#define _ao_lisp_atom_symbolp _atom(symbol?) +#define _ao_lisp_atom_symbolp _atom(symbol?) #else #include "ao_lisp_const.h" #ifndef AO_LISP_POOL @@ -108,7 +110,8 @@ extern uint8_t ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA] __attribute__((a #define AO_LISP_FRAME 6 #define AO_LISP_LAMBDA 7 #define AO_LISP_STACK 8 -#define AO_LISP_NUM_TYPE 9 +#define AO_LISP_BOOL 9 +#define AO_LISP_NUM_TYPE 10 /* Leave two bits for types to use as they please */ #define AO_LISP_OTHER_TYPE_MASK 0x3f @@ -171,6 +174,12 @@ struct ao_lisp_frame { struct ao_lisp_val vals[]; }; +struct ao_lisp_bool { + uint8_t type; + uint8_t value; + uint16_t pad; +}; + /* Set on type when the frame escapes the lambda */ #define AO_LISP_FRAME_MARK 0x80 #define AO_LISP_FRAME_PRINT 0x40 @@ -257,47 +266,8 @@ struct ao_lisp_builtin { uint16_t func; }; -enum ao_lisp_builtin_id { - builtin_eval, - builtin_read, - builtin_lambda, - builtin_lexpr, - builtin_nlambda, - builtin_macro, - builtin_car, - builtin_cdr, - builtin_cons, - builtin_last, - builtin_length, - builtin_quote, - builtin_set, - builtin_setq, - builtin_cond, - builtin_progn, - builtin_while, - builtin_print, - builtin_patom, - builtin_plus, - builtin_minus, - builtin_times, - builtin_divide, - builtin_mod, - builtin_equal, - builtin_less, - builtin_greater, - builtin_less_equal, - builtin_greater_equal, - builtin_pack, - builtin_unpack, - builtin_flush, - builtin_delay, - builtin_led, - builtin_save, - builtin_restore, - builtin_call_cc, - builtin_collect, - _builtin_last -}; +#define AO_LISP_BUILTIN_ID +#include "ao_lisp_builtin.h" typedef ao_poly (*ao_lisp_func_t)(struct ao_lisp_cons *cons); @@ -433,6 +403,17 @@ ao_lisp_builtin_poly(struct ao_lisp_builtin *b) return ao_lisp_poly(b, AO_LISP_OTHER); } +static inline ao_poly +ao_lisp_bool_poly(struct ao_lisp_bool *b) +{ + return ao_lisp_poly(b, AO_LISP_OTHER); +} + +static inline struct ao_lisp_bool * +ao_lisp_poly_bool(ao_poly poly) +{ + return ao_lisp_ref(poly); +} /* memory functions */ extern int ao_lisp_collects[2]; @@ -495,6 +476,20 @@ ao_lisp_stack_fetch(int id) { return ao_lisp_poly_stack(ao_lisp_poly_fetch(id)); } +/* bool */ + +extern const struct ao_lisp_type ao_lisp_bool_type; + +void +ao_lisp_bool_print(ao_poly v); + +#ifdef AO_LISP_MAKE_CONST +struct ao_lisp_bool *ao_lisp_true, *ao_lisp_false; + +struct ao_lisp_bool * +ao_lisp_bool_get(uint8_t value); +#endif + /* cons */ extern const struct ao_lisp_type ao_lisp_cons_type; @@ -665,29 +660,9 @@ ao_lisp_lambda_new(ao_poly cons); void ao_lisp_lambda_print(ao_poly lambda); -ao_poly -ao_lisp_lambda(struct ao_lisp_cons *cons); - -ao_poly -ao_lisp_lexpr(struct ao_lisp_cons *cons); - -ao_poly -ao_lisp_nlambda(struct ao_lisp_cons *cons); - -ao_poly -ao_lisp_macro(struct ao_lisp_cons *cons); - ao_poly ao_lisp_lambda_eval(void); -/* save */ - -ao_poly -ao_lisp_save(struct ao_lisp_cons *cons); - -ao_poly -ao_lisp_restore(struct ao_lisp_cons *cons); - /* stack */ extern const struct ao_lisp_type ao_lisp_stack_type; @@ -712,9 +687,6 @@ ao_lisp_stack_print(ao_poly stack); ao_poly ao_lisp_stack_eval(void); -ao_poly -ao_lisp_call_cc(struct ao_lisp_cons *cons); - /* error */ void @@ -726,6 +698,11 @@ ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame); ao_poly ao_lisp_error(int error, char *format, ...); +/* builtins */ + +#define AO_LISP_BUILTIN_DECLS +#include "ao_lisp_builtin.h" + /* debugging macros */ #if DBG_EVAL diff --git a/src/lisp/ao_lisp_bool.c b/src/lisp/ao_lisp_bool.c new file mode 100644 index 00000000..ad25afba --- /dev/null +++ b/src/lisp/ao_lisp_bool.c @@ -0,0 +1,73 @@ +/* + * Copyright © 2017 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_lisp.h" + +static void bool_mark(void *addr) +{ + (void) addr; +} + +static int bool_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_lisp_bool); +} + +static void bool_move(void *addr) +{ + (void) addr; +} + +const struct ao_lisp_type ao_lisp_bool_type = { + .mark = bool_mark, + .size = bool_size, + .move = bool_move, + .name = "bool" +}; + +void +ao_lisp_bool_print(ao_poly v) +{ + struct ao_lisp_bool *b = ao_lisp_poly_bool(v); + + if (b->value) + printf("#t"); + else + printf("#f"); +} + +#ifdef AO_LISP_MAKE_CONST + +struct ao_lisp_bool *ao_lisp_true, *ao_lisp_false; + +struct ao_lisp_bool * +ao_lisp_bool_get(uint8_t value) +{ + struct ao_lisp_bool **b; + + if (value) + b = &ao_lisp_true; + else + b = &ao_lisp_false; + + if (!*b) { + *b = ao_lisp_alloc(sizeof (struct ao_lisp_bool)); + (*b)->type = AO_LISP_BOOL; + (*b)->value = value; + } + return *b; +} + +#endif diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 5a960873..6fc28820 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -40,61 +40,26 @@ const struct ao_lisp_type ao_lisp_builtin_type = { }; #ifdef AO_LISP_MAKE_CONST -char *ao_lisp_builtin_name(enum ao_lisp_builtin_id b) { - (void) b; - return "???"; -} + +#define AO_LISP_BUILTIN_CASENAME +#include "ao_lisp_builtin.h" + +#define _atomn(n) ao_lisp_poly_atom(_atom(n)) + char *ao_lisp_args_name(uint8_t args) { - (void) args; - return "???"; + args &= AO_LISP_FUNC_MASK; + switch (args) { + case AO_LISP_FUNC_LAMBDA: return _atomn(lambda)->name; + case AO_LISP_FUNC_LEXPR: return _atomn(lexpr)->name; + case AO_LISP_FUNC_NLAMBDA: return _atomn(nlambda)->name; + case AO_LISP_FUNC_MACRO: return _atomn(macro)->name; + default: return "???"; + } } #else -static const ao_poly builtin_names[] = { - [builtin_eval] = _ao_lisp_atom_eval, - [builtin_read] = _ao_lisp_atom_read, - [builtin_lambda] = _ao_lisp_atom_lambda, - [builtin_lexpr] = _ao_lisp_atom_lexpr, - [builtin_nlambda] = _ao_lisp_atom_nlambda, - [builtin_macro] = _ao_lisp_atom_macro, - [builtin_car] = _ao_lisp_atom_car, - [builtin_cdr] = _ao_lisp_atom_cdr, - [builtin_cons] = _ao_lisp_atom_cons, - [builtin_last] = _ao_lisp_atom_last, - [builtin_length] = _ao_lisp_atom_length, - [builtin_quote] = _ao_lisp_atom_quote, - [builtin_set] = _ao_lisp_atom_set, - [builtin_setq] = _ao_lisp_atom_setq, - [builtin_cond] = _ao_lisp_atom_cond, - [builtin_progn] = _ao_lisp_atom_progn, - [builtin_while] = _ao_lisp_atom_while, - [builtin_print] = _ao_lisp_atom_print, - [builtin_patom] = _ao_lisp_atom_patom, - [builtin_plus] = _ao_lisp_atom_2b, - [builtin_minus] = _ao_lisp_atom_2d, - [builtin_times] = _ao_lisp_atom_2a, - [builtin_divide] = _ao_lisp_atom_2f, - [builtin_mod] = _ao_lisp_atom_25, - [builtin_equal] = _ao_lisp_atom_3d, - [builtin_less] = _ao_lisp_atom_3c, - [builtin_greater] = _ao_lisp_atom_3e, - [builtin_less_equal] = _ao_lisp_atom_3c3d, - [builtin_greater_equal] = _ao_lisp_atom_3e3d, - [builtin_pack] = _ao_lisp_atom_pack, - [builtin_unpack] = _ao_lisp_atom_unpack, - [builtin_flush] = _ao_lisp_atom_flush, - [builtin_delay] = _ao_lisp_atom_delay, - [builtin_led] = _ao_lisp_atom_led, - [builtin_save] = _ao_lisp_atom_save, - [builtin_restore] = _ao_lisp_atom_restore, - [builtin_call_cc] = _ao_lisp_atom_call2fcc, - [builtin_collect] = _ao_lisp_atom_collect, -#if 0 - [builtin_symbolp] = _ao_lisp_atom_symbolp, - [builtin_listp] = _ao_lisp_atom_listp, - [builtin_stringp] = _ao_lisp_atom_stringp, - [builtin_numberp] = _ao_lisp_atom_numberp, -#endif -}; + +#define AO_LISP_BUILTIN_ARRAYNAME +#include "ao_lisp_builtin.h" static char * ao_lisp_builtin_name(enum ao_lisp_builtin_id b) { @@ -138,7 +103,7 @@ ao_lisp_check_argc(ao_poly name, struct ao_lisp_cons *cons, int min, int max) } if (argc < min || argc > max) return ao_lisp_error(AO_LISP_INVALID, "%s: invalid arg count", ao_lisp_poly_atom(name)->name); - return _ao_lisp_atom_t; + return _ao_lisp_bool_true; } ao_poly @@ -161,11 +126,11 @@ ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type, if ((!car && !nil_ok) || ao_lisp_poly_type(car) != type) return ao_lisp_error(AO_LISP_INVALID, "%s: invalid type for arg %d", ao_lisp_poly_atom(name)->name, argc); - return _ao_lisp_atom_t; + return _ao_lisp_bool_true; } ao_poly -ao_lisp_car(struct ao_lisp_cons *cons) +ao_lisp_do_car(struct ao_lisp_cons *cons) { if (!ao_lisp_check_argc(_ao_lisp_atom_car, cons, 1, 1)) return AO_LISP_NIL; @@ -175,7 +140,7 @@ ao_lisp_car(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_cdr(struct ao_lisp_cons *cons) +ao_lisp_do_cdr(struct ao_lisp_cons *cons) { if (!ao_lisp_check_argc(_ao_lisp_atom_cdr, cons, 1, 1)) return AO_LISP_NIL; @@ -185,7 +150,7 @@ ao_lisp_cdr(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_cons(struct ao_lisp_cons *cons) +ao_lisp_do_cons(struct ao_lisp_cons *cons) { ao_poly car, cdr; if(!ao_lisp_check_argc(_ao_lisp_atom_cons, cons, 2, 2)) @@ -196,7 +161,7 @@ ao_lisp_cons(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_last(struct ao_lisp_cons *cons) +ao_lisp_do_last(struct ao_lisp_cons *cons) { ao_poly l; if (!ao_lisp_check_argc(_ao_lisp_atom_last, cons, 1, 1)) @@ -214,7 +179,7 @@ ao_lisp_last(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_length(struct ao_lisp_cons *cons) +ao_lisp_do_length(struct ao_lisp_cons *cons) { if (!ao_lisp_check_argc(_ao_lisp_atom_length, cons, 1, 1)) return AO_LISP_NIL; @@ -224,7 +189,7 @@ ao_lisp_length(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_quote(struct ao_lisp_cons *cons) +ao_lisp_do_quote(struct ao_lisp_cons *cons) { if (!ao_lisp_check_argc(_ao_lisp_atom_quote, cons, 1, 1)) return AO_LISP_NIL; @@ -232,7 +197,7 @@ ao_lisp_quote(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_set(struct ao_lisp_cons *cons) +ao_lisp_do_set(struct ao_lisp_cons *cons) { if (!ao_lisp_check_argc(_ao_lisp_atom_set, cons, 2, 2)) return AO_LISP_NIL; @@ -243,7 +208,7 @@ ao_lisp_set(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_setq(struct ao_lisp_cons *cons) +ao_lisp_do_setq(struct ao_lisp_cons *cons) { if (!ao_lisp_check_argc(_ao_lisp_atom_setq, cons, 2, 2)) return AO_LISP_NIL; @@ -254,14 +219,14 @@ ao_lisp_setq(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_cond(struct ao_lisp_cons *cons) +ao_lisp_do_cond(struct ao_lisp_cons *cons) { ao_lisp_set_cond(cons); return AO_LISP_NIL; } ao_poly -ao_lisp_progn(struct ao_lisp_cons *cons) +ao_lisp_do_progn(struct ao_lisp_cons *cons) { ao_lisp_stack->state = eval_progn; ao_lisp_stack->sexprs = ao_lisp_cons_poly(cons); @@ -269,7 +234,7 @@ ao_lisp_progn(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_while(struct ao_lisp_cons *cons) +ao_lisp_do_while(struct ao_lisp_cons *cons) { ao_lisp_stack->state = eval_while; ao_lisp_stack->sexprs = ao_lisp_cons_poly(cons); @@ -277,7 +242,7 @@ ao_lisp_while(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_print(struct ao_lisp_cons *cons) +ao_lisp_do_print(struct ao_lisp_cons *cons) { ao_poly val = AO_LISP_NIL; while (cons) { @@ -292,7 +257,7 @@ ao_lisp_print(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_patom(struct ao_lisp_cons *cons) +ao_lisp_do_patom(struct ao_lisp_cons *cons) { ao_poly val = AO_LISP_NIL; while (cons) { @@ -358,31 +323,31 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) } ao_poly -ao_lisp_plus(struct ao_lisp_cons *cons) +ao_lisp_do_plus(struct ao_lisp_cons *cons) { return ao_lisp_math(cons, builtin_plus); } ao_poly -ao_lisp_minus(struct ao_lisp_cons *cons) +ao_lisp_do_minus(struct ao_lisp_cons *cons) { return ao_lisp_math(cons, builtin_minus); } ao_poly -ao_lisp_times(struct ao_lisp_cons *cons) +ao_lisp_do_times(struct ao_lisp_cons *cons) { return ao_lisp_math(cons, builtin_times); } ao_poly -ao_lisp_divide(struct ao_lisp_cons *cons) +ao_lisp_do_divide(struct ao_lisp_cons *cons) { return ao_lisp_math(cons, builtin_divide); } ao_poly -ao_lisp_mod(struct ao_lisp_cons *cons) +ao_lisp_do_mod(struct ao_lisp_cons *cons) { return ao_lisp_math(cons, builtin_mod); } @@ -393,7 +358,7 @@ ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) ao_poly left; if (!cons) - return _ao_lisp_atom_t; + return _ao_lisp_bool_true; left = cons->car; cons = ao_lisp_poly_cons(cons->cdr); @@ -402,7 +367,7 @@ ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) if (op == builtin_equal) { if (left != right) - return AO_LISP_NIL; + return _ao_lisp_bool_false; } else { uint8_t lt = ao_lisp_poly_type(left); uint8_t rt = ao_lisp_poly_type(right); @@ -413,19 +378,19 @@ ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) switch (op) { case builtin_less: if (!(l < r)) - return AO_LISP_NIL; + return _ao_lisp_bool_false; break; case builtin_greater: if (!(l > r)) - return AO_LISP_NIL; + return _ao_lisp_bool_false; break; case builtin_less_equal: if (!(l <= r)) - return AO_LISP_NIL; + return _ao_lisp_bool_false; break; case builtin_greater_equal: if (!(l >= r)) - return AO_LISP_NIL; + return _ao_lisp_bool_false; break; default: break; @@ -436,19 +401,19 @@ ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) switch (op) { case builtin_less: if (!(c < 0)) - return AO_LISP_NIL; + return _ao_lisp_bool_false; break; case builtin_greater: if (!(c > 0)) - return AO_LISP_NIL; + return _ao_lisp_bool_false; break; case builtin_less_equal: if (!(c <= 0)) - return AO_LISP_NIL; + return _ao_lisp_bool_false; break; case builtin_greater_equal: if (!(c >= 0)) - return AO_LISP_NIL; + return _ao_lisp_bool_false; break; default: break; @@ -458,41 +423,41 @@ ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) left = right; cons = ao_lisp_poly_cons(cons->cdr); } - return _ao_lisp_atom_t; + return _ao_lisp_bool_true; } ao_poly -ao_lisp_equal(struct ao_lisp_cons *cons) +ao_lisp_do_equal(struct ao_lisp_cons *cons) { return ao_lisp_compare(cons, builtin_equal); } ao_poly -ao_lisp_less(struct ao_lisp_cons *cons) +ao_lisp_do_less(struct ao_lisp_cons *cons) { return ao_lisp_compare(cons, builtin_less); } ao_poly -ao_lisp_greater(struct ao_lisp_cons *cons) +ao_lisp_do_greater(struct ao_lisp_cons *cons) { return ao_lisp_compare(cons, builtin_greater); } ao_poly -ao_lisp_less_equal(struct ao_lisp_cons *cons) +ao_lisp_do_less_equal(struct ao_lisp_cons *cons) { return ao_lisp_compare(cons, builtin_less_equal); } ao_poly -ao_lisp_greater_equal(struct ao_lisp_cons *cons) +ao_lisp_do_greater_equal(struct ao_lisp_cons *cons) { return ao_lisp_compare(cons, builtin_greater_equal); } ao_poly -ao_lisp_pack(struct ao_lisp_cons *cons) +ao_lisp_do_pack(struct ao_lisp_cons *cons) { if (!ao_lisp_check_argc(_ao_lisp_atom_pack, cons, 1, 1)) return AO_LISP_NIL; @@ -502,7 +467,7 @@ ao_lisp_pack(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_unpack(struct ao_lisp_cons *cons) +ao_lisp_do_unpack(struct ao_lisp_cons *cons) { if (!ao_lisp_check_argc(_ao_lisp_atom_unpack, cons, 1, 1)) return AO_LISP_NIL; @@ -512,16 +477,16 @@ ao_lisp_unpack(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_flush(struct ao_lisp_cons *cons) +ao_lisp_do_flush(struct ao_lisp_cons *cons) { if (!ao_lisp_check_argc(_ao_lisp_atom_flush, cons, 0, 0)) return AO_LISP_NIL; ao_lisp_os_flush(); - return _ao_lisp_atom_t; + return _ao_lisp_bool_true; } ao_poly -ao_lisp_led(struct ao_lisp_cons *cons) +ao_lisp_do_led(struct ao_lisp_cons *cons) { ao_poly led; if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) @@ -534,7 +499,7 @@ ao_lisp_led(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_delay(struct ao_lisp_cons *cons) +ao_lisp_do_delay(struct ao_lisp_cons *cons) { ao_poly delay; if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) @@ -572,44 +537,27 @@ ao_lisp_do_collect(struct ao_lisp_cons *cons) return ao_lisp_int_poly(free); } -const ao_lisp_func_t ao_lisp_builtins[] = { - [builtin_eval] = ao_lisp_do_eval, - [builtin_read] = ao_lisp_do_read, - [builtin_lambda] = ao_lisp_lambda, - [builtin_lexpr] = ao_lisp_lexpr, - [builtin_nlambda] = ao_lisp_nlambda, - [builtin_macro] = ao_lisp_macro, - [builtin_car] = ao_lisp_car, - [builtin_cdr] = ao_lisp_cdr, - [builtin_cons] = ao_lisp_cons, - [builtin_last] = ao_lisp_last, - [builtin_length] = ao_lisp_length, - [builtin_quote] = ao_lisp_quote, - [builtin_set] = ao_lisp_set, - [builtin_setq] = ao_lisp_setq, - [builtin_cond] = ao_lisp_cond, - [builtin_progn] = ao_lisp_progn, - [builtin_while] = ao_lisp_while, - [builtin_print] = ao_lisp_print, - [builtin_patom] = ao_lisp_patom, - [builtin_plus] = ao_lisp_plus, - [builtin_minus] = ao_lisp_minus, - [builtin_times] = ao_lisp_times, - [builtin_divide] = ao_lisp_divide, - [builtin_mod] = ao_lisp_mod, - [builtin_equal] = ao_lisp_equal, - [builtin_less] = ao_lisp_less, - [builtin_greater] = ao_lisp_greater, - [builtin_less_equal] = ao_lisp_less_equal, - [builtin_greater_equal] = ao_lisp_greater_equal, - [builtin_pack] = ao_lisp_pack, - [builtin_unpack] = ao_lisp_unpack, - [builtin_flush] = ao_lisp_flush, - [builtin_led] = ao_lisp_led, - [builtin_delay] = ao_lisp_delay, - [builtin_save] = ao_lisp_save, - [builtin_restore] = ao_lisp_restore, - [builtin_call_cc] = ao_lisp_call_cc, - [builtin_collect] = ao_lisp_do_collect, -}; +ao_poly +ao_lisp_do_nullp(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + if (ao_lisp_arg(cons, 0) == AO_LISP_NIL) + return _ao_lisp_bool_true; + else + return _ao_lisp_bool_false; +} + +ao_poly +ao_lisp_do_not(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + if (ao_lisp_arg(cons, 0) == _ao_lisp_bool_false) + return _ao_lisp_bool_true; + else + return _ao_lisp_bool_false; +} +#define AO_LISP_BUILTIN_FUNCS +#include "ao_lisp_builtin.h" diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt new file mode 100644 index 00000000..02320df0 --- /dev/null +++ b/src/lisp/ao_lisp_builtin.txt @@ -0,0 +1,40 @@ +lambda eval +lambda read +nlambda lambda +nlambda lexpr +nlambda nlambda +nlambda macro +lambda car +lambda cdr +lambda cons +lambda last +lambda length +nlambda quote +lambda set +macro setq +nlambda cond +nlambda progn +nlambda while +lexpr print +lexpr patom +lexpr plus + +lexpr minus - +lexpr times * +lexpr divide / +lexpr mod % +lexpr equal = +lexpr less < +lexpr greater > +lexpr less_equal <= +lexpr greater_equal >= +lambda pack +lambda unpack +lambda flush +lambda delay +lexpr led +lambda save +lambda restore +lambda call_cc call/cc +lambda collect +lambda nullp null? +lambda not diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 3c8fd21b..df277fce 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -95,7 +95,7 @@ ; (setq make-names (lambda (vars) - (cond (vars + (cond ((not (null? vars)) (cons (car (car vars)) (make-names (cdr vars)))) ) @@ -108,7 +108,7 @@ ; expressions to evaluate (setq make-exprs (lambda (vars exprs) - (cond (vars (cons + (cond ((not (null? vars)) (cons (list set (list quote (car (car vars)) @@ -127,7 +127,7 @@ ; of nils of the right length (setq make-nils (lambda (vars) - (cond (vars (cons nil (make-nils (cdr vars)))) + (cond ((not (null? vars)) (cons () (make-nils (cdr vars)))) ) ) ) @@ -149,13 +149,14 @@ ) ) +(let ((x 1)) x) + ; boolean operators (def or (lexpr (l) - (let ((ret nil)) - (while l - (cond ((setq ret (car l)) - (setq l nil)) + (let ((ret #f)) + (while (not (null? l)) + (cond ((car l) (setq ret #t) (setq l ())) ((setq l (cdr l))))) ret ) @@ -164,14 +165,16 @@ ; execute to resolve macros -(or nil t) +(or #f #t) (def and (lexpr (l) - (let ((ret t)) - (while l - (cond ((setq ret (car l)) + (let ((ret #t)) + (while (not (null? l)) + (cond ((car l) (setq l (cdr l))) - ((setq ret (setq l nil))) + (#t + (setq ret #f) + (setq l ())) ) ) ret @@ -181,4 +184,4 @@ ; execute to resolve macros -(and t nil) +(and #t #f) diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 3e68d14a..b6cb4fd8 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -107,6 +107,7 @@ ao_lisp_eval_sexpr(void) DBGI("..frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); ao_lisp_v = ao_lisp_atom_get(ao_lisp_v); /* fall through */ + case AO_LISP_BOOL: case AO_LISP_INT: case AO_LISP_STRING: case AO_LISP_BUILTIN: @@ -345,7 +346,7 @@ ao_lisp_eval_cond_test(void) DBGI("cond_test: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); - if (ao_lisp_v) { + if (ao_lisp_v != _ao_lisp_bool_false) { struct ao_lisp_cons *car = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car); ao_poly c = car->cdr; @@ -432,7 +433,7 @@ ao_lisp_eval_while_test(void) DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); - if (ao_lisp_v) { + if (ao_lisp_v != _ao_lisp_bool_false) { ao_lisp_stack->values = ao_lisp_v; ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; ao_lisp_stack->state = eval_while; diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c index 526863c5..cc333d6f 100644 --- a/src/lisp/ao_lisp_lambda.c +++ b/src/lisp/ao_lisp_lambda.c @@ -98,25 +98,25 @@ ao_lisp_lambda_alloc(struct ao_lisp_cons *code, int args) } ao_poly -ao_lisp_lambda(struct ao_lisp_cons *cons) +ao_lisp_do_lambda(struct ao_lisp_cons *cons) { return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LAMBDA); } ao_poly -ao_lisp_lexpr(struct ao_lisp_cons *cons) +ao_lisp_do_lexpr(struct ao_lisp_cons *cons) { return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LEXPR); } ao_poly -ao_lisp_nlambda(struct ao_lisp_cons *cons) +ao_lisp_do_nlambda(struct ao_lisp_cons *cons) { return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_NLAMBDA); } ao_poly -ao_lisp_macro(struct ao_lisp_cons *cons) +ao_lisp_do_macro(struct ao_lisp_cons *cons) { return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_MACRO); } diff --git a/src/lisp/ao_lisp_make_builtin b/src/lisp/ao_lisp_make_builtin new file mode 100644 index 00000000..5e98516c --- /dev/null +++ b/src/lisp/ao_lisp_make_builtin @@ -0,0 +1,149 @@ +#!/usr/bin/nickle + +typedef struct { + string type; + string c_name; + string lisp_name; +} builtin_t; + +string[string] type_map = { + "lambda" => "F_LAMBDA", + "nlambda" => "NLAMBDA", + "lexpr" => "F_LEXPR", + "macro" => "MACRO", +}; + +builtin_t +read_builtin(file f) { + string line = File::fgets(f); + string[*] tokens = String::wordsplit(line, " \t"); + + return (builtin_t) { + .type = dim(tokens) > 0 ? type_map[tokens[0]] : "#", + .c_name = dim(tokens) > 1 ? tokens[1] : "#", + .lisp_name = dim(tokens) > 2 ? tokens[2] : tokens[1] + }; +} + +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_ids(builtin_t[*] builtins) { + printf("#ifdef AO_LISP_BUILTIN_ID\n"); + printf("#undef AO_LISP_BUILTIN_ID\n"); + printf("enum ao_lisp_builtin_id {\n"); + for (int i = 0; i < dim(builtins); i++) + printf("\tbuiltin_%s,\n", builtins[i].c_name); + printf("\t_builtin_last\n"); + printf("};\n"); + printf("#endif /* AO_LISP_BUILTIN_ID */\n"); +} + +void +dump_casename(builtin_t[*] builtins) { + printf("#ifdef AO_LISP_BUILTIN_CASENAME\n"); + printf("#undef AO_LISP_BUILTIN_CASENAME\n"); + printf("static char *ao_lisp_builtin_name(enum ao_lisp_builtin_id b) {\n"); + printf("\tswitch(b) {\n"); + for (int i = 0; i < dim(builtins); i++) + printf("\tcase builtin_%s: return ao_lisp_poly_atom(_atom(%s))->name;\n", + builtins[i].c_name, builtins[i].c_name); + printf("\tdefault: return \"???\";\n"); + printf("\t}\n"); + printf("}\n"); + printf("#endif /* AO_LISP_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_LISP_BUILTIN_ARRAYNAME\n"); + printf("#undef AO_LISP_BUILTIN_ARRAYNAME\n"); + printf("static const ao_poly builtin_names[] = {\n"); + for (int i = 0; i < dim(builtins); i++) { + printf("\t[builtin_%s] = _ao_lisp_atom_", + builtins[i].c_name); + cify_lisp(builtins[i].lisp_name); + printf(",\n"); + } + printf("};\n"); + printf("#endif /* AO_LISP_BUILTIN_ARRAYNAME */\n"); +} + +void +dump_funcs(builtin_t[*] builtins) { + printf("#ifdef AO_LISP_BUILTIN_FUNCS\n"); + printf("#undef AO_LISP_BUILTIN_FUNCS\n"); + printf("const ao_lisp_func_t ao_lisp_builtins[] = {\n"); + for (int i = 0; i < dim(builtins); i++) { + printf("\t[builtin_%s] = ao_lisp_do_%s,\n", + builtins[i].c_name, + builtins[i].c_name); + } + printf("};\n"); + printf("#endif /* AO_LISP_BUILTIN_FUNCS */\n"); +} + +void +dump_decls(builtin_t[*] builtins) { + printf("#ifdef AO_LISP_BUILTIN_DECLS\n"); + printf("#undef AO_LISP_BUILTIN_DECLS\n"); + for (int i = 0; i < dim(builtins); i++) { + printf("ao_poly\n"); + printf("ao_lisp_do_%s(struct ao_lisp_cons *cons);\n", + builtins[i].c_name); + } + printf("#endif /* AO_LISP_BUILTIN_DECLS */\n"); +} + +void +dump_consts(builtin_t[*] builtins) { + printf("#ifdef AO_LISP_BUILTIN_CONSTS\n"); + printf("#undef AO_LISP_BUILTIN_CONSTS\n"); + printf("struct builtin_func funcs[] = {\n"); + for (int i = 0; i < dim(builtins); i++) { + printf ("\t{ .name = \"%s\", .args = AO_LISP_FUNC_%s, .func = builtin_%s },\n", + builtins[i].lisp_name, builtins[i].type, builtins[i].c_name); + } + printf("};\n"); + printf("#endif /* AO_LISP_BUILTIN_CONSTS */\n"); +} + +void main() { + if (dim(argv) < 2) { + File::fprintf(stderr, "usage: %s \n", argv[0]); + exit(1); + } + twixt(file f = File::open(argv[1], "r"); File::close(f)) { + builtin_t[*] builtins = read_builtins(f); + dump_ids(builtins); + dump_casename(builtins); + dump_arrayname(builtins); + dump_funcs(builtins); + dump_decls(builtins); + dump_consts(builtins); + } +} + +main(); diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 49f989e6..02cfa67e 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -34,46 +34,8 @@ struct builtin_func { int func; }; -struct builtin_func funcs[] = { - { .name = "eval", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_eval }, - { .name = "read", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_read }, - { .name = "lambda", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_lambda }, - { .name = "lexpr", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_lexpr }, - { .name = "nlambda", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_nlambda }, - { .name = "macro", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_macro }, - { .name = "car", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_car }, - { .name = "cdr", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_cdr }, - { .name = "cons", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_cons }, - { .name = "last", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_last }, - { .name = "length", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_length }, - { .name = "quote", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_quote }, - { .name = "set", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_set }, - { .name = "setq", .args = AO_LISP_FUNC_MACRO, .func = builtin_setq }, - { .name = "cond", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_cond }, - { .name = "progn", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_progn }, - { .name = "while", .args = AO_LISP_FUNC_NLAMBDA, .func = builtin_while }, - { .name = "print", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_print }, - { .name = "patom", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_patom }, - { .name = "+", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_plus }, - { .name = "-", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_minus }, - { .name = "*", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_times }, - { .name = "/", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_divide }, - { .name = "%", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_mod }, - { .name = "=", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_equal }, - { .name = "<", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_less }, - { .name = ">", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_greater }, - { .name = "<=", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_less_equal }, - { .name = ">=", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_greater_equal }, - { .name = "pack", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_pack }, - { .name = "unpack", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_unpack }, - { .name = "flush", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_flush }, - { .name = "delay", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_delay }, - { .name = "led", .args = AO_LISP_FUNC_F_LEXPR, .func = builtin_led }, - { .name = "save", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_save }, - { .name = "restore", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_restore }, - { .name = "call/cc", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_call_cc }, - { .name = "collect", .args = AO_LISP_FUNC_F_LAMBDA, .func = builtin_collect }, -}; +#define AO_LISP_BUILTIN_CONSTS +#include "ao_lisp_builtin.h" #define N_FUNC (sizeof funcs / sizeof funcs[0]) @@ -326,6 +288,10 @@ main(int argc, char **argv) } } + /* Boolean values #f and #t */ + ao_lisp_bool_get(0); + ao_lisp_bool_get(1); + for (f = 0; f < (int) N_FUNC; f++) { b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); a = ao_lisp_atom_intern(funcs[f].name); @@ -333,13 +299,6 @@ main(int argc, char **argv) ao_lisp_builtin_poly(b)); } - /* boolean constants */ - ao_lisp_atom_set(ao_lisp_atom_poly(ao_lisp_atom_intern("nil")), - AO_LISP_NIL); - a = ao_lisp_atom_intern("t"); - ao_lisp_atom_set(ao_lisp_atom_poly(a), - ao_lisp_atom_poly(a)); - /* end of file value */ a = ao_lisp_atom_intern("eof"); ao_lisp_atom_set(ao_lisp_atom_poly(a), @@ -387,6 +346,8 @@ main(int argc, char **argv) fprintf(out, "#define ao_builtin_frame 0x%04x\n", ao_lisp_frame_poly(ao_lisp_frame_global)); fprintf(out, "#define ao_lisp_const_checksum ((uint16_t) 0x%04x)\n", ao_fec_crc(ao_lisp_const, ao_lisp_top)); + fprintf(out, "#define _ao_lisp_bool_false 0x%04x\n", ao_lisp_bool_poly(ao_lisp_false)); + fprintf(out, "#define _ao_lisp_bool_true 0x%04x\n", ao_lisp_bool_poly(ao_lisp_true)); for (a = ao_lisp_atoms; a; a = ao_lisp_poly_atom(a->next)) { char *n = a->name, c; diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index d7c8d7a6..156221e8 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -211,6 +211,16 @@ static const struct ao_lisp_root ao_lisp_root[] = { .type = &ao_lisp_cons_type, .addr = (void **) &ao_lisp_read_stack, }, +#ifdef AO_LISP_MAKE_CONST + { + .type = &ao_lisp_bool_type, + .addr = (void **) &ao_lisp_false, + }, + { + .type = &ao_lisp_bool_type, + .addr = (void **) &ao_lisp_true, + }, +#endif }; #define AO_LISP_ROOT (sizeof (ao_lisp_root) / sizeof (ao_lisp_root[0])) @@ -447,6 +457,7 @@ static const struct ao_lisp_type *ao_lisp_types[AO_LISP_NUM_TYPE] = { [AO_LISP_FRAME] = &ao_lisp_frame_type, [AO_LISP_LAMBDA] = &ao_lisp_lambda_type, [AO_LISP_STACK] = &ao_lisp_stack_type, + [AO_LISP_BOOL] = &ao_lisp_bool_type, }; static int diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c index fb3b06fe..160734b1 100644 --- a/src/lisp/ao_lisp_poly.c +++ b/src/lisp/ao_lisp_poly.c @@ -52,6 +52,10 @@ static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { .print = ao_lisp_stack_print, .patom = ao_lisp_stack_print, }, + [AO_LISP_BOOL] = { + .print = ao_lisp_bool_print, + .patom = ao_lisp_bool_print, + }, }; static const struct ao_lisp_funcs * diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index 550f62c2..508d16b4 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -51,18 +51,18 @@ static const uint16_t lex_classes[128] = { PRINTABLE|WHITE, /* */ PRINTABLE, /* ! */ PRINTABLE|STRINGC, /* " */ - PRINTABLE|COMMENT, /* # */ + PRINTABLE|POUND, /* # */ PRINTABLE, /* $ */ PRINTABLE, /* % */ PRINTABLE, /* & */ - PRINTABLE|QUOTEC, /* ' */ - PRINTABLE|BRA, /* ( */ - PRINTABLE|KET, /* ) */ + PRINTABLE|SPECIAL, /* ' */ + PRINTABLE|SPECIAL, /* ( */ + PRINTABLE|SPECIAL, /* ) */ PRINTABLE, /* * */ PRINTABLE|SIGN, /* + */ PRINTABLE, /* , */ PRINTABLE|SIGN, /* - */ - PRINTABLE|DOTC, /* . */ + PRINTABLE|SPECIAL, /* . */ PRINTABLE, /* / */ PRINTABLE|DIGIT, /* 0 */ PRINTABLE|DIGIT, /* 1 */ @@ -283,27 +283,38 @@ _lex(void) continue; } - if (lex_class & (BRA|KET|QUOTEC)) { + if (lex_class & SPECIAL) { add_token(c); end_token(); switch (c) { case '(': + case '[': return OPEN; case ')': + case ']': return CLOSE; case '\'': return QUOTE; + case '.': + return DOT; } } - if (lex_class & (DOTC)) { - add_token(c); - end_token(); - return DOT; - } if (lex_class & TWIDDLE) { token_int = lexc(); return NUM; } + if (lex_class & POUND) { + for (;;) { + c = lexc(); + add_token(c); + switch (c) { + case 't': + return BOOL; + case 'f': + return BOOL; + } + } + } if (lex_class & STRINGC) { for (;;) { c = lexc(); @@ -457,6 +468,12 @@ ao_lisp_read(void) case NUM: v = ao_lisp_int_poly(token_int); break; + case BOOL: + if (token_string[0] == 't') + v = _ao_lisp_bool_true; + else + v = _ao_lisp_bool_false; + break; case STRING: string = ao_lisp_string_copy(token_string); if (string) diff --git a/src/lisp/ao_lisp_read.h b/src/lisp/ao_lisp_read.h index 30dcac3f..f8bcd195 100644 --- a/src/lisp/ao_lisp_read.h +++ b/src/lisp/ao_lisp_read.h @@ -15,6 +15,10 @@ #ifndef _AO_LISP_READ_H_ #define _AO_LISP_READ_H_ +/* + * token classes + */ + # define END 0 # define NAME 1 # define OPEN 2 @@ -23,29 +27,28 @@ # define STRING 5 # define NUM 6 # define DOT 7 +# define BOOL 8 /* * character classes */ -# define PRINTABLE 0x00000001 /* \t \n ' ' - '~' */ -# define QUOTED 0x00000002 /* \ anything */ -# define BRA 0x00000004 /* ( [ { */ -# define KET 0x00000008 /* ) ] } */ -# define WHITE 0x00000010 /* ' ' \t \n */ -# define DIGIT 0x00000020 /* [0-9] */ -# define SIGN 0x00000040 /* +- */ -# define ENDOFFILE 0x00000080 /* end of file */ -# define COMMENT 0x00000100 /* ; # */ -# define IGNORE 0x00000200 /* \0 - ' ' */ -# define QUOTEC 0x00000400 /* ' */ -# define BACKSLASH 0x00000800 /* \ */ -# define VBAR 0x00001000 /* | */ -# define TWIDDLE 0x00002000 /* ~ */ -# define STRINGC 0x00004000 /* " */ -# define DOTC 0x00008000 /* . */ +# define PRINTABLE 0x0001 /* \t \n ' ' - '~' */ +# define QUOTED 0x0002 /* \ anything */ +# define SPECIAL 0x0004 /* ( [ { ) ] } ' . */ +# define WHITE 0x0008 /* ' ' \t \n */ +# define DIGIT 0x0010 /* [0-9] */ +# define SIGN 0x0020 /* +- */ +# define ENDOFFILE 0x0040 /* end of file */ +# define COMMENT 0x0080 /* ; */ +# define IGNORE 0x0100 /* \0 - ' ' */ +# define BACKSLASH 0x0200 /* \ */ +# define VBAR 0x0400 /* | */ +# define TWIDDLE 0x0800 /* ~ */ +# define STRINGC 0x1000 /* " */ +# define POUND 0x2000 /* # */ -# define NOTNAME (STRINGC|TWIDDLE|VBAR|QUOTEC|COMMENT|ENDOFFILE|WHITE|KET|BRA|DOTC) +# define NOTNAME (STRINGC|TWIDDLE|VBAR|COMMENT|ENDOFFILE|WHITE|SPECIAL) # define NUMBER (DIGIT|SIGN) #endif /* _AO_LISP_READ_H_ */ diff --git a/src/lisp/ao_lisp_rep.c b/src/lisp/ao_lisp_rep.c index 3be95d44..ef7dbaf2 100644 --- a/src/lisp/ao_lisp_rep.c +++ b/src/lisp/ao_lisp_rep.c @@ -20,7 +20,7 @@ ao_lisp_read_eval_print(void) ao_poly in, out = AO_LISP_NIL; for(;;) { in = ao_lisp_read(); - if (in == _ao_lisp_atom_eof || in == AO_LISP_NIL) + if (in == _ao_lisp_atom_eof) break; out = ao_lisp_eval(in); if (ao_lisp_exception) { diff --git a/src/lisp/ao_lisp_save.c b/src/lisp/ao_lisp_save.c index 4f850fb9..cbc8e925 100644 --- a/src/lisp/ao_lisp_save.c +++ b/src/lisp/ao_lisp_save.c @@ -15,7 +15,7 @@ #include ao_poly -ao_lisp_save(struct ao_lisp_cons *cons) +ao_lisp_do_save(struct ao_lisp_cons *cons) { if (!ao_lisp_check_argc(_ao_lisp_atom_save, cons, 0, 0)) return AO_LISP_NIL; @@ -30,13 +30,13 @@ ao_lisp_save(struct ao_lisp_cons *cons) os->const_checksum_inv = (uint16_t) ~ao_lisp_const_checksum; if (ao_lisp_os_save()) - return _ao_lisp_atom_t; + return _ao_lisp_bool_true; #endif - return AO_LISP_NIL; + return _ao_lisp_bool_false; } ao_poly -ao_lisp_restore(struct ao_lisp_cons *cons) +ao_lisp_do_restore(struct ao_lisp_cons *cons) { if (!ao_lisp_check_argc(_ao_lisp_atom_save, cons, 0, 0)) return AO_LISP_NIL; @@ -68,9 +68,9 @@ ao_lisp_restore(struct ao_lisp_cons *cons) /* Re-create the evaluator stack */ if (!ao_lisp_eval_restart()) - return AO_LISP_NIL; - return _ao_lisp_atom_t; + return _ao_lisp_bool_false; + return _ao_lisp_bool_true; } #endif - return AO_LISP_NIL; + return _ao_lisp_bool_false; } diff --git a/src/lisp/ao_lisp_stack.c b/src/lisp/ao_lisp_stack.c index 53adf432..729a63ba 100644 --- a/src/lisp/ao_lisp_stack.c +++ b/src/lisp/ao_lisp_stack.c @@ -241,7 +241,7 @@ ao_lisp_stack_eval(void) * it a single argument which is the current continuation */ ao_poly -ao_lisp_call_cc(struct ao_lisp_cons *cons) +ao_lisp_do_call_cc(struct ao_lisp_cons *cons) { struct ao_lisp_stack *new; ao_poly v; -- cgit v1.2.3 From 0ced351c8f4449f7086b04e42c822d649f040d1f Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 16 Nov 2017 18:41:18 -0800 Subject: altos/lisp: Add 'else' sematics to cond Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 1 + src/lisp/ao_lisp_eval.c | 5 +++++ src/lisp/ao_lisp_make_const.c | 3 +++ 3 files changed, 9 insertions(+) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index cd002cc2..9a48a445 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -68,6 +68,7 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4))); #define _ao_lisp_atom_last _atom(last) #define _ao_lisp_atom_length _atom(length) #define _ao_lisp_atom_cond _atom(cond) +#define _ao_lisp_atom_else _atom(else) #define _ao_lisp_atom_lambda _atom(lambda) #define _ao_lisp_atom_led _atom(led) #define _ao_lisp_atom_delay _atom(delay) diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index b6cb4fd8..57227e93 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -324,6 +324,8 @@ ao_lisp_eval_cond(void) return 0; } ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; + if (ao_lisp_v == _ao_lisp_atom_else) + ao_lisp_v = _ao_lisp_bool_true; ao_lisp_stack->state = eval_cond_test; if (!ao_lisp_stack_push()) return 0; @@ -492,6 +494,9 @@ const char *ao_lisp_state_names[] = { "cond", "cond_test", "progn", + "while", + "while_test", + "macro", }; /* diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 02cfa67e..826c98b9 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -304,6 +304,9 @@ main(int argc, char **argv) ao_lisp_atom_set(ao_lisp_atom_poly(a), ao_lisp_atom_poly(a)); + /* 'else' */ + a = ao_lisp_atom_intern("else"); + if (argv[optind]){ in = fopen(argv[optind], "r"); if (!in) { -- cgit v1.2.3 From 2e58b6c380bc6440490c47650fbf11d45b3f2e72 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 16 Nov 2017 18:46:03 -0800 Subject: altos/lisp: More schemisms Add 'if'. setq -> set!, but doesn't define new variables def -> define Add pair? and list? Add eq? and eqv? as aliases for = Signed-off-by: Keith Packard --- src/lisp/ao_lisp_builtin.c | 36 +++++++++++++++++- src/lisp/ao_lisp_builtin.txt | 6 ++- src/lisp/ao_lisp_const.lisp | 87 ++++++++++++++++++++++++++++++------------- src/lisp/ao_lisp_make_builtin | 22 ++++++++--- 4 files changed, 117 insertions(+), 34 deletions(-) diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 6fc28820..d89404dc 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -210,11 +210,17 @@ ao_lisp_do_set(struct ao_lisp_cons *cons) ao_poly ao_lisp_do_setq(struct ao_lisp_cons *cons) { + ao_poly name; if (!ao_lisp_check_argc(_ao_lisp_atom_setq, cons, 2, 2)) return AO_LISP_NIL; + name = cons->car; + if (ao_lisp_poly_type(name) != AO_LISP_ATOM) + return ao_lisp_error(AO_LISP_INVALID, "set! of non-atom"); + if (!ao_lisp_atom_ref(ao_lisp_frame_current, name)) + return ao_lisp_error(AO_LISP_INVALID, "atom not defined"); return ao_lisp__cons(_ao_lisp_atom_set, ao_lisp__cons(ao_lisp__cons(_ao_lisp_atom_quote, - ao_lisp__cons(cons->car, AO_LISP_NIL)), + ao_lisp__cons(name, AO_LISP_NIL)), cons->cdr)); } @@ -559,5 +565,33 @@ ao_lisp_do_not(struct ao_lisp_cons *cons) return _ao_lisp_bool_false; } +ao_poly +ao_lisp_do_listp(struct ao_lisp_cons *cons) +{ + ao_poly v; + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + v = ao_lisp_arg(cons, 0); + for (;;) { + if (v == AO_LISP_NIL) + return _ao_lisp_bool_true; + if (ao_lisp_poly_type(v) != AO_LISP_CONS) + return _ao_lisp_bool_false; + v = ao_lisp_poly_cons(v)->cdr; + } +} + +ao_poly +ao_lisp_do_pairp(struct ao_lisp_cons *cons) +{ + ao_poly v; + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + v = ao_lisp_arg(cons, 0); + if (ao_lisp_poly_type(v) == AO_LISP_CONS) + return _ao_lisp_bool_true; + return _ao_lisp_bool_false; +} + #define AO_LISP_BUILTIN_FUNCS #include "ao_lisp_builtin.h" diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt index 02320df0..2b891dba 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/lisp/ao_lisp_builtin.txt @@ -11,7 +11,7 @@ lambda last lambda length nlambda quote lambda set -macro setq +macro setq set! nlambda cond nlambda progn nlambda while @@ -22,7 +22,7 @@ lexpr minus - lexpr times * lexpr divide / lexpr mod % -lexpr equal = +lexpr equal = eq? eqv? lexpr less < lexpr greater > lexpr less_equal <= @@ -38,3 +38,5 @@ lambda call_cc call/cc lambda collect lambda nullp null? lambda not +lambda listp list? +lambda pairp pair? diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index df277fce..37307a68 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -23,17 +23,17 @@ ; having lots of output generated ; -(setq def (macro (name val rest) - (list - 'progn - (list - 'set - (list 'quote name) - val) - (list 'quote name) - ) - ) - ) +(set (quote define) (macro (name val rest) + (list + 'progn + (list + 'set + (list 'quote name) + val) + (list 'quote name) + ) + ) + ) ; ; A slightly more convenient form @@ -42,9 +42,9 @@ ; (defun () s-exprs) ; -(def defun (macro (name args exprs) +(define defun (macro (name args exprs) (list - def + define name (cons 'lambda (cons args exprs)) ) @@ -69,6 +69,28 @@ (defun 1+ (x) (+ x 1)) (defun 1- (x) (- x 1)) +(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) + ; define a set of local ; variables and then evaluate ; a list of sexprs @@ -85,16 +107,16 @@ ; ; e.g. ; - ; (let ((x 1) (y)) (setq y (+ x 1)) y) + ; (let ((x 1) (y)) (set! y (+ x 1)) y) -(def let (macro (vars exprs) +(define let (macro (vars exprs) ((lambda (make-names make-exprs make-nils) ; ; make the list of names in the let ; - (setq make-names (lambda (vars) + (set! make-names (lambda (vars) (cond ((not (null? vars)) (cons (car (car vars)) (make-names (cdr vars)))) @@ -107,7 +129,7 @@ ; pre-pended to the ; expressions to evaluate - (setq make-exprs (lambda (vars exprs) + (set! make-exprs (lambda (vars exprs) (cond ((not (null? vars)) (cons (list set (list quote @@ -126,7 +148,7 @@ ; the parameters to the lambda is a list ; of nils of the right length - (setq make-nils (lambda (vars) + (set! make-nils (lambda (vars) (cond ((not (null? vars)) (cons () (make-nils (cdr vars)))) ) ) @@ -134,7 +156,7 @@ ; prepend the set operations ; to the expressions - (setq exprs (make-exprs vars exprs)) + (set! exprs (make-exprs vars exprs)) ; build the lambda. @@ -153,11 +175,11 @@ ; boolean operators -(def or (lexpr (l) +(define or (lexpr (l) (let ((ret #f)) (while (not (null? l)) - (cond ((car l) (setq ret #t) (setq l ())) - ((setq l (cdr l))))) + (cond ((car l) (set! ret #t) (set! l ())) + ((set! l (cdr l))))) ret ) ) @@ -167,14 +189,14 @@ (or #f #t) -(def and (lexpr (l) +(define and (lexpr (l) (let ((ret #t)) (while (not (null? l)) (cond ((car l) - (setq l (cdr l))) + (set! l (cdr l))) (#t - (setq ret #f) - (setq l ())) + (set! ret #f) + (set! l ())) ) ) ret @@ -185,3 +207,16 @@ ; execute to resolve macros (and #t #f) + +(defun 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)) diff --git a/src/lisp/ao_lisp_make_builtin b/src/lisp/ao_lisp_make_builtin index 5e98516c..b7b17cf4 100644 --- a/src/lisp/ao_lisp_make_builtin +++ b/src/lisp/ao_lisp_make_builtin @@ -3,7 +3,7 @@ typedef struct { string type; string c_name; - string lisp_name; + string[*] lisp_names; } builtin_t; string[string] type_map = { @@ -13,6 +13,16 @@ string[string] type_map = { "macro" => "MACRO", }; +string[*] +make_lisp(string[*] tokens) +{ + string[...] lisp = {}; + + if (dim(tokens) < 3) + return (string[1]) { tokens[dim(tokens) - 1] }; + return (string[dim(tokens)-2]) { [i] = tokens[i+2] }; +} + builtin_t read_builtin(file f) { string line = File::fgets(f); @@ -21,7 +31,7 @@ read_builtin(file f) { return (builtin_t) { .type = dim(tokens) > 0 ? type_map[tokens[0]] : "#", .c_name = dim(tokens) > 1 ? tokens[1] : "#", - .lisp_name = dim(tokens) > 2 ? tokens[2] : tokens[1] + .lisp_names = make_lisp(tokens), }; } @@ -84,7 +94,7 @@ dump_arrayname(builtin_t[*] builtins) { for (int i = 0; i < dim(builtins); i++) { printf("\t[builtin_%s] = _ao_lisp_atom_", builtins[i].c_name); - cify_lisp(builtins[i].lisp_name); + cify_lisp(builtins[i].lisp_names[0]); printf(",\n"); } printf("};\n"); @@ -123,8 +133,10 @@ dump_consts(builtin_t[*] builtins) { printf("#undef AO_LISP_BUILTIN_CONSTS\n"); printf("struct builtin_func funcs[] = {\n"); for (int i = 0; i < dim(builtins); i++) { - printf ("\t{ .name = \"%s\", .args = AO_LISP_FUNC_%s, .func = builtin_%s },\n", - builtins[i].lisp_name, builtins[i].type, builtins[i].c_name); + for (int j = 0; j < dim(builtins[i].lisp_names); j++) { + printf ("\t{ .name = \"%s\", .args = AO_LISP_FUNC_%s, .func = builtin_%s },\n", + builtins[i].lisp_names[j], builtins[i].type, builtins[i].c_name); + } } printf("};\n"); printf("#endif /* AO_LISP_BUILTIN_CONSTS */\n"); -- cgit v1.2.3 From cc76030d669600051fbb42a8cf85701aaaf5f5b7 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 16 Nov 2017 18:47:34 -0800 Subject: altos/test: Get lisp test building using Makefile-inc Instead of re-defining all of the lisp sources and headers Signed-off-by: Keith Packard --- src/test/Makefile | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/src/test/Makefile b/src/test/Makefile index 08808430..8d8740e4 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -1,4 +1,7 @@ -vpath % ..:../kernel:../drivers:../util:../micropeak:../aes:../product:../lisp +vpath %.o . +vpath %.c ..:../kernel:../drivers:../util:../micropeak:../aes:../product:../lisp +vpath %.h ..:../kernel:../drivers:../util:../micropeak:../aes:../product:../lisp +vpath make-kalman ..:../kernel:../drivers:../util:../micropeak:../aes:../product:../lisp PROGS=ao_flight_test ao_flight_test_baro ao_flight_test_accel ao_flight_test_noisy_accel ao_flight_test_mm \ ao_flight_test_metrum ao_flight_test_mini \ @@ -17,7 +20,7 @@ CFLAGS=-I.. -I. -I../kernel -I../drivers -I../micropeak -I../product -I../lisp - all: $(PROGS) ao_aprs_data.wav -clean: +clean:: rm -f $(PROGS) ao_aprs_data.wav run-out.baro run-out.full install: @@ -94,12 +97,16 @@ ao_ms5607_convert_test: ao_ms5607_convert_test.c ao_ms5607_convert_8051.c ao_int ao_quaternion_test: ao_quaternion_test.c ao_quaternion.h cc $(CFLAGS) -o $@ ao_quaternion_test.c -lm -AO_LISP_OBJS = ao_lisp_test.o ao_lisp_mem.o ao_lisp_cons.o ao_lisp_string.o \ - ao_lisp_atom.o ao_lisp_int.o ao_lisp_eval.o ao_lisp_poly.o \ - ao_lisp_builtin.o ao_lisp_read.o ao_lisp_rep.o ao_lisp_frame.o \ - ao_lisp_lambda.o ao_lisp_error.o ao_lisp_save.o ao_lisp_stack.o +include ../lisp/Makefile-inc + +AO_LISP_SRCS=$(LISP_SRCS) ao_lisp_test.c + +AO_LISP_OBJS=$(AO_LISP_SRCS:.c=.o) ao_lisp_test: $(AO_LISP_OBJS) cc $(CFLAGS) -o $@ $(AO_LISP_OBJS) -$(AO_LISP_OBJS): ao_lisp.h ao_lisp_const.h ao_lisp_os.h +$(AO_LISP_OBJS): $(LISP_HDRS) + +clean:: + rm -f $(AO_LISP_OBJS) -- cgit v1.2.3 From 435a91ae3889cd361b543f4555a78488905e0bbb Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 16 Nov 2017 22:13:46 -0800 Subject: altos/lisp: Lots more scheme bits * Arithmetic functions and tests * append, reverse and list-tail * set-car! and set-cdr! Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 2 +- src/lisp/ao_lisp_builtin.c | 105 ++++++++++++++++++++++++++++++--- src/lisp/ao_lisp_builtin.txt | 8 ++- src/lisp/ao_lisp_const.lisp | 136 +++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 240 insertions(+), 11 deletions(-) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 9a48a445..341996c0 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -136,7 +136,7 @@ ao_lisp_is_const(ao_poly poly) { #define AO_LISP_IS_CONST(a) (ao_lisp_const <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_lisp_const + AO_LISP_POOL_CONST) #define AO_LISP_IS_POOL(a) (ao_lisp_pool <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_lisp_pool + AO_LISP_POOL) -#define AO_LISP_IS_INT(p) (ao_lisp_base_type(p) == AO_LISP_INT); +#define AO_LISP_IS_INT(p) (ao_lisp_poly_base_type(p) == AO_LISP_INT) void * ao_lisp_ref(ao_poly poly); diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index d89404dc..2c5608e7 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -277,6 +277,7 @@ ao_lisp_do_patom(struct ao_lisp_cons *cons) ao_poly ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) { + struct ao_lisp_cons *orig_cons = cons; ao_poly ret = AO_LISP_NIL; while (cons) { @@ -284,12 +285,29 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) uint8_t rt = ao_lisp_poly_type(ret); uint8_t ct = ao_lisp_poly_type(car); - cons = ao_lisp_poly_cons(cons->cdr); - - if (rt == AO_LISP_NIL) + if (cons == orig_cons) { ret = car; - - else if (rt == AO_LISP_INT && ct == AO_LISP_INT) { + if (cons->cdr == AO_LISP_NIL && ct == AO_LISP_INT) { + switch (op) { + case builtin_minus: + ret = ao_lisp_int_poly(-ao_lisp_poly_int(ret)); + break; + case builtin_divide: + switch (ao_lisp_poly_int(ret)) { + case 0: + return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero"); + case 1: + break; + default: + ret = ao_lisp_int_poly(0); + break; + } + break; + default: + break; + } + } + } else if (rt == AO_LISP_INT && ct == AO_LISP_INT) { int r = ao_lisp_poly_int(ret); int c = ao_lisp_poly_int(car); @@ -308,11 +326,26 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero"); r /= c; break; - case builtin_mod: + case builtin_quotient: if (c == 0) - return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "mod by zero"); + return ao_lisp_error(AO_LISP_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_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "remainder by zero"); r %= c; break; + case builtin_modulo: + if (c == 0) + return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "modulo by zero"); + r %= c; + if ((r < 0) != (c < 0)) + r += c; + break; default: break; } @@ -324,6 +357,8 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) ao_lisp_poly_string(car))); else return ao_lisp_error(AO_LISP_INVALID, "invalid args"); + + cons = ao_lisp_poly_cons(cons->cdr); } return ret; } @@ -353,9 +388,21 @@ ao_lisp_do_divide(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_do_mod(struct ao_lisp_cons *cons) +ao_lisp_do_quotient(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, builtin_quotient); +} + +ao_poly +ao_lisp_do_modulo(struct ao_lisp_cons *cons) { - return ao_lisp_math(cons, builtin_mod); + return ao_lisp_math(cons, builtin_modulo); +} + +ao_poly +ao_lisp_do_remainder(struct ao_lisp_cons *cons) +{ + return ao_lisp_math(cons, builtin_remainder); } ao_poly @@ -593,5 +640,45 @@ ao_lisp_do_pairp(struct ao_lisp_cons *cons) return _ao_lisp_bool_false; } +ao_poly +ao_lisp_do_numberp(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + if (AO_LISP_IS_INT(ao_lisp_arg(cons, 0))) + return _ao_lisp_bool_true; + return _ao_lisp_bool_false; +} + +ao_poly +ao_lisp_do_booleanp(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + if (ao_lisp_poly_type(ao_lisp_arg(cons, 0)) == AO_LISP_BOOL) + return _ao_lisp_bool_true; + return _ao_lisp_bool_false; +} + +ao_poly +ao_lisp_do_set_car(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 2, 2)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_CONS, 0)) + return AO_LISP_NIL; + return ao_lisp_poly_cons(ao_lisp_arg(cons, 0))->car = ao_lisp_arg(cons, 1); +} + +ao_poly +ao_lisp_do_set_cdr(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 2, 2)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_CONS, 0)) + return AO_LISP_NIL; + return ao_lisp_poly_cons(ao_lisp_arg(cons, 0))->cdr = ao_lisp_arg(cons, 1); +} + #define AO_LISP_BUILTIN_FUNCS #include "ao_lisp_builtin.h" diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt index 2b891dba..b27985ff 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/lisp/ao_lisp_builtin.txt @@ -21,7 +21,9 @@ lexpr plus + lexpr minus - lexpr times * lexpr divide / -lexpr mod % +lexpr modulo modulo % +lexpr remainder +lexpr quotient lexpr equal = eq? eqv? lexpr less < lexpr greater > @@ -40,3 +42,7 @@ lambda nullp null? lambda not lambda listp list? lambda pairp pair? +lambda numberp number? integer? +lambda booleanp boolean? +lambda set_car set-car! +lambda set_cdr set-cdr! diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 37307a68..3ba6aaf5 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -69,6 +69,93 @@ (defun 1+ (x) (+ x 1)) (defun 1- (x) (- x 1)) +(define zero? (macro (value rest) + (list + eq? + value + 0) + ) + ) + +(zero? 1) +(zero? 0) +(zero? "hello") + +(define positive? (macro (value rest) + (list + > + value + 0) + ) + ) + +(positive? 12) +(positive? -12) + +(define negative? (macro (value rest) + (list + < + value + 0) + ) + ) + +(negative? 12) +(negative? -12) + +(defun abs (x) (cond ((>= x 0) x) + (else (- x))) + ) + +(abs 12) +(abs -12) + +(define max (lexpr (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 (lexpr (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) + +(defun even? (x) (zero? (% x 2))) + +(even? 2) +(even? -2) +(even? 3) +(even? -1) + +(defun odd? (x) (not (even? x))) + +(odd? 2) +(odd? -2) +(odd? 3) +(odd? -1) + +(define exact? number?) +(defun inexact? (x) #f) + + ; (if ) + ; (if string (lexpr (arg opt) +; (let ((base (if (null? opt) 10 (car opt))) + ; +; + -- cgit v1.2.3 From cd9152973f29f4e775569f5acbbe8fab2d93d170 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Thu, 16 Nov 2017 22:15:06 -0800 Subject: altos/test: More lisp test Makefile fixes Depend on ao_lisp_const.h Signed-off-by: Keith Packard --- src/test/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/test/Makefile b/src/test/Makefile index 8d8740e4..9fe886b9 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -106,7 +106,7 @@ AO_LISP_OBJS=$(AO_LISP_SRCS:.c=.o) ao_lisp_test: $(AO_LISP_OBJS) cc $(CFLAGS) -o $@ $(AO_LISP_OBJS) -$(AO_LISP_OBJS): $(LISP_HDRS) +$(AO_LISP_OBJS): $(LISP_HDRS) ao_lisp_const.h clean:: rm -f $(AO_LISP_OBJS) -- cgit v1.2.3 From 5b6f4b5de89a2bb0d63442e2651cf8d2ee0f4b10 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 17 Nov 2017 08:04:28 -0800 Subject: altos/lisp: Generate built-in lambda atoms for const creation Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 32 ++++++-------------------------- src/lisp/ao_lisp_make_builtin | 17 +++++++++++++++++ 2 files changed, 23 insertions(+), 26 deletions(-) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 341996c0..77a94cf1 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -59,33 +59,13 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4))); #define _ao_lisp_bool_true _bool(1) #define _ao_lisp_bool_false _bool(0) -#define _ao_lisp_atom_quote _atom(quote) -#define _ao_lisp_atom_set _atom(set) -#define _ao_lisp_atom_setq _atom(setq) -#define _ao_lisp_atom_car _atom(car) -#define _ao_lisp_atom_cdr _atom(cdr) -#define _ao_lisp_atom_cons _atom(cons) -#define _ao_lisp_atom_last _atom(last) -#define _ao_lisp_atom_length _atom(length) -#define _ao_lisp_atom_cond _atom(cond) -#define _ao_lisp_atom_else _atom(else) -#define _ao_lisp_atom_lambda _atom(lambda) -#define _ao_lisp_atom_led _atom(led) -#define _ao_lisp_atom_delay _atom(delay) -#define _ao_lisp_atom_pack _atom(pack) -#define _ao_lisp_atom_unpack _atom(unpack) -#define _ao_lisp_atom_flush _atom(flush) -#define _ao_lisp_atom_eval _atom(eval) -#define _ao_lisp_atom_read _atom(read) + #define _ao_lisp_atom_eof _atom(eof) -#define _ao_lisp_atom_save _atom(save) -#define _ao_lisp_atom_restore _atom(restore) -#define _ao_lisp_atom_call2fcc _atom(call/cc) -#define _ao_lisp_atom_collect _atom(collect) -#define _ao_lisp_atom_symbolp _atom(symbol?) -#define _ao_lisp_atom_builtin _atom(builtin?) -#define _ao_lisp_atom_symbolp _atom(symbol?) -#define _ao_lisp_atom_symbolp _atom(symbol?) +#define _ao_lisp_atom_else _atom(else) + +#define AO_LISP_BUILTIN_ATOMS +#include "ao_lisp_builtin.h" + #else #include "ao_lisp_const.h" #ifndef AO_LISP_POOL diff --git a/src/lisp/ao_lisp_make_builtin b/src/lisp/ao_lisp_make_builtin index b7b17cf4..ddc9a0b3 100644 --- a/src/lisp/ao_lisp_make_builtin +++ b/src/lisp/ao_lisp_make_builtin @@ -142,6 +142,22 @@ dump_consts(builtin_t[*] builtins) { printf("#endif /* AO_LISP_BUILTIN_CONSTS */\n"); } +void +dump_atoms(builtin_t[*] builtins) { + printf("#ifdef AO_LISP_BUILTIN_ATOMS\n"); + printf("#undef AO_LISP_BUILTIN_ATOMS\n"); + for (int i = 0; i < dim(builtins); i++) { + for (int j = 0; j < dim(builtins[i].lisp_names); j++) { + printf("#define _ao_lisp_atom_"); + cify_lisp(builtins[i].lisp_names[j]); + printf(" _atom("); + cify_lisp(builtins[i].lisp_names[j]); + printf(")\n"); + } + } + printf("#endif /* AO_LISP_BUILTIN_ATOMS */\n"); +} + void main() { if (dim(argv) < 2) { File::fprintf(stderr, "usage: %s \n", argv[0]); @@ -155,6 +171,7 @@ void main() { dump_funcs(builtins); dump_decls(builtins); dump_consts(builtins); + dump_atoms(builtins); } } -- cgit v1.2.3 From a4e18a13029cc7b16b2ed9da84d6e606bc725ac3 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 17 Nov 2017 08:50:50 -0800 Subject: altos/lisp: Character consts. String and assoc builtins. Also add back escaped characters in strings. Signed-off-by: Keith Packard --- src/lisp/ao_lisp_builtin.c | 98 ++++++++++++++++++++++++------------- src/lisp/ao_lisp_builtin.txt | 8 ++- src/lisp/ao_lisp_const.lisp | 110 +++++++++++++++++++++++++++++++++++++++++ src/lisp/ao_lisp_read.c | 113 +++++++++++++++++++++++++++---------------- src/lisp/ao_lisp_read.h | 7 ++- 5 files changed, 256 insertions(+), 80 deletions(-) diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 2c5608e7..b2941d58 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -211,7 +211,7 @@ ao_poly ao_lisp_do_setq(struct ao_lisp_cons *cons) { ao_poly name; - if (!ao_lisp_check_argc(_ao_lisp_atom_setq, cons, 2, 2)) + if (!ao_lisp_check_argc(_ao_lisp_atom_set21, cons, 2, 2)) return AO_LISP_NIL; name = cons->car; if (ao_lisp_poly_type(name) != AO_LISP_ATOM) @@ -510,21 +510,21 @@ ao_lisp_do_greater_equal(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_do_pack(struct ao_lisp_cons *cons) +ao_lisp_do_list_to_string(struct ao_lisp_cons *cons) { - if (!ao_lisp_check_argc(_ao_lisp_atom_pack, cons, 1, 1)) + if (!ao_lisp_check_argc(_ao_lisp_atom_list2d3estring, cons, 1, 1)) return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_pack, cons, 0, AO_LISP_CONS, 1)) + if (!ao_lisp_check_argt(_ao_lisp_atom_list2d3estring, cons, 0, AO_LISP_CONS, 1)) return AO_LISP_NIL; return ao_lisp_string_pack(ao_lisp_poly_cons(ao_lisp_arg(cons, 0))); } ao_poly -ao_lisp_do_unpack(struct ao_lisp_cons *cons) +ao_lisp_do_string_to_list(struct ao_lisp_cons *cons) { - if (!ao_lisp_check_argc(_ao_lisp_atom_unpack, cons, 1, 1)) + if (!ao_lisp_check_argc(_ao_lisp_atom_string2d3elist, cons, 1, 1)) return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_unpack, cons, 0, AO_LISP_STRING, 0)) + if (!ao_lisp_check_argt(_ao_lisp_atom_string2d3elist, cons, 0, AO_LISP_STRING, 0)) return AO_LISP_NIL; return ao_lisp_string_unpack(ao_lisp_poly_string(ao_lisp_arg(cons, 0))); } @@ -612,52 +612,63 @@ ao_lisp_do_not(struct ao_lisp_cons *cons) return _ao_lisp_bool_false; } -ao_poly -ao_lisp_do_listp(struct ao_lisp_cons *cons) +static ao_poly +ao_lisp_do_typep(int type, struct ao_lisp_cons *cons) { - ao_poly v; if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) return AO_LISP_NIL; - v = ao_lisp_arg(cons, 0); - for (;;) { - if (v == AO_LISP_NIL) - return _ao_lisp_bool_true; - if (ao_lisp_poly_type(v) != AO_LISP_CONS) - return _ao_lisp_bool_false; - v = ao_lisp_poly_cons(v)->cdr; - } + if (ao_lisp_poly_type(ao_lisp_arg(cons, 0)) == type) + return _ao_lisp_bool_true; + return _ao_lisp_bool_false; } ao_poly ao_lisp_do_pairp(struct ao_lisp_cons *cons) { - ao_poly v; - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - v = ao_lisp_arg(cons, 0); - if (ao_lisp_poly_type(v) == AO_LISP_CONS) - return _ao_lisp_bool_true; - return _ao_lisp_bool_false; + return ao_lisp_do_typep(AO_LISP_CONS, cons); } ao_poly ao_lisp_do_numberp(struct ao_lisp_cons *cons) { - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - if (AO_LISP_IS_INT(ao_lisp_arg(cons, 0))) - return _ao_lisp_bool_true; - return _ao_lisp_bool_false; + return ao_lisp_do_typep(AO_LISP_INT, cons); +} + +ao_poly +ao_lisp_do_stringp(struct ao_lisp_cons *cons) +{ + return ao_lisp_do_typep(AO_LISP_STRING, cons); +} + +ao_poly +ao_lisp_do_symbolp(struct ao_lisp_cons *cons) +{ + return ao_lisp_do_typep(AO_LISP_ATOM, cons); } ao_poly ao_lisp_do_booleanp(struct ao_lisp_cons *cons) { + return ao_lisp_do_typep(AO_LISP_BOOL, cons); +} + +/* This one is special -- a list is either nil or + * a 'proper' list with only cons cells + */ +ao_poly +ao_lisp_do_listp(struct ao_lisp_cons *cons) +{ + ao_poly v; if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) return AO_LISP_NIL; - if (ao_lisp_poly_type(ao_lisp_arg(cons, 0)) == AO_LISP_BOOL) - return _ao_lisp_bool_true; - return _ao_lisp_bool_false; + v = ao_lisp_arg(cons, 0); + for (;;) { + if (v == AO_LISP_NIL) + return _ao_lisp_bool_true; + if (ao_lisp_poly_type(v) != AO_LISP_CONS) + return _ao_lisp_bool_false; + v = ao_lisp_poly_cons(v)->cdr; + } } ao_poly @@ -680,5 +691,26 @@ ao_lisp_do_set_cdr(struct ao_lisp_cons *cons) return ao_lisp_poly_cons(ao_lisp_arg(cons, 0))->cdr = ao_lisp_arg(cons, 1); } +ao_poly +ao_lisp_do_symbol_to_string(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_ATOM, 0)) + return AO_LISP_NIL; + return ao_lisp_string_poly(ao_lisp_string_copy(ao_lisp_poly_atom(ao_lisp_arg(cons, 0))->name)); +} + +ao_poly +ao_lisp_do_string_to_symbol(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_STRING, 0)) + return AO_LISP_NIL; + + return ao_lisp_atom_poly(ao_lisp_atom_intern(ao_lisp_poly_string(ao_lisp_arg(cons, 0)))); +} + #define AO_LISP_BUILTIN_FUNCS #include "ao_lisp_builtin.h" diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt index b27985ff..6cb4fdae 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/lisp/ao_lisp_builtin.txt @@ -29,8 +29,8 @@ lexpr less < lexpr greater > lexpr less_equal <= lexpr greater_equal >= -lambda pack -lambda unpack +lambda list_to_string list->string +lambda string_to_list string->list lambda flush lambda delay lexpr led @@ -46,3 +46,7 @@ lambda numberp number? integer? lambda booleanp boolean? lambda set_car set-car! lambda set_cdr set-cdr! +lambda symbolp symbol? +lambda symbol_to_string symbol->string +lambda string_to_symbol string->symbol +lambda stringp string? diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 3ba6aaf5..17509044 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -54,6 +54,8 @@ ; basic list accessors +(defun caar (l) (car (car l))) + (defun cadr (l) (car (cdr l))) (defun caddr (l) (car (cdr (cdr l)))) @@ -336,6 +338,12 @@ (list-tail (cdr x) (- k 1))))) (list-tail '(1 2 3) 2) + +(defun list-ref (x k) (car (list-tail x k))) + +(list-ref '(1 2 3) 2) + + ; recursive equality (defun equal? (a b) @@ -351,6 +359,108 @@ (equal? '(a b c) '(a b c)) (equal? '(a b c) '(a b b)) +(defun _member (obj list test?) + (if (null? list) + #f + (if (test? obj (car list)) + list + (memq obj (cdr list))))) + +(defun memq (obj list) (_member obj list eq?)) + +(memq 2 '(1 2 3)) + +(memq 4 '(1 2 3)) + +(defun memv (obj list) (_member obj list eqv?)) + +(memv 2 '(1 2 3)) + +(memv 4 '(1 2 3)) + +(defun member (obj list) (_member obj list equal?)) + +(member '(2) '((1) (2) (3))) + +(member '(4) '((1) (2) (3))) + +(defun _assoc (obj list test?) + (if (null? list) + #f + (if (test? obj (caar list)) + (car list) + (_assoc obj (cdr list) test?) + ) + ) + ) + +(defun assq (obj list) (_assoc obj list eq?)) +(defun assv (obj list) (_assoc obj list eqv?)) +(defun 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") + +(defun char-upper-case? (c) (<= #\A c #\Z)) + +(char-upper-case? #\a) +(char-upper-case? #\B) +(char-upper-case? #\0) +(char-upper-case? #\space) + +(defun char-lower-case? (c) (<= #\a c #\a)) + +(char-lower-case? #\a) +(char-lower-case? #\B) +(char-lower-case? #\0) +(char-lower-case? #\space) + +(defun char-alphabetic? (c) (or (char-upper-case? c) (char-lower-case? c))) + +(char-alphabetic? #\a) +(char-alphabetic? #\B) +(char-alphabetic? #\0) +(char-alphabetic? #\space) + +(defun char-numeric? (c) (<= #\0 c #\9)) + +(char-numeric? #\a) +(char-numeric? #\B) +(char-numeric? #\0) +(char-numeric? #\space) + +(defun char-whitespace? (c) (or (<= #\tab c #\return) (= #\space c))) + +(char-whitespace? #\a) +(char-whitespace? #\B) +(char-whitespace? #\0) +(char-whitespace? #\space) + +(defun char->integer (c) c) +(defun integer->char (c) char-integer) + +(defun char-upcase (c) (if (char-lower-case? c) (+ c (- #\A #\a)) c)) + +(char-upcase #\a) +(char-upcase #\B) +(char-upcase #\0) +(char-upcase #\space) + +(defun 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 (lexpr (chars) (list->string chars))) + ;(define number->string (lexpr (arg opt) ; (let ((base (if (null? opt) 10 (car opt))) ; diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index 508d16b4..bcd23ce1 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -142,7 +142,7 @@ static const uint16_t lex_classes[128] = { PRINTABLE, /* { */ PRINTABLE|VBAR, /* | */ PRINTABLE, /* } */ - PRINTABLE|TWIDDLE, /* ~ */ + PRINTABLE, /* ~ */ IGNORE, /* ^? */ }; @@ -168,16 +168,38 @@ lex_unget(int c) 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) +lex_quoted(void) { int c; int v; int count; c = lex_get(); - if (c == EOF) - return EOF; + if (c == EOF) { + lex_class = ENDOFFILE; + return 0; + } + lex_class = 0; c &= 0x7f; switch (c) { case 'n': @@ -220,32 +242,6 @@ lex_quoted (void) } } -static uint16_t lex_class; - -static int -lexc(void) -{ - int c; - do { - c = lex_get(); - if (c == EOF) { - lex_class = ENDOFFILE; - c = 0; - } else { - c &= 0x7f; - lex_class = lex_classes[c]; - if (lex_class & BACKSLASH) { - c = lex_quoted(); - if (c == EOF) - lex_class = ENDOFFILE; - else - lex_class = PRINTABLE; - } - } - } while (lex_class & IGNORE); - return c; -} - #define AO_LISP_TOKEN_MAX 32 static char token_string[AO_LISP_TOKEN_MAX]; @@ -299,25 +295,60 @@ _lex(void) return DOT; } } - if (lex_class & TWIDDLE) { - token_int = lexc(); - return NUM; - } if (lex_class & POUND) { - for (;;) { - c = lexc(); + c = lexc(); + switch (c) { + case 't': add_token(c); - switch (c) { - case 't': - return BOOL; - case 'f': - return BOOL; + end_token(); + return BOOL; + case 'f': + add_token(c); + end_token(); + return BOOL; + 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_lisp_error(AO_LISP_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; diff --git a/src/lisp/ao_lisp_read.h b/src/lisp/ao_lisp_read.h index f8bcd195..fc74a8e4 100644 --- a/src/lisp/ao_lisp_read.h +++ b/src/lisp/ao_lisp_read.h @@ -44,11 +44,10 @@ # define IGNORE 0x0100 /* \0 - ' ' */ # define BACKSLASH 0x0200 /* \ */ # define VBAR 0x0400 /* | */ -# define TWIDDLE 0x0800 /* ~ */ -# define STRINGC 0x1000 /* " */ -# define POUND 0x2000 /* # */ +# define STRINGC 0x0800 /* " */ +# define POUND 0x1000 /* # */ -# define NOTNAME (STRINGC|TWIDDLE|VBAR|COMMENT|ENDOFFILE|WHITE|SPECIAL) +# define NOTNAME (STRINGC|VBAR|COMMENT|ENDOFFILE|WHITE|SPECIAL) # define NUMBER (DIGIT|SIGN) #endif /* _AO_LISP_READ_H_ */ -- cgit v1.2.3 From e1acf5eb12aceda7aa838df031c1da1129d0fa5d Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 17 Nov 2017 22:14:19 -0800 Subject: altos/lisp: Add apply And all of the library routines that use it, map, string-map and friends. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 7 +-- src/lisp/ao_lisp_builtin.c | 40 +++++++++++++--- src/lisp/ao_lisp_builtin.txt | 106 +++++++++++++++++++++--------------------- src/lisp/ao_lisp_cons.c | 30 ++++++++---- src/lisp/ao_lisp_const.lisp | 74 +++++++++++++++++++++++++---- src/lisp/ao_lisp_eval.c | 57 ++++++++++++++++++----- src/lisp/ao_lisp_make_builtin | 14 +++--- src/lisp/ao_lisp_read.c | 2 +- 8 files changed, 230 insertions(+), 100 deletions(-) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 77a94cf1..a445dddd 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -54,14 +54,14 @@ extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4))); #define ao_lisp_pool ao_lisp_const #define AO_LISP_POOL AO_LISP_POOL_CONST -#define _atom(n) ao_lisp_atom_poly(ao_lisp_atom_intern(#n)) +#define _atom(n) ao_lisp_atom_poly(ao_lisp_atom_intern(n)) #define _bool(v) ao_lisp_bool_poly(ao_lisp_bool_get(v)) #define _ao_lisp_bool_true _bool(1) #define _ao_lisp_bool_false _bool(0) -#define _ao_lisp_atom_eof _atom(eof) -#define _ao_lisp_atom_else _atom(else) +#define _ao_lisp_atom_eof _atom("eof") +#define _ao_lisp_atom_else _atom("else") #define AO_LISP_BUILTIN_ATOMS #include "ao_lisp_builtin.h" @@ -184,6 +184,7 @@ enum eval_state { 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_progn, /* Start next progn entry */ diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index b2941d58..d37d0284 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -13,6 +13,7 @@ */ #include "ao_lisp.h" +#include static int builtin_size(void *addr) @@ -44,15 +45,13 @@ const struct ao_lisp_type ao_lisp_builtin_type = { #define AO_LISP_BUILTIN_CASENAME #include "ao_lisp_builtin.h" -#define _atomn(n) ao_lisp_poly_atom(_atom(n)) - char *ao_lisp_args_name(uint8_t args) { args &= AO_LISP_FUNC_MASK; switch (args) { - case AO_LISP_FUNC_LAMBDA: return _atomn(lambda)->name; - case AO_LISP_FUNC_LEXPR: return _atomn(lexpr)->name; - case AO_LISP_FUNC_NLAMBDA: return _atomn(nlambda)->name; - case AO_LISP_FUNC_MACRO: return _atomn(macro)->name; + case AO_LISP_FUNC_LAMBDA: return ao_lisp_poly_atom(_ao_lisp_atom_lambda)->name; + case AO_LISP_FUNC_LEXPR: return ao_lisp_poly_atom(_ao_lisp_atom_lexpr)->name; + case AO_LISP_FUNC_NLAMBDA: return ao_lisp_poly_atom(_ao_lisp_atom_nlambda)->name; + case AO_LISP_FUNC_MACRO: return ao_lisp_poly_atom(_ao_lisp_atom_macro)->name; default: return "???"; } } @@ -282,6 +281,7 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) while (cons) { ao_poly car = cons->car; + ao_poly cdr; uint8_t rt = ao_lisp_poly_type(ret); uint8_t ct = ao_lisp_poly_type(car); @@ -358,7 +358,10 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) else return ao_lisp_error(AO_LISP_INVALID, "invalid args"); - cons = ao_lisp_poly_cons(cons->cdr); + cdr = cons->cdr; + if (cdr != AO_LISP_NIL && ao_lisp_poly_type(cdr) != AO_LISP_CONS) + return ao_lisp_error(AO_LISP_INVALID, "improper list"); + cons = ao_lisp_poly_cons(cdr); } return ret; } @@ -573,6 +576,15 @@ ao_lisp_do_eval(struct ao_lisp_cons *cons) return cons->car; } +ao_poly +ao_lisp_do_apply(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_apply, cons, 2, INT_MAX)) + return AO_LISP_NIL; + ao_lisp_stack->state = eval_apply; + return ao_lisp_cons_poly(cons); +} + ao_poly ao_lisp_do_read(struct ao_lisp_cons *cons) { @@ -652,6 +664,20 @@ ao_lisp_do_booleanp(struct ao_lisp_cons *cons) return ao_lisp_do_typep(AO_LISP_BOOL, cons); } +ao_poly +ao_lisp_do_procedurep(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) { + case AO_LISP_BUILTIN: + case AO_LISP_LAMBDA: + return _ao_lisp_bool_true; + default: + return _ao_lisp_bool_false; + } +} + /* This one is special -- a list is either nil or * a 'proper' list with only cons cells */ diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt index 6cb4fdae..ba6455ab 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/lisp/ao_lisp_builtin.txt @@ -1,52 +1,54 @@ -lambda eval -lambda read -nlambda lambda -nlambda lexpr -nlambda nlambda -nlambda macro -lambda car -lambda cdr -lambda cons -lambda last -lambda length -nlambda quote -lambda set -macro setq set! -nlambda cond -nlambda progn -nlambda while -lexpr print -lexpr patom -lexpr plus + -lexpr minus - -lexpr times * -lexpr divide / -lexpr modulo modulo % -lexpr remainder -lexpr quotient -lexpr equal = eq? eqv? -lexpr less < -lexpr greater > -lexpr less_equal <= -lexpr greater_equal >= -lambda list_to_string list->string -lambda string_to_list string->list -lambda flush -lambda delay -lexpr led -lambda save -lambda restore -lambda call_cc call/cc -lambda collect -lambda nullp null? -lambda not -lambda listp list? -lambda pairp pair? -lambda numberp number? integer? -lambda booleanp boolean? -lambda set_car set-car! -lambda set_cdr set-cdr! -lambda symbolp symbol? -lambda symbol_to_string symbol->string -lambda string_to_symbol string->symbol -lambda stringp string? +f_lambda eval +f_lambda read +nlambda lambda +nlambda lexpr +nlambda nlambda +nlambda macro +f_lambda car +f_lambda cdr +f_lambda cons +f_lambda last +f_lambda length +nlambda quote +f_lambda set +macro setq set! +nlambda cond +nlambda progn +nlambda while +f_lexpr print +f_lexpr patom +f_lexpr plus + +f_lexpr minus - +f_lexpr times * +f_lexpr divide / +f_lexpr modulo modulo % +f_lexpr remainder +f_lexpr quotient +f_lexpr equal = eq? eqv? +f_lexpr less < +f_lexpr greater > +f_lexpr less_equal <= +f_lexpr greater_equal >= +f_lambda list_to_string list->string +f_lambda string_to_list string->list +f_lambda flush +f_lambda delay +f_lexpr led +f_lambda save +f_lambda restore +f_lambda call_cc call-with-current-continuation call/cc +f_lambda collect +f_lambda nullp null? +f_lambda not +f_lambda listp list? +f_lambda pairp pair? +f_lambda numberp number? integer? +f_lambda booleanp boolean? +f_lambda set_car set-car! +f_lambda set_cdr set-cdr! +f_lambda symbolp symbol? +f_lambda symbol_to_string symbol->string +f_lambda string_to_symbol string->symbol +f_lambda stringp string? +f_lambda procedurep procedure? +lexpr apply diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index 81a16a7a..8d607372 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -19,10 +19,16 @@ static void cons_mark(void *addr) struct ao_lisp_cons *cons = addr; for (;;) { + ao_poly cdr = cons->cdr; + ao_lisp_poly_mark(cons->car, 1); - cons = ao_lisp_poly_cons(cons->cdr); - if (!cons) + if (!cdr) break; + if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) { + ao_lisp_poly_mark(cdr, 1); + break; + } + cons = ao_lisp_poly_cons(cdr); if (ao_lisp_mark_memory(&ao_lisp_cons_type, cons)) break; } @@ -42,23 +48,29 @@ static void cons_move(void *addr) return; for (;;) { - struct ao_lisp_cons *cdr; - int ret; + ao_poly cdr; + struct ao_lisp_cons *c; + int ret; MDBG_MOVE("cons_move start %d (%d, %d)\n", MDBG_OFFSET(cons), MDBG_OFFSET(ao_lisp_ref(cons->car)), MDBG_OFFSET(ao_lisp_ref(cons->cdr))); (void) ao_lisp_poly_move(&cons->car, 1); - cdr = ao_lisp_poly_cons(cons->cdr); + cdr = cons->cdr; if (!cdr) break; - ret = ao_lisp_move_memory(&ao_lisp_cons_type, (void **) &cdr); - if (cdr != ao_lisp_poly_cons(cons->cdr)) - cons->cdr = ao_lisp_cons_poly(cdr); + if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) { + (void) ao_lisp_poly_move(&cons->cdr, 1); + break; + } + c = ao_lisp_poly_cons(cdr); + ret = ao_lisp_move_memory(&ao_lisp_cons_type, (void **) &c); + if (c != ao_lisp_poly_cons(cons->cdr)) + cons->cdr = ao_lisp_cons_poly(c); MDBG_MOVE("cons_move end %d (%d, %d)\n", MDBG_OFFSET(cons), MDBG_OFFSET(ao_lisp_ref(cons->car)), MDBG_OFFSET(ao_lisp_ref(cons->cdr))); if (ret) break; - cons = cdr; + cons = c; } } diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 17509044..d9b1c1f2 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -219,16 +219,18 @@ ; expressions to evaluate (set! make-exprs (lambda (vars exprs) - (cond ((not (null? vars)) (cons - (list set - (list quote - (car (car vars)) - ) - (cadr (car vars)) - ) - (make-exprs (cdr vars) exprs) - ) - ) + (cond ((not (null? vars)) + (cons + (list set + (list quote + (car (car vars)) + ) + (cond ((null? (cdr (car vars))) ()) + (else (cadr (car vars)))) + ) + (make-exprs (cdr vars) exprs) + ) + ) (exprs) ) ) @@ -461,6 +463,58 @@ (define string (lexpr (chars) (list->string chars))) +(patom "apply\n") +(apply cons '(a b)) + +(define save ()) + +(define map (lexpr (proc lists) + (let ((args (lambda (lists) + (if (null? lists) () + (cons (caar lists) (args (cdr lists)))))) + (next (lambda (lists) + (if (null? lists) () + (cons (cdr (car lists)) (next (cdr lists)))))) + (domap (lambda (lists) + (if (null? (car lists)) () + (cons (apply proc (args lists)) (domap (next lists))) + ))) + ) + (domap lists)))) + +(map cadr '((a b) (d e) (g h))) + +(define for-each (lexpr (proc lists) + (apply map proc lists) + #t)) + +(for-each patom '("hello" " " "world" "\n")) + +(define string-map (lexpr (proc strings) + (let ((make-lists (lambda (strings) + (if (null? strings) () + (cons (string->list (car strings)) (make-lists (cdr strings)))))) + ) + (list->string (apply map proc (make-lists strings)))))) + +(string-map 1+ "HAL") + +(define string-for-each (lexpr (proc strings) + (apply string-map proc strings) + #t)) + +(string-for-each patom "IBM") + + +(call-with-current-continuation + (lambda (exit) + (for-each (lambda (x) + (print "test" x) + (if (negative? x) + (exit x))) + '(54 0 37 -3 245 19)) + #t)) + ;(define number->string (lexpr (arg opt) ; (let ((base (if (null? opt) 10 (car opt))) ; diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 57227e93..844e7ce7 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -17,6 +17,7 @@ struct ao_lisp_stack *ao_lisp_stack; ao_poly ao_lisp_v; +uint8_t ao_lisp_skip_cons_free; ao_poly ao_lisp_set_cond(struct ao_lisp_cons *c) @@ -269,7 +270,7 @@ ao_lisp_eval_exec(void) DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n"); }); builtin = ao_lisp_poly_builtin(ao_lisp_v); - if (builtin->args & AO_LISP_FUNC_FREE_ARGS && !ao_lisp_stack_marked(ao_lisp_stack)) + if (builtin->args & AO_LISP_FUNC_FREE_ARGS && !ao_lisp_stack_marked(ao_lisp_stack) && !ao_lisp_skip_cons_free) ao_lisp_cons_free(ao_lisp_poly_cons(ao_lisp_stack->values)); ao_lisp_v = v; @@ -295,6 +296,38 @@ ao_lisp_eval_exec(void) DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); break; } + ao_lisp_skip_cons_free = 0; + return 1; +} + +/* + * Finish setting up the apply evaluation + * + * The value is the list to execute + */ +static int +ao_lisp_eval_apply(void) +{ + struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_v); + struct ao_lisp_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_lisp_poly_cons(prev->cdr); + if (cdr->cdr == AO_LISP_NIL) + break; + } + DBGI("before mangling: "); DBG_POLY(ao_lisp_v); DBG("\n"); + prev->cdr = cdr->car; + ao_lisp_stack->values = ao_lisp_v; + ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->values)->car; + DBGI("apply: "); DBG_POLY(ao_lisp_stack->values); DBG ("\n"); + ao_lisp_stack->state = eval_exec; + ao_lisp_skip_cons_free = 1; return 1; } @@ -478,6 +511,7 @@ static int (*const evals[])(void) = { [eval_val] = ao_lisp_eval_val, [eval_formal] = ao_lisp_eval_formal, [eval_exec] = ao_lisp_eval_exec, + [eval_apply] = ao_lisp_eval_apply, [eval_cond] = ao_lisp_eval_cond, [eval_cond_test] = ao_lisp_eval_cond_test, [eval_progn] = ao_lisp_eval_progn, @@ -487,16 +521,17 @@ static int (*const evals[])(void) = { }; const char *ao_lisp_state_names[] = { - "sexpr", - "val", - "formal", - "exec", - "cond", - "cond_test", - "progn", - "while", - "while_test", - "macro", + [eval_sexpr] = "sexpr", + [eval_val] = "val", + [eval_formal] = "formal", + [eval_exec] = "exec", + [eval_apply] = "apply", + [eval_cond] = "cond", + [eval_cond_test] = "cond_test", + [eval_progn] = "progn", + [eval_while] = "while", + [eval_while_test] = "while_test", + [eval_macro] = "macro", }; /* diff --git a/src/lisp/ao_lisp_make_builtin b/src/lisp/ao_lisp_make_builtin index ddc9a0b3..11838e33 100644 --- a/src/lisp/ao_lisp_make_builtin +++ b/src/lisp/ao_lisp_make_builtin @@ -7,10 +7,12 @@ typedef struct { } builtin_t; string[string] type_map = { - "lambda" => "F_LAMBDA", + "lambda" => "LAMBDA", "nlambda" => "NLAMBDA", - "lexpr" => "F_LEXPR", + "lexpr" => "LEXPR", "macro" => "MACRO", + "f_lambda" => "F_LAMBDA", + "f_lexpr" => "F_LEXPR", }; string[*] @@ -67,8 +69,8 @@ dump_casename(builtin_t[*] builtins) { printf("static char *ao_lisp_builtin_name(enum ao_lisp_builtin_id b) {\n"); printf("\tswitch(b) {\n"); for (int i = 0; i < dim(builtins); i++) - printf("\tcase builtin_%s: return ao_lisp_poly_atom(_atom(%s))->name;\n", - builtins[i].c_name, builtins[i].c_name); + printf("\tcase builtin_%s: return ao_lisp_poly_atom(_atom(\"%s\"))->name;\n", + builtins[i].c_name, builtins[i].lisp_names[0]); printf("\tdefault: return \"???\";\n"); printf("\t}\n"); printf("}\n"); @@ -150,9 +152,7 @@ dump_atoms(builtin_t[*] builtins) { for (int j = 0; j < dim(builtins[i].lisp_names); j++) { printf("#define _ao_lisp_atom_"); cify_lisp(builtins[i].lisp_names[j]); - printf(" _atom("); - cify_lisp(builtins[i].lisp_names[j]); - printf(")\n"); + printf(" _atom(\"%s\")\n", builtins[i].lisp_names[j]); } } printf("#endif /* AO_LISP_BUILTIN_ATOMS */\n"); diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index bcd23ce1..8c06e198 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -516,7 +516,7 @@ ao_lisp_read(void) if (!push_read_stack(cons, read_state)) return AO_LISP_NIL; cons++; - read_state |= READ_IN_QUOTE; + read_state = READ_IN_QUOTE; v = _ao_lisp_atom_quote; break; case CLOSE: -- cgit v1.2.3 From cf5729a0bae51172f12fc9ec4339d4e975a45fcc Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 17 Nov 2017 23:23:50 -0800 Subject: altos/lisp: Finish first pass through r7rs * print -> write, patom -> display * Add read-char, write-char * Add exit, current-jiffy, current-second, jiffies-per-second * Add for-each and string-for-each * Avoid duplicate builtins with different atoms Signed-off-by: Keith Packard --- src/lisp/README | 11 +++++++ src/lisp/ao_lisp.h | 33 +++++++++---------- src/lisp/ao_lisp_atom.c | 2 +- src/lisp/ao_lisp_bool.c | 2 +- src/lisp/ao_lisp_builtin.c | 74 +++++++++++++++++++++++++++++++++++++++---- src/lisp/ao_lisp_builtin.txt | 10 ++++-- src/lisp/ao_lisp_cons.c | 10 +++--- src/lisp/ao_lisp_const.lisp | 26 +++++++-------- src/lisp/ao_lisp_error.c | 14 ++++---- src/lisp/ao_lisp_eval.c | 2 +- src/lisp/ao_lisp_frame.c | 8 ++--- src/lisp/ao_lisp_int.c | 2 +- src/lisp/ao_lisp_lambda.c | 4 +-- src/lisp/ao_lisp_make_builtin | 4 ++- src/lisp/ao_lisp_make_const.c | 19 ++++++----- src/lisp/ao_lisp_os.h | 16 ++++++++-- src/lisp/ao_lisp_poly.c | 52 +++++++++++++++--------------- src/lisp/ao_lisp_rep.c | 4 ++- src/lisp/ao_lisp_save.c | 1 + src/lisp/ao_lisp_stack.c | 4 +-- src/lisp/ao_lisp_string.c | 4 +-- 21 files changed, 199 insertions(+), 103 deletions(-) create mode 100644 src/lisp/README diff --git a/src/lisp/README b/src/lisp/README new file mode 100644 index 00000000..c1e84475 --- /dev/null +++ b/src/lisp/README @@ -0,0 +1,11 @@ +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; we have macros instead +* define inside of lambda does not add name to lambda scope +* No record types +* No libraries diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index a445dddd..a10ccc43 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -106,6 +106,7 @@ extern uint16_t ao_lisp_top; #define AO_LISP_INVALID 0x04 #define AO_LISP_UNDEFINED 0x08 #define AO_LISP_EOF 0x10 +#define AO_LISP_EXIT 0x20 extern uint8_t ao_lisp_exception; @@ -463,7 +464,7 @@ ao_lisp_stack_fetch(int id) { extern const struct ao_lisp_type ao_lisp_bool_type; void -ao_lisp_bool_print(ao_poly v); +ao_lisp_bool_write(ao_poly v); #ifdef AO_LISP_MAKE_CONST struct ao_lisp_bool *ao_lisp_true, *ao_lisp_false; @@ -487,10 +488,10 @@ void ao_lisp_cons_free(struct ao_lisp_cons *cons); void -ao_lisp_cons_print(ao_poly); +ao_lisp_cons_write(ao_poly); void -ao_lisp_cons_patom(ao_poly); +ao_lisp_cons_display(ao_poly); int ao_lisp_cons_length(struct ao_lisp_cons *cons); @@ -511,10 +512,10 @@ ao_poly ao_lisp_string_unpack(char *a); void -ao_lisp_string_print(ao_poly s); +ao_lisp_string_write(ao_poly s); void -ao_lisp_string_patom(ao_poly s); +ao_lisp_string_display(ao_poly s); /* atom */ extern const struct ao_lisp_type ao_lisp_atom_type; @@ -524,7 +525,7 @@ extern struct ao_lisp_frame *ao_lisp_frame_global; extern struct ao_lisp_frame *ao_lisp_frame_current; void -ao_lisp_atom_print(ao_poly a); +ao_lisp_atom_write(ao_poly a); struct ao_lisp_atom * ao_lisp_atom_intern(char *name); @@ -540,14 +541,14 @@ ao_lisp_atom_set(ao_poly atom, ao_poly val); /* int */ void -ao_lisp_int_print(ao_poly i); +ao_lisp_int_write(ao_poly i); /* prim */ void -ao_lisp_poly_print(ao_poly p); +ao_lisp_poly_write(ao_poly p); void -ao_lisp_poly_patom(ao_poly p); +ao_lisp_poly_display(ao_poly p); int ao_lisp_poly_mark(ao_poly p, uint8_t note_cons); @@ -572,7 +573,7 @@ ao_lisp_set_cond(struct ao_lisp_cons *cons); /* builtin */ void -ao_lisp_builtin_print(ao_poly b); +ao_lisp_builtin_write(ao_poly b); extern const struct ao_lisp_type ao_lisp_builtin_type; @@ -629,7 +630,7 @@ int ao_lisp_frame_add(struct ao_lisp_frame **frame, ao_poly atom, ao_poly val); void -ao_lisp_frame_print(ao_poly p); +ao_lisp_frame_write(ao_poly p); /* lambda */ extern const struct ao_lisp_type ao_lisp_lambda_type; @@ -640,7 +641,7 @@ struct ao_lisp_lambda * ao_lisp_lambda_new(ao_poly cons); void -ao_lisp_lambda_print(ao_poly lambda); +ao_lisp_lambda_write(ao_poly lambda); ao_poly ao_lisp_lambda_eval(void); @@ -664,7 +665,7 @@ void ao_lisp_stack_clear(void); void -ao_lisp_stack_print(ao_poly stack); +ao_lisp_stack_write(ao_poly stack); ao_poly ao_lisp_stack_eval(void); @@ -697,10 +698,10 @@ int ao_lisp_stack_depth; #define DBG_RESET() (ao_lisp_stack_depth = 0) #define DBG(...) printf(__VA_ARGS__) #define DBGI(...) do { DBG("%4d: ", __LINE__); DBG_INDENT(); DBG(__VA_ARGS__); } while (0) -#define DBG_CONS(a) ao_lisp_cons_print(ao_lisp_cons_poly(a)) -#define DBG_POLY(a) ao_lisp_poly_print(a) +#define DBG_CONS(a) ao_lisp_cons_write(ao_lisp_cons_poly(a)) +#define DBG_POLY(a) ao_lisp_poly_write(a) #define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_lisp_pool) : -1) -#define DBG_STACK() ao_lisp_stack_print(ao_lisp_stack_poly(ao_lisp_stack)) +#define DBG_STACK() ao_lisp_stack_write(ao_lisp_stack_poly(ao_lisp_stack)) static inline void ao_lisp_frames_dump(void) { diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c index 8c9e8ed1..ede13567 100644 --- a/src/lisp/ao_lisp_atom.c +++ b/src/lisp/ao_lisp_atom.c @@ -158,7 +158,7 @@ ao_lisp_atom_set(ao_poly atom, ao_poly val) } void -ao_lisp_atom_print(ao_poly a) +ao_lisp_atom_write(ao_poly a) { struct ao_lisp_atom *atom = ao_lisp_poly_atom(a); printf("%s", atom->name); diff --git a/src/lisp/ao_lisp_bool.c b/src/lisp/ao_lisp_bool.c index ad25afba..391a7f78 100644 --- a/src/lisp/ao_lisp_bool.c +++ b/src/lisp/ao_lisp_bool.c @@ -38,7 +38,7 @@ const struct ao_lisp_type ao_lisp_bool_type = { }; void -ao_lisp_bool_print(ao_poly v) +ao_lisp_bool_write(ao_poly v) { struct ao_lisp_bool *b = ao_lisp_poly_bool(v); diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index d37d0284..6dd4d5e6 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -85,7 +85,7 @@ ao_lisp_args_name(uint8_t args) #endif void -ao_lisp_builtin_print(ao_poly b) +ao_lisp_builtin_write(ao_poly b) { struct ao_lisp_builtin *builtin = ao_lisp_poly_builtin(b); printf("%s", ao_lisp_builtin_name(builtin->func)); @@ -247,30 +247,30 @@ ao_lisp_do_while(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_do_print(struct ao_lisp_cons *cons) +ao_lisp_do_write(struct ao_lisp_cons *cons) { ao_poly val = AO_LISP_NIL; while (cons) { val = cons->car; - ao_lisp_poly_print(val); + ao_lisp_poly_write(val); cons = ao_lisp_poly_cons(cons->cdr); if (cons) printf(" "); } printf("\n"); - return val; + return _ao_lisp_bool_true; } ao_poly -ao_lisp_do_patom(struct ao_lisp_cons *cons) +ao_lisp_do_display(struct ao_lisp_cons *cons) { ao_poly val = AO_LISP_NIL; while (cons) { val = cons->car; - ao_lisp_poly_patom(val); + ao_lisp_poly_display(val); cons = ao_lisp_poly_cons(cons->cdr); } - return val; + return _ao_lisp_bool_true; } ao_poly @@ -738,5 +738,65 @@ ao_lisp_do_string_to_symbol(struct ao_lisp_cons *cons) return ao_lisp_atom_poly(ao_lisp_atom_intern(ao_lisp_poly_string(ao_lisp_arg(cons, 0)))); } +ao_poly +ao_lisp_do_read_char(struct ao_lisp_cons *cons) +{ + int c; + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) + return AO_LISP_NIL; + c = getchar(); + return ao_lisp_int_poly(c); +} + +ao_poly +ao_lisp_do_write_char(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_INT, 0)) + return AO_LISP_NIL; + putchar(ao_lisp_poly_int(ao_lisp_arg(cons, 0))); + return _ao_lisp_bool_true; +} + +ao_poly +ao_lisp_do_exit(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) + return AO_LISP_NIL; + ao_lisp_exception |= AO_LISP_EXIT; + return _ao_lisp_bool_true; +} + +ao_poly +ao_lisp_do_current_jiffy(struct ao_lisp_cons *cons) +{ + int jiffy; + + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) + return AO_LISP_NIL; + jiffy = ao_lisp_os_jiffy(); + return (ao_lisp_int_poly(jiffy)); +} + +ao_poly +ao_lisp_do_current_second(struct ao_lisp_cons *cons) +{ + int second; + + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) + return AO_LISP_NIL; + second = ao_lisp_os_jiffy() / AO_LISP_JIFFIES_PER_SECOND; + return (ao_lisp_int_poly(second)); +} + +ao_poly +ao_lisp_do_jiffies_per_second(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) + return AO_LISP_NIL; + return (ao_lisp_int_poly(AO_LISP_JIFFIES_PER_SECOND)); +} + #define AO_LISP_BUILTIN_FUNCS #include "ao_lisp_builtin.h" diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt index ba6455ab..4c484337 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/lisp/ao_lisp_builtin.txt @@ -15,8 +15,8 @@ macro setq set! nlambda cond nlambda progn nlambda while -f_lexpr print -f_lexpr patom +f_lexpr write +f_lexpr display f_lexpr plus + f_lexpr minus - f_lexpr times * @@ -52,3 +52,9 @@ f_lambda string_to_symbol string->symbol f_lambda stringp string? f_lambda procedurep procedure? lexpr apply +f_lambda read_char read-char +f_lambda write_char write-char +f_lambda exit +f_lambda current_jiffy current-jiffy +f_lambda current_second current-second +f_lambda jiffies_per_second jiffies-per-second diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index 8d607372..9379597c 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -123,7 +123,7 @@ ao_lisp_cons_free(struct ao_lisp_cons *cons) } void -ao_lisp_cons_print(ao_poly c) +ao_lisp_cons_write(ao_poly c) { struct ao_lisp_cons *cons = ao_lisp_poly_cons(c); int first = 1; @@ -131,14 +131,14 @@ ao_lisp_cons_print(ao_poly c) while (cons) { if (!first) printf(" "); - ao_lisp_poly_print(cons->car); + ao_lisp_poly_write(cons->car); c = cons->cdr; if (ao_lisp_poly_type(c) == AO_LISP_CONS) { cons = ao_lisp_poly_cons(c); first = 0; } else { printf(" . "); - ao_lisp_poly_print(c); + ao_lisp_poly_write(c); cons = NULL; } } @@ -146,12 +146,12 @@ ao_lisp_cons_print(ao_poly c) } void -ao_lisp_cons_patom(ao_poly c) +ao_lisp_cons_display(ao_poly c) { struct ao_lisp_cons *cons = ao_lisp_poly_cons(c); while (cons) { - ao_lisp_poly_patom(cons->car); + ao_lisp_poly_display(cons->car); cons = ao_lisp_poly_cons(cons->cdr); } } diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index d9b1c1f2..191ef005 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -463,11 +463,9 @@ (define string (lexpr (chars) (list->string chars))) -(patom "apply\n") +(display "apply\n") (apply cons '(a b)) -(define save ()) - (define map (lexpr (proc lists) (let ((args (lambda (lists) (if (null? lists) () @@ -488,28 +486,30 @@ (apply map proc lists) #t)) -(for-each patom '("hello" " " "world" "\n")) +(for-each display '("hello" " " "world" "\n")) + +(define -string-ml (lambda (strings) + (if (null? strings) () + (cons (string->list (car strings)) (-string-ml (cdr strings)))))) (define string-map (lexpr (proc strings) - (let ((make-lists (lambda (strings) - (if (null? strings) () - (cons (string->list (car strings)) (make-lists (cdr strings)))))) - ) - (list->string (apply map proc (make-lists strings)))))) + (list->string (apply map proc (-string-ml strings)))))) (string-map 1+ "HAL") (define string-for-each (lexpr (proc strings) - (apply string-map proc strings) - #t)) + (apply for-each proc (-string-ml strings)))) + +(string-for-each write-char "IBM\n") -(string-for-each patom "IBM") +(define newline (lambda () (write-char #\newline))) +(newline) (call-with-current-continuation (lambda (exit) (for-each (lambda (x) - (print "test" x) + (write "test" x) (if (negative? x) (exit x))) '(54 0 37 -3 245 19)) diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c index 54a9be10..d1c9b941 100644 --- a/src/lisp/ao_lisp_error.c +++ b/src/lisp/ao_lisp_error.c @@ -28,7 +28,7 @@ ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last) printf("\t\t "); else first = 0; - ao_lisp_poly_print(cons->car); + ao_lisp_poly_write(cons->car); printf("\n"); if (poly == last) break; @@ -38,7 +38,7 @@ ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last) } else printf(")\n"); } else { - ao_lisp_poly_print(poly); + ao_lisp_poly_write(poly); printf("\n"); } } @@ -66,9 +66,9 @@ ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) tabs(indent); printf(" "); } - ao_lisp_poly_print(frame->vals[f].atom); + ao_lisp_poly_write(frame->vals[f].atom); printf(" = "); - ao_lisp_poly_print(frame->vals[f].val); + ao_lisp_poly_write(frame->vals[f].val); printf("\n"); } if (frame->prev) @@ -92,11 +92,11 @@ ao_lisp_error(int error, char *format, ...) vprintf(format, args); va_end(args); printf("\n"); - printf("Value: "); ao_lisp_poly_print(ao_lisp_v); printf("\n"); + printf("Value: "); ao_lisp_poly_write(ao_lisp_v); printf("\n"); printf("Stack:\n"); - ao_lisp_stack_print(ao_lisp_stack_poly(ao_lisp_stack)); + ao_lisp_stack_write(ao_lisp_stack_poly(ao_lisp_stack)); printf("Globals:\n\t"); - ao_lisp_frame_print(ao_lisp_frame_poly(ao_lisp_frame_global)); + ao_lisp_frame_write(ao_lisp_frame_poly(ao_lisp_frame_global)); printf("\n"); return AO_LISP_NIL; } diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 844e7ce7..758a9232 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -270,7 +270,7 @@ ao_lisp_eval_exec(void) DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n"); }); builtin = ao_lisp_poly_builtin(ao_lisp_v); - if (builtin->args & AO_LISP_FUNC_FREE_ARGS && !ao_lisp_stack_marked(ao_lisp_stack) && !ao_lisp_skip_cons_free) + if (builtin && builtin->args & AO_LISP_FUNC_FREE_ARGS && !ao_lisp_stack_marked(ao_lisp_stack) && !ao_lisp_skip_cons_free) ao_lisp_cons_free(ao_lisp_poly_cons(ao_lisp_stack->values)); ao_lisp_v = v; diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index 05f6d253..ebdb7757 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -102,7 +102,7 @@ const struct ao_lisp_type ao_lisp_frame_type = { }; void -ao_lisp_frame_print(ao_poly p) +ao_lisp_frame_write(ao_poly p) { struct ao_lisp_frame *frame = ao_lisp_poly_frame(p); int f; @@ -116,12 +116,12 @@ ao_lisp_frame_print(ao_poly p) for (f = 0; f < frame->num; f++) { if (f != 0) printf(", "); - ao_lisp_poly_print(frame->vals[f].atom); + ao_lisp_poly_write(frame->vals[f].atom); printf(" = "); - ao_lisp_poly_print(frame->vals[f].val); + ao_lisp_poly_write(frame->vals[f].val); } if (frame->prev) - ao_lisp_poly_print(frame->prev); + ao_lisp_poly_write(frame->prev); frame->type &= ~AO_LISP_FRAME_PRINT; } } diff --git a/src/lisp/ao_lisp_int.c b/src/lisp/ao_lisp_int.c index 77f65e95..3b5341bd 100644 --- a/src/lisp/ao_lisp_int.c +++ b/src/lisp/ao_lisp_int.c @@ -15,7 +15,7 @@ #include "ao_lisp.h" void -ao_lisp_int_print(ao_poly p) +ao_lisp_int_write(ao_poly p) { int i = ao_lisp_poly_int(p); printf("%d", i); diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c index cc333d6f..71aebed0 100644 --- a/src/lisp/ao_lisp_lambda.c +++ b/src/lisp/ao_lisp_lambda.c @@ -50,7 +50,7 @@ const struct ao_lisp_type ao_lisp_lambda_type = { }; void -ao_lisp_lambda_print(ao_poly poly) +ao_lisp_lambda_write(ao_poly poly) { struct ao_lisp_lambda *lambda = ao_lisp_poly_lambda(poly); struct ao_lisp_cons *cons = ao_lisp_poly_cons(lambda->code); @@ -59,7 +59,7 @@ ao_lisp_lambda_print(ao_poly poly) printf("%s", ao_lisp_args_name(lambda->args)); while (cons) { printf(" "); - ao_lisp_poly_print(cons->car); + ao_lisp_poly_write(cons->car); cons = ao_lisp_poly_cons(cons->cdr); } printf(")"); diff --git a/src/lisp/ao_lisp_make_builtin b/src/lisp/ao_lisp_make_builtin index 11838e33..531e388d 100644 --- a/src/lisp/ao_lisp_make_builtin +++ b/src/lisp/ao_lisp_make_builtin @@ -137,7 +137,9 @@ dump_consts(builtin_t[*] builtins) { for (int i = 0; i < dim(builtins); i++) { for (int j = 0; j < dim(builtins[i].lisp_names); j++) { printf ("\t{ .name = \"%s\", .args = AO_LISP_FUNC_%s, .func = builtin_%s },\n", - builtins[i].lisp_names[j], builtins[i].type, builtins[i].c_name); + builtins[i].lisp_names[j], + builtins[i].type, + builtins[i].c_name); } } printf("};\n"); diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index 826c98b9..f23d34db 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -31,7 +31,7 @@ ao_lisp_make_builtin(enum ao_lisp_builtin_id func, int args) { struct builtin_func { char *name; int args; - int func; + enum ao_lisp_builtin_id func; }; #define AO_LISP_BUILTIN_CONSTS @@ -146,7 +146,7 @@ ao_is_macro(ao_poly p) struct ao_lisp_lambda *lambda; ao_poly ret; - MACRO_DEBUG(indent(); printf ("is macro "); ao_lisp_poly_print(p); printf("\n"); ++macro_scan_depth); + MACRO_DEBUG(indent(); printf ("is macro "); ao_lisp_poly_write(p); printf("\n"); ++macro_scan_depth); switch (ao_lisp_poly_type(p)) { case AO_LISP_ATOM: if (ao_lisp_macro_push(p)) @@ -181,7 +181,7 @@ ao_is_macro(ao_poly p) ret = AO_LISP_NIL; break; } - MACRO_DEBUG(--macro_scan_depth; indent(); printf ("... "); ao_lisp_poly_print(ret); printf("\n")); + MACRO_DEBUG(--macro_scan_depth; indent(); printf ("... "); ao_lisp_poly_write(ret); printf("\n")); return ret; } @@ -195,7 +195,7 @@ ao_has_macro(ao_poly p) if (p == AO_LISP_NIL) return AO_LISP_NIL; - MACRO_DEBUG(indent(); printf("has macro "); ao_lisp_poly_print(p); printf("\n"); ++macro_scan_depth); + MACRO_DEBUG(indent(); printf("has macro "); ao_lisp_poly_write(p); printf("\n"); ++macro_scan_depth); switch (ao_lisp_poly_type(p)) { case AO_LISP_LAMBDA: lambda = ao_lisp_poly_lambda(p); @@ -222,7 +222,7 @@ ao_has_macro(ao_poly p) p = AO_LISP_NIL; break; } - MACRO_DEBUG(--macro_scan_depth; indent(); printf("... "); ao_lisp_poly_print(p); printf("\n")); + MACRO_DEBUG(--macro_scan_depth; indent(); printf("... "); ao_lisp_poly_write(p); printf("\n")); return p; } @@ -237,7 +237,7 @@ ao_lisp_read_eval_abort(void) out = ao_lisp_eval(in); if (ao_lisp_exception) return 0; - ao_lisp_poly_print(out); + ao_lisp_poly_write(out); putchar ('\n'); } return 1; @@ -273,6 +273,7 @@ main(int argc, char **argv) int in_atom = 0; char *out_name = NULL; int c; + enum ao_lisp_builtin_id prev_func; in = stdin; out = stdout; @@ -292,8 +293,10 @@ main(int argc, char **argv) ao_lisp_bool_get(0); ao_lisp_bool_get(1); + prev_func = _builtin_last; for (f = 0; f < (int) N_FUNC; f++) { - b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); + if (funcs[f].func != prev_func) + b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); a = ao_lisp_atom_intern(funcs[f].name); ao_lisp_atom_set(ao_lisp_atom_poly(a), ao_lisp_builtin_poly(b)); @@ -327,7 +330,7 @@ main(int argc, char **argv) if (val != AO_LISP_NIL) { printf("error: function %s contains unresolved macro: ", ao_lisp_poly_atom(ao_lisp_frame_global->vals[f].atom)->name); - ao_lisp_poly_print(val); + ao_lisp_poly_write(val); printf("\n"); exit(1); } diff --git a/src/lisp/ao_lisp_os.h b/src/lisp/ao_lisp_os.h index 5fa3686b..4285cb8c 100644 --- a/src/lisp/ao_lisp_os.h +++ b/src/lisp/ao_lisp_os.h @@ -41,13 +41,23 @@ ao_lisp_os_led(int led) printf("leds set to 0x%x\n", led); } +#define AO_LISP_JIFFIES_PER_SECOND 100 + static inline void -ao_lisp_os_delay(int delay) +ao_lisp_os_delay(int jiffies) { struct timespec ts = { - .tv_sec = delay / 1000, - .tv_nsec = (delay % 1000) * 1000000, + .tv_sec = jiffies / AO_LISP_JIFFIES_PER_SECOND, + .tv_nsec = (jiffies % AO_LISP_JIFFIES_PER_SECOND) * (1000000000L / AO_LISP_JIFFIES_PER_SECOND) }; nanosleep(&ts, NULL); } + +static inline int +ao_lisp_os_jiffy(void) +{ + struct timespec tp; + clock_gettime(CLOCK_MONOTONIC, &tp); + return tp.tv_sec * AO_LISP_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_LISP_JIFFIES_PER_SECOND)); +} #endif diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c index 160734b1..7e4c98d2 100644 --- a/src/lisp/ao_lisp_poly.c +++ b/src/lisp/ao_lisp_poly.c @@ -15,46 +15,46 @@ #include "ao_lisp.h" struct ao_lisp_funcs { - void (*print)(ao_poly); - void (*patom)(ao_poly); + void (*write)(ao_poly); + void (*display)(ao_poly); }; static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { [AO_LISP_CONS] = { - .print = ao_lisp_cons_print, - .patom = ao_lisp_cons_patom, + .write = ao_lisp_cons_write, + .display = ao_lisp_cons_display, }, [AO_LISP_STRING] = { - .print = ao_lisp_string_print, - .patom = ao_lisp_string_patom, + .write = ao_lisp_string_write, + .display = ao_lisp_string_display, }, [AO_LISP_INT] = { - .print = ao_lisp_int_print, - .patom = ao_lisp_int_print, + .write = ao_lisp_int_write, + .display = ao_lisp_int_write, }, [AO_LISP_ATOM] = { - .print = ao_lisp_atom_print, - .patom = ao_lisp_atom_print, + .write = ao_lisp_atom_write, + .display = ao_lisp_atom_write, }, [AO_LISP_BUILTIN] = { - .print = ao_lisp_builtin_print, - .patom = ao_lisp_builtin_print, + .write = ao_lisp_builtin_write, + .display = ao_lisp_builtin_write, }, [AO_LISP_FRAME] = { - .print = ao_lisp_frame_print, - .patom = ao_lisp_frame_print, + .write = ao_lisp_frame_write, + .display = ao_lisp_frame_write, }, [AO_LISP_LAMBDA] = { - .print = ao_lisp_lambda_print, - .patom = ao_lisp_lambda_print, + .write = ao_lisp_lambda_write, + .display = ao_lisp_lambda_write, }, [AO_LISP_STACK] = { - .print = ao_lisp_stack_print, - .patom = ao_lisp_stack_print, + .write = ao_lisp_stack_write, + .display = ao_lisp_stack_write, }, [AO_LISP_BOOL] = { - .print = ao_lisp_bool_print, - .patom = ao_lisp_bool_print, + .write = ao_lisp_bool_write, + .display = ao_lisp_bool_write, }, }; @@ -69,21 +69,21 @@ funcs(ao_poly p) } void -ao_lisp_poly_print(ao_poly p) +ao_lisp_poly_write(ao_poly p) { const struct ao_lisp_funcs *f = funcs(p); - if (f && f->print) - f->print(p); + if (f && f->write) + f->write(p); } void -ao_lisp_poly_patom(ao_poly p) +ao_lisp_poly_display(ao_poly p) { const struct ao_lisp_funcs *f = funcs(p); - if (f && f->patom) - f->patom(p); + if (f && f->display) + f->display(p); } void * diff --git a/src/lisp/ao_lisp_rep.c b/src/lisp/ao_lisp_rep.c index ef7dbaf2..43cc387f 100644 --- a/src/lisp/ao_lisp_rep.c +++ b/src/lisp/ao_lisp_rep.c @@ -24,9 +24,11 @@ ao_lisp_read_eval_print(void) break; out = ao_lisp_eval(in); if (ao_lisp_exception) { + if (ao_lisp_exception & AO_LISP_EXIT) + break; ao_lisp_exception = 0; } else { - ao_lisp_poly_print(out); + ao_lisp_poly_write(out); putchar ('\n'); } } diff --git a/src/lisp/ao_lisp_save.c b/src/lisp/ao_lisp_save.c index cbc8e925..c990e9c6 100644 --- a/src/lisp/ao_lisp_save.c +++ b/src/lisp/ao_lisp_save.c @@ -69,6 +69,7 @@ ao_lisp_do_restore(struct ao_lisp_cons *cons) /* Re-create the evaluator stack */ if (!ao_lisp_eval_restart()) return _ao_lisp_bool_false; + return _ao_lisp_bool_true; } #endif diff --git a/src/lisp/ao_lisp_stack.c b/src/lisp/ao_lisp_stack.c index 729a63ba..af68b656 100644 --- a/src/lisp/ao_lisp_stack.c +++ b/src/lisp/ao_lisp_stack.c @@ -156,7 +156,7 @@ ao_lisp_stack_clear(void) } void -ao_lisp_stack_print(ao_poly poly) +ao_lisp_stack_write(ao_poly poly) { struct ao_lisp_stack *s = ao_lisp_poly_stack(poly); @@ -167,7 +167,7 @@ ao_lisp_stack_print(ao_poly poly) } s->type |= AO_LISP_STACK_PRINT; printf("\t[\n"); - printf("\t\texpr: "); ao_lisp_poly_print(s->list); printf("\n"); + printf("\t\texpr: "); ao_lisp_poly_write(s->list); printf("\n"); printf("\t\tstate: %s\n", ao_lisp_state_names[s->state]); ao_lisp_error_poly ("values: ", s->values, s->values_tail); ao_lisp_error_poly ("sexprs: ", s->sexprs, AO_LISP_NIL); diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c index af23f7b3..87f9289c 100644 --- a/src/lisp/ao_lisp_string.c +++ b/src/lisp/ao_lisp_string.c @@ -122,7 +122,7 @@ ao_lisp_string_unpack(char *a) } void -ao_lisp_string_print(ao_poly p) +ao_lisp_string_write(ao_poly p) { char *s = ao_lisp_poly_string(p); char c; @@ -148,7 +148,7 @@ ao_lisp_string_print(ao_poly p) } void -ao_lisp_string_patom(ao_poly p) +ao_lisp_string_display(ao_poly p) { char *s = ao_lisp_poly_string(p); char c; -- cgit v1.2.3 From 65fb0ad8693407cc9bd114424c1f51b6aa6befc3 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 17 Nov 2017 23:27:36 -0800 Subject: altos/test: Add jiffy funcs to lisp test Signed-off-by: Keith Packard --- src/test/ao_lisp_os.h | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/src/test/ao_lisp_os.h b/src/test/ao_lisp_os.h index 9ff2e1fe..9b021900 100644 --- a/src/test/ao_lisp_os.h +++ b/src/test/ao_lisp_os.h @@ -45,15 +45,24 @@ ao_lisp_os_led(int led) printf("leds set to 0x%x\n", led); } +#define AO_LISP_JIFFIES_PER_SECOND 100 + static inline void -ao_lisp_os_delay(int delay) +ao_lisp_os_delay(int jiffies) { - if (!delay) - return; struct timespec ts = { - .tv_sec = delay / 1000, - .tv_nsec = (delay % 1000) * 1000000, + .tv_sec = jiffies / AO_LISP_JIFFIES_PER_SECOND, + .tv_nsec = (jiffies % AO_LISP_JIFFIES_PER_SECOND) * (1000000000L / AO_LISP_JIFFIES_PER_SECOND) }; nanosleep(&ts, NULL); } + +static inline int +ao_lisp_os_jiffy(void) +{ + struct timespec tp; + clock_gettime(CLOCK_MONOTONIC, &tp); + return tp.tv_sec * AO_LISP_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_LISP_JIFFIES_PER_SECOND)); +} + #endif -- cgit v1.2.3 From e745229311366a792110d78d8480a2bf83eef9a0 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 17 Nov 2017 23:28:08 -0800 Subject: altos/cortexelf-v1: Make lisp compile again Signed-off-by: Keith Packard --- src/cortexelf-v1/Makefile | 1 + src/cortexelf-v1/ao_lisp_os.h | 10 +++++++++- src/cortexelf-v1/ao_pins.h | 2 ++ 3 files changed, 12 insertions(+), 1 deletion(-) diff --git a/src/cortexelf-v1/Makefile b/src/cortexelf-v1/Makefile index 8cc6ce31..be225e57 100644 --- a/src/cortexelf-v1/Makefile +++ b/src/cortexelf-v1/Makefile @@ -82,6 +82,7 @@ ALTOS_SRC = \ ao_lisp_atom.c \ ao_lisp_int.c \ ao_lisp_poly.c \ + ao_lisp_bool.c \ ao_lisp_builtin.c \ ao_lisp_read.c \ ao_lisp_rep.c \ diff --git a/src/cortexelf-v1/ao_lisp_os.h b/src/cortexelf-v1/ao_lisp_os.h index d0c1f7b7..50c9d40f 100644 --- a/src/cortexelf-v1/ao_lisp_os.h +++ b/src/cortexelf-v1/ao_lisp_os.h @@ -56,10 +56,18 @@ ao_lisp_os_led(int led) (void) led; } +#define AO_LISP_JIFFIES_PER_SECOND AO_HERTZ + static inline void ao_lisp_os_delay(int delay) { - ao_delay(AO_MS_TO_TICKS(delay)); + ao_delay(delay); +} + +static inline int +ao_lisp_os_jiffy(void) +{ + return ao_tick_count; } #endif diff --git a/src/cortexelf-v1/ao_pins.h b/src/cortexelf-v1/ao_pins.h index 258ffe31..c2bbf2d2 100644 --- a/src/cortexelf-v1/ao_pins.h +++ b/src/cortexelf-v1/ao_pins.h @@ -62,6 +62,8 @@ #define USE_SERIAL_2_STDIN 1 #define SERIAL_2_PA2_PA3 0 #define SERIAL_2_PD5_PD6 1 +#define USE_SERIAL_2_FLOW 0 +#define USE_SERIAL_2_SW_FLOW 0 #define HAS_SERIAL_3 0 #define USE_SERIAL_3_STDIN 0 -- cgit v1.2.3 From 5f8f0ed5cd5d4b4f793c602ed09f9b4bdb98f7e8 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 18 Nov 2017 20:38:15 -0800 Subject: altos/lisp: Add 'big' ints -- 24 bits wide With the default ints being only 14 bits, having a larger type with more precision seems useful. This is not exposed to the application. Signed-off-by: Keith Packard --- src/cortexelf-v1/ao_lisp_os.h | 6 ++++ src/lisp/ao_lisp.h | 69 ++++++++++++++++++++++++++++++++++++++++--- src/lisp/ao_lisp_builtin.c | 30 ++++++++++++------- src/lisp/ao_lisp_eval.c | 1 + src/lisp/ao_lisp_int.c | 57 +++++++++++++++++++++++++++++++++++ src/lisp/ao_lisp_mem.c | 1 + src/lisp/ao_lisp_poly.c | 4 +++ src/lisp/ao_lisp_read.c | 4 +-- src/lisp/ao_lisp_string.c | 4 +-- 9 files changed, 157 insertions(+), 19 deletions(-) diff --git a/src/cortexelf-v1/ao_lisp_os.h b/src/cortexelf-v1/ao_lisp_os.h index 50c9d40f..27ea7806 100644 --- a/src/cortexelf-v1/ao_lisp_os.h +++ b/src/cortexelf-v1/ao_lisp_os.h @@ -23,6 +23,12 @@ #define AO_LISP_POOL_TOTAL 16384 #define AO_LISP_SAVE 1 +#ifndef __BYTE_ORDER +#define __LITTLE_ENDIAN 1234 +#define __BIG_ENDIAN 4321 +#define __BYTE_ORDER __LITTLE_ENDIAN +#endif + static inline int ao_lisp_getc() { static uint8_t at_eol; diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index a10ccc43..08278fe7 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -21,6 +21,9 @@ #include #include #include +#ifndef __BYTE_ORDER +#include +#endif typedef uint16_t ao_poly; typedef int16_t ao_signed_poly; @@ -92,7 +95,8 @@ extern uint8_t ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA] __attribute__((a #define AO_LISP_LAMBDA 7 #define AO_LISP_STACK 8 #define AO_LISP_BOOL 9 -#define AO_LISP_NUM_TYPE 10 +#define AO_LISP_BIGINT 10 +#define AO_LISP_NUM_TYPE 11 /* Leave two bits for types to use as they please */ #define AO_LISP_OTHER_TYPE_MASK 0x3f @@ -162,6 +166,35 @@ struct ao_lisp_bool { uint16_t pad; }; +struct ao_lisp_bigint { + uint32_t value; +}; + +#if __BYTE_ORDER == __LITTLE_ENDIAN +static inline uint32_t +ao_lisp_int_bigint(int32_t i) { + return AO_LISP_BIGINT | (i << 8); +} +static inline int32_t +ao_lisp_bigint_int(uint32_t bi) { + return (int32_t) bi >> 8; +} +#else +static inline uint32_t +ao_lisp_int_bigint(int32_t i) { + return (uint32_t) (i & 0xffffff) | (AO_LISP_BIGINT << 24); +} +static inlint int32_t +ao_lisp_bigint_int(uint32_t bi) { + return (int32_t) (bi << 8) >> 8; +} +#endif + +#define AO_LISP_MIN_INT (-(1 << (15 - AO_LISP_TYPE_SHIFT))) +#define AO_LISP_MAX_INT ((1 << (15 - AO_LISP_TYPE_SHIFT)) - 1) + +#define AO_LISP_NOT_INTEGER 0x7fffffff + /* Set on type when the frame escapes the lambda */ #define AO_LISP_FRAME_MARK 0x80 #define AO_LISP_FRAME_PRINT 0x40 @@ -338,18 +371,30 @@ ao_lisp_cons_poly(struct ao_lisp_cons *cons) return ao_lisp_poly(cons, AO_LISP_CONS); } -static inline int +static inline int32_t ao_lisp_poly_int(ao_poly poly) { - return (int) ((ao_signed_poly) poly >> AO_LISP_TYPE_SHIFT); + return (int32_t) ((ao_signed_poly) poly >> AO_LISP_TYPE_SHIFT); } static inline ao_poly -ao_lisp_int_poly(int i) +ao_lisp_int_poly(int32_t i) { return ((ao_poly) i << 2) | AO_LISP_INT; } +static inline struct ao_lisp_bigint * +ao_lisp_poly_bigint(ao_poly poly) +{ + return ao_lisp_ref(poly); +} + +static inline ao_poly +ao_lisp_bigint_poly(struct ao_lisp_bigint *bi) +{ + return ao_lisp_poly(bi, AO_LISP_OTHER); +} + static inline char * ao_lisp_poly_string(ao_poly poly) { @@ -543,6 +588,22 @@ ao_lisp_atom_set(ao_poly atom, ao_poly val); void ao_lisp_int_write(ao_poly i); +int32_t +ao_lisp_poly_integer(ao_poly p); + +ao_poly +ao_lisp_integer_poly(int32_t i); + +static inline int +ao_lisp_integer_typep(uint8_t t) +{ + return (t == AO_LISP_INT) || (t == AO_LISP_BIGINT); +} + +void +ao_lisp_bigint_write(ao_poly i); + +extern const struct ao_lisp_type ao_lisp_bigint_type; /* prim */ void ao_lisp_poly_write(ao_poly p); diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 6dd4d5e6..ccd13d07 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -290,10 +290,10 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) if (cons->cdr == AO_LISP_NIL && ct == AO_LISP_INT) { switch (op) { case builtin_minus: - ret = ao_lisp_int_poly(-ao_lisp_poly_int(ret)); + ret = ao_lisp_integer_poly(-ao_lisp_poly_integer(ret)); break; case builtin_divide: - switch (ao_lisp_poly_int(ret)) { + switch (ao_lisp_poly_integer(ret)) { case 0: return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero"); case 1: @@ -307,9 +307,9 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) break; } } - } else if (rt == AO_LISP_INT && ct == AO_LISP_INT) { - int r = ao_lisp_poly_int(ret); - int c = ao_lisp_poly_int(car); + } else if (ao_lisp_integer_typep(rt) && ao_lisp_integer_typep(ct)) { + int32_t r = ao_lisp_poly_integer(ret); + int32_t c = ao_lisp_poly_integer(car); switch(op) { case builtin_plus: @@ -349,7 +349,7 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) default: break; } - ret = ao_lisp_int_poly(r); + ret = ao_lisp_integer_poly(r); } else if (rt == AO_LISP_STRING && ct == AO_LISP_STRING && op == builtin_plus) @@ -427,9 +427,9 @@ ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) } else { uint8_t lt = ao_lisp_poly_type(left); uint8_t rt = ao_lisp_poly_type(right); - if (lt == AO_LISP_INT && rt == AO_LISP_INT) { - int l = ao_lisp_poly_int(left); - int r = ao_lisp_poly_int(right); + if (ao_lisp_integer_typep(lt) && ao_lisp_integer_typep(rt)) { + int32_t l = ao_lisp_poly_integer(left); + int32_t r = ao_lisp_poly_integer(right); switch (op) { case builtin_less: @@ -643,7 +643,15 @@ ao_lisp_do_pairp(struct ao_lisp_cons *cons) ao_poly ao_lisp_do_numberp(struct ao_lisp_cons *cons) { - return ao_lisp_do_typep(AO_LISP_INT, cons); + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) { + case AO_LISP_INT: + case AO_LISP_BIGINT: + return _ao_lisp_bool_true; + default: + return _ao_lisp_bool_false; + } } ao_poly @@ -755,7 +763,7 @@ ao_lisp_do_write_char(struct ao_lisp_cons *cons) return AO_LISP_NIL; if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_INT, 0)) return AO_LISP_NIL; - putchar(ao_lisp_poly_int(ao_lisp_arg(cons, 0))); + putchar(ao_lisp_poly_integer(ao_lisp_arg(cons, 0))); return _ao_lisp_bool_true; } diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 758a9232..8fa488e2 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -110,6 +110,7 @@ ao_lisp_eval_sexpr(void) /* fall through */ case AO_LISP_BOOL: case AO_LISP_INT: + case AO_LISP_BIGINT: case AO_LISP_STRING: case AO_LISP_BUILTIN: case AO_LISP_LAMBDA: diff --git a/src/lisp/ao_lisp_int.c b/src/lisp/ao_lisp_int.c index 3b5341bd..8e467755 100644 --- a/src/lisp/ao_lisp_int.c +++ b/src/lisp/ao_lisp_int.c @@ -20,3 +20,60 @@ ao_lisp_int_write(ao_poly p) int i = ao_lisp_poly_int(p); printf("%d", i); } + +int32_t +ao_lisp_poly_integer(ao_poly p) +{ + switch (ao_lisp_poly_base_type(p)) { + case AO_LISP_INT: + return ao_lisp_poly_int(p); + case AO_LISP_OTHER: + if (ao_lisp_other_type(ao_lisp_poly_other(p)) == AO_LISP_BIGINT) + return ao_lisp_bigint_int(ao_lisp_poly_bigint(p)->value); + } + return AO_LISP_NOT_INTEGER; +} + +ao_poly +ao_lisp_integer_poly(int32_t p) +{ + struct ao_lisp_bigint *bi; + + if (AO_LISP_MIN_INT <= p && p <= AO_LISP_MAX_INT) + return ao_lisp_int_poly(p); + bi = ao_lisp_alloc(sizeof (struct ao_lisp_bigint)); + bi->value = ao_lisp_int_bigint(p); + return ao_lisp_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_lisp_bigint); +} + +static void bigint_move(void *addr) +{ + (void) addr; +} + +const struct ao_lisp_type ao_lisp_bigint_type = { + .mark = bigint_mark, + .size = bigint_size, + .move = bigint_move, + .name = "bigint", +}; + +void +ao_lisp_bigint_write(ao_poly p) +{ + struct ao_lisp_bigint *bi = ao_lisp_poly_bigint(p); + + printf("%d", ao_lisp_bigint_int(bi->value)); +} diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 156221e8..f333073a 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -458,6 +458,7 @@ static const struct ao_lisp_type *ao_lisp_types[AO_LISP_NUM_TYPE] = { [AO_LISP_LAMBDA] = &ao_lisp_lambda_type, [AO_LISP_STACK] = &ao_lisp_stack_type, [AO_LISP_BOOL] = &ao_lisp_bool_type, + [AO_LISP_BIGINT] = &ao_lisp_bigint_type, }; static int diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c index 7e4c98d2..94ecd042 100644 --- a/src/lisp/ao_lisp_poly.c +++ b/src/lisp/ao_lisp_poly.c @@ -56,6 +56,10 @@ static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { .write = ao_lisp_bool_write, .display = ao_lisp_bool_write, }, + [AO_LISP_BIGINT] = { + .write = ao_lisp_bigint_write, + .display = ao_lisp_bigint_write, + }, }; static const struct ao_lisp_funcs * diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index 8c06e198..5115f46e 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -245,7 +245,7 @@ lex_quoted(void) #define AO_LISP_TOKEN_MAX 32 static char token_string[AO_LISP_TOKEN_MAX]; -static int token_int; +static int32_t token_int; static int token_len; static inline void add_token(int c) { @@ -497,7 +497,7 @@ ao_lisp_read(void) v = AO_LISP_NIL; break; case NUM: - v = ao_lisp_int_poly(token_int); + v = ao_lisp_integer_poly(token_int); break; case BOOL: if (token_string[0] == 't') diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c index 87f9289c..fff218df 100644 --- a/src/lisp/ao_lisp_string.c +++ b/src/lisp/ao_lisp_string.c @@ -83,9 +83,9 @@ ao_lisp_string_pack(struct ao_lisp_cons *cons) char *s = r; while (cons) { - if (ao_lisp_poly_type(cons->car) != AO_LISP_INT) + if (!ao_lisp_integer_typep(ao_lisp_poly_type(cons->car))) return ao_lisp_error(AO_LISP_INVALID, "non-int passed to pack"); - *s++ = ao_lisp_poly_int(cons->car); + *s++ = ao_lisp_poly_integer(cons->car); cons = ao_lisp_poly_cons(cons->cdr); } *s++ = 0; -- cgit v1.2.3 From 12a1f6ad48f2b924f71239effeb90afca75a090f Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 18 Nov 2017 22:00:44 -0800 Subject: altos/lisp: Fix some scheme compat issues flush -> flush-output nth -> list-ref (oh, and add list-tail) add let* (same as let for now) write control chars in octal make hanoi example work Signed-off-by: Keith Packard --- src/lisp/ao_lisp_builtin.c | 4 +- src/lisp/ao_lisp_builtin.txt | 2 +- src/lisp/ao_lisp_const.lisp | 16 +++- src/lisp/ao_lisp_string.c | 5 +- src/test/hanoi.lisp | 185 ++++++++++++++++++++++--------------------- 5 files changed, 115 insertions(+), 97 deletions(-) diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index ccd13d07..e5370f90 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -533,9 +533,9 @@ ao_lisp_do_string_to_list(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_do_flush(struct ao_lisp_cons *cons) +ao_lisp_do_flush_output(struct ao_lisp_cons *cons) { - if (!ao_lisp_check_argc(_ao_lisp_atom_flush, cons, 0, 0)) + if (!ao_lisp_check_argc(_ao_lisp_atom_flush2doutput, cons, 0, 0)) return AO_LISP_NIL; ao_lisp_os_flush(); return _ao_lisp_bool_true; diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt index 4c484337..c324ca67 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/lisp/ao_lisp_builtin.txt @@ -31,7 +31,7 @@ f_lexpr less_equal <= f_lexpr greater_equal >= f_lambda list_to_string list->string f_lambda string_to_list string->list -f_lambda flush +f_lambda flush_output flush-output f_lambda delay f_lexpr led f_lambda save diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 191ef005..861a4fc8 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -60,10 +60,17 @@ (defun caddr (l) (car (cdr (cdr l)))) -(defun nth (list n) - (cond ((= n 0) (car list)) - ((nth (cdr list) (1- n))) - ) +(define list-tail (lambda (x k) + (if (zero? k) + x + (list-tail (cdr x (- k 1))) + ) + ) + ) + +(define list-ref (lambda (x k) + (car (list-tail x k)) + ) ) ; simple math operators @@ -264,6 +271,7 @@ (let ((x 1)) x) +(define let* let) ; boolean operators (define or (lexpr (l) diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c index fff218df..1daa50ea 100644 --- a/src/lisp/ao_lisp_string.c +++ b/src/lisp/ao_lisp_string.c @@ -140,7 +140,10 @@ ao_lisp_string_write(ao_poly p) printf ("\\t"); break; default: - putchar(c); + if (c < ' ') + printf("\\%03o", c); + else + putchar(c); break; } } diff --git a/src/test/hanoi.lisp b/src/test/hanoi.lisp index e2eb0fa0..e873c796 100644 --- a/src/test/hanoi.lisp +++ b/src/test/hanoi.lisp @@ -16,129 +16,133 @@ ; ANSI control sequences -(defun move-to (col row) - (patom "\033[" row ";" col "H") +(define move-to (lambda (col row) + (for-each display (list "\033[" row ";" col "H")) + ) ) -(defun clear () - (patom "\033[2J") +(define clear (lambda () + (display "\033[2J") + ) ) -(defun display-string (x y str) - (move-to x y) - (patom str) +(define display-string (lambda (x y str) + (move-to x y) + (display str) + ) ) ; Here's the pieces to display -(setq stack '(" * " " *** " " ***** " " ******* " " ********* " "***********")) +(define tower '(" * " " *** " " ***** " " ******* " " ********* " "***********")) - ; Here's all of the stacks of pieces + ; Here's all of the towers of pieces ; This is generated when the program is run -(setq stacks nil) +(define towers ()) - ; Display one stack, clearing any +(define 1- (lambda (x) (- x 1))) + ; Display one tower, clearing any ; space above it -(defun display-stack (x y clear stack) - (cond ((= 0 clear) - (cond (stack - (display-string x y (car stack)) - (display-stack x (1+ y) 0 (cdr stack)) - ) - ) - ) - (t - (display-string x y " ") - (display-stack x (1+ y) (1- clear) stack) - ) - ) +(define display-tower (lambda (x y clear tower) + (cond ((= 0 clear) + (cond ((not (null? tower)) + (display-string x y (car tower)) + (display-tower x (1+ y) 0 (cdr tower)) + ) + ) + ) + (else + (display-string x y " ") + (display-tower x (1+ y) (1- clear) tower) + ) + ) + ) ) - ; Position of the top of the stack on the screen - ; Shorter stacks start further down the screen + ; Position of the top of the tower on the screen + ; Shorter towers start further down the screen -(defun stack-pos (y stack) - (- y (length stack)) +(define tower-pos (lambda (y tower) + (- y (length tower)) + ) ) - ; Display all of the stacks, spaced 20 columns apart + ; Display all of the towers, spaced 20 columns apart -(defun display-stacks (x y stacks) - (cond (stacks - (display-stack x 0 (stack-pos y (car stacks)) (car stacks)) - (display-stacks (+ x 20) y (cdr stacks))) - ) +(define display-towers (lambda (x y towers) + (cond ((not (null? towers)) + (display-tower x 0 (tower-pos y (car towers)) (car towers)) + (display-towers (+ x 20) y (cdr towers))) + ) + ) ) - ; Display all of the stacks, then move the cursor +(define top 0) + ; Display all of the towers, then move the cursor ; out of the way and flush the output -(defun display () - (display-stacks 0 top stacks) - (move-to 1 21) - (flush) +(define display-hanoi (lambda () + (display-towers 0 top towers) + (move-to 1 21) + (flush-output) + ) ) - ; Reset stacks to the starting state, with - ; all of the pieces in the first stack and the + ; Reset towers to the starting state, with + ; all of the pieces in the first tower and the ; other two empty -(defun reset-stacks () - (setq stacks (list stack nil nil)) - (setq top (+ (length stack) 3)) - (length stack) - ) - - ; more functions which could usefully - ; be in the rom image - -(defun min (a b) - (cond ((< a b) a) - (b) - ) +(define reset-towers (lambda () + (set! towers (list tower () ())) + (set! top (+ (length tower) 3)) + (length tower) + ) ) - ; Replace a stack in the list of stacks + ; Replace a tower in the list of towers ; with a new value -(defun replace (list pos member) - (cond ((= pos 0) (cons member (cdr list))) - ((cons (car list) (replace (cdr list) (1- pos) member))) - ) +(define replace (lambda (list pos member) + (cond ((= pos 0) (cons member (cdr list))) + ((cons (car list) (replace (cdr list) (1- pos) member))) + ) + ) ) - ; Move a piece from the top of one stack + ; Move a piece from the top of one tower ; to the top of another -(setq move-delay 100) - -(defun move-piece (from to) - (let ((from-stack (nth stacks from)) - (to-stack (nth stacks to)) - (piece (car from-stack))) - (setq from-stack (cdr from-stack)) - (setq to-stack (cons piece to-stack)) - (setq stacks (replace stacks from from-stack)) - (setq stacks (replace stacks to to-stack)) - (display) - (delay move-delay) - ) +(define move-delay 10) + +(define move-piece (lambda (from to) + (let* ((from-tower (list-ref towers from)) + (to-tower (list-ref towers to)) + (piece (car from-tower))) + (set! from-tower (cdr from-tower)) + (set! to-tower (cons piece to-tower)) + (set! towers (replace towers from from-tower)) + (set! towers (replace towers to to-tower)) + (display-hanoi) +; (delay move-delay) + ) + ) ) ; The implementation of the game -(defun _hanoi (n from to use) - (cond ((= 1 n) - (move-piece from to) - ) - (t - (_hanoi (1- n) from use to) - (_hanoi 1 from to use) - (_hanoi (1- n) use to from) - ) - ) +(define _hanoi (lambda (n from to use) + (cond ((= 1 n) + (move-piece from to) + ) + (else + (_hanoi (1- n) from use to) + (_hanoi 1 from to use) + (_hanoi (1- n) use to from) + ) + ) + ) ) ; A pretty interface which @@ -146,10 +150,13 @@ ; clears the screen and runs ; the program -(defun hanoi () - (setq len (reset-stacks)) - (clear) - (_hanoi len 0 1 2) - (move-to 0 23) - t +(define hanoi (lambda () + (let ((len)) + (set! len (reset-towers)) + (clear) + (_hanoi len 0 1 2) + (move-to 0 23) + #t + ) + ) ) -- cgit v1.2.3 From 6d2f271a45759bd792d299f04a424d3382ef4798 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 19 Nov 2017 21:07:00 -0800 Subject: altos/lisp: Add floats Signed-off-by: Keith Packard --- src/lisp/Makefile | 2 +- src/lisp/Makefile-inc | 1 + src/lisp/ao_lisp.h | 48 +++++++++++++- src/lisp/ao_lisp_builtin.c | 119 ++++++++++++++++++++++++---------- src/lisp/ao_lisp_builtin.txt | 7 +- src/lisp/ao_lisp_cons.c | 13 ++++ src/lisp/ao_lisp_const.lisp | 3 - src/lisp/ao_lisp_eval.c | 1 + src/lisp/ao_lisp_float.c | 148 +++++++++++++++++++++++++++++++++++++++++++ src/lisp/ao_lisp_mem.c | 1 + src/lisp/ao_lisp_poly.c | 4 ++ src/lisp/ao_lisp_read.c | 77 ++++++++++++++++++---- src/lisp/ao_lisp_read.h | 24 +++---- 13 files changed, 384 insertions(+), 64 deletions(-) create mode 100644 src/lisp/ao_lisp_float.c diff --git a/src/lisp/Makefile b/src/lisp/Makefile index 4563dad3..05f54550 100644 --- a/src/lisp/Makefile +++ b/src/lisp/Makefile @@ -19,6 +19,6 @@ OBJS=$(SRCS:.c=.o) CFLAGS=-DAO_LISP_MAKE_CONST -O0 -g -I. -Wall -Wextra -no-pie ao_lisp_make_const: $(OBJS) - $(CC) $(CFLAGS) -o $@ $(OBJS) + $(CC) $(CFLAGS) -o $@ $(OBJS) -lm $(OBJS): $(HDRS) diff --git a/src/lisp/Makefile-inc b/src/lisp/Makefile-inc index 6c8702fb..a097f1be 100644 --- a/src/lisp/Makefile-inc +++ b/src/lisp/Makefile-inc @@ -6,6 +6,7 @@ LISP_SRCS=\ ao_lisp_int.c \ ao_lisp_poly.c \ ao_lisp_bool.c \ + ao_lisp_float.c \ ao_lisp_builtin.c \ ao_lisp_read.c \ ao_lisp_frame.c \ diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 08278fe7..cbbbe9a4 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -96,7 +96,8 @@ extern uint8_t ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA] __attribute__((a #define AO_LISP_STACK 8 #define AO_LISP_BOOL 9 #define AO_LISP_BIGINT 10 -#define AO_LISP_NUM_TYPE 11 +#define AO_LISP_FLOAT 11 +#define AO_LISP_NUM_TYPE 12 /* Leave two bits for types to use as they please */ #define AO_LISP_OTHER_TYPE_MASK 0x3f @@ -170,6 +171,13 @@ struct ao_lisp_bigint { uint32_t value; }; +struct ao_lisp_float { + uint8_t type; + uint8_t pad1; + uint16_t pad2; + float value; +}; + #if __BYTE_ORDER == __LITTLE_ENDIAN static inline uint32_t ao_lisp_int_bigint(int32_t i) { @@ -442,6 +450,22 @@ ao_lisp_poly_bool(ao_poly poly) { return ao_lisp_ref(poly); } + +static inline ao_poly +ao_lisp_float_poly(struct ao_lisp_float *f) +{ + return ao_lisp_poly(f, AO_LISP_OTHER); +} + +static inline struct ao_lisp_float * +ao_lisp_poly_float(ao_poly poly) +{ + return ao_lisp_ref(poly); +} + +float +ao_lisp_poly_number(ao_poly p); + /* memory functions */ extern int ao_lisp_collects[2]; @@ -524,6 +548,10 @@ extern const struct ao_lisp_type ao_lisp_cons_type; struct ao_lisp_cons * ao_lisp_cons_cons(ao_poly car, ao_poly cdr); +/* Return a cons or NULL for a proper list, else error */ +struct ao_lisp_cons * +ao_lisp_cons_cdr(struct ao_lisp_cons *cons); + ao_poly ao_lisp__cons(ao_poly car, ao_poly cdr); @@ -632,6 +660,24 @@ ao_lisp_eval(ao_poly p); ao_poly ao_lisp_set_cond(struct ao_lisp_cons *cons); +/* float */ +extern const struct ao_lisp_type ao_lisp_float_type; + +void +ao_lisp_float_write(ao_poly p); + +ao_poly +ao_lisp_float_get(float value); + +static inline uint8_t +ao_lisp_number_typep(uint8_t t) +{ + return ao_lisp_integer_typep(t) || (t == AO_LISP_FLOAT); +} + +float +ao_lisp_poly_number(ao_poly p); + /* builtin */ void ao_lisp_builtin_write(ao_poly b); diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index e5370f90..d4dc8a86 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -14,6 +14,7 @@ #include "ao_lisp.h" #include +#include static int builtin_size(void *addr) @@ -98,7 +99,7 @@ ao_lisp_check_argc(ao_poly name, struct ao_lisp_cons *cons, int min, int max) while (cons && argc <= max) { argc++; - cons = ao_lisp_poly_cons(cons->cdr); + cons = ao_lisp_cons_cdr(cons); } if (argc < min || argc > max) return ao_lisp_error(AO_LISP_INVALID, "%s: invalid arg count", ao_lisp_poly_atom(name)->name); @@ -113,7 +114,7 @@ ao_lisp_arg(struct ao_lisp_cons *cons, int argc) while (argc--) { if (!cons) return AO_LISP_NIL; - cons = ao_lisp_poly_cons(cons->cdr); + cons = ao_lisp_cons_cdr(cons); } return cons->car; } @@ -162,17 +163,17 @@ ao_lisp_do_cons(struct ao_lisp_cons *cons) ao_poly ao_lisp_do_last(struct ao_lisp_cons *cons) { - ao_poly l; + struct ao_lisp_cons *list; if (!ao_lisp_check_argc(_ao_lisp_atom_last, cons, 1, 1)) return AO_LISP_NIL; if (!ao_lisp_check_argt(_ao_lisp_atom_last, cons, 0, AO_LISP_CONS, 1)) return AO_LISP_NIL; - l = ao_lisp_arg(cons, 0); - while (l) { - struct ao_lisp_cons *list = ao_lisp_poly_cons(l); + for (list = ao_lisp_poly_cons(ao_lisp_arg(cons, 0)); + list; + list = ao_lisp_cons_cdr(list)) + { if (!list->cdr) return list->car; - l = list->cdr; } return AO_LISP_NIL; } @@ -253,7 +254,7 @@ ao_lisp_do_write(struct ao_lisp_cons *cons) while (cons) { val = cons->car; ao_lisp_poly_write(val); - cons = ao_lisp_poly_cons(cons->cdr); + cons = ao_lisp_cons_cdr(cons); if (cons) printf(" "); } @@ -268,39 +269,38 @@ ao_lisp_do_display(struct ao_lisp_cons *cons) while (cons) { val = cons->car; ao_lisp_poly_display(val); - cons = ao_lisp_poly_cons(cons->cdr); + cons = ao_lisp_cons_cdr(cons); } return _ao_lisp_bool_true; } ao_poly -ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) +ao_lisp_math(struct ao_lisp_cons *orig_cons, enum ao_lisp_builtin_id op) { - struct ao_lisp_cons *orig_cons = cons; + struct ao_lisp_cons *cons = cons; ao_poly ret = AO_LISP_NIL; - while (cons) { + for (cons = orig_cons; cons; cons = ao_lisp_cons_cdr(cons)) { ao_poly car = cons->car; - ao_poly cdr; uint8_t rt = ao_lisp_poly_type(ret); uint8_t ct = ao_lisp_poly_type(car); if (cons == orig_cons) { ret = car; - if (cons->cdr == AO_LISP_NIL && ct == AO_LISP_INT) { + if (cons->cdr == AO_LISP_NIL) { switch (op) { case builtin_minus: - ret = ao_lisp_integer_poly(-ao_lisp_poly_integer(ret)); + if (ao_lisp_integer_typep(ct)) + ret = ao_lisp_integer_poly(-ao_lisp_poly_integer(ret)); + else if (ct == AO_LISP_FLOAT) + ret = ao_lisp_float_get(-ao_lisp_poly_number(ret)); break; case builtin_divide: - switch (ao_lisp_poly_integer(ret)) { - case 0: - return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero"); - case 1: - break; - default: - ret = ao_lisp_int_poly(0); - break; + if (ao_lisp_integer_typep(ct) && ao_lisp_poly_integer(ret) == 1) + ; + else if (ao_lisp_number_typep(ct)) { + float v = ao_lisp_poly_number(ret); + ret = ao_lisp_float_get(1/v); } break; default: @@ -322,10 +322,54 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) r *= c; break; case builtin_divide: + if (c != 0 && (r % c) == 0) + r /= c; + else { + ret = ao_lisp_float_get((float) r / (float) c); + continue; + } + break; + case builtin_quotient: + if (c == 0) + return ao_lisp_error(AO_LISP_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_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "divide by zero"); + return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "remainder by zero"); + r %= c; + break; + case builtin_modulo: + if (c == 0) + return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "modulo by zero"); + r %= c; + if ((r < 0) != (c < 0)) + r += c; + break; + default: + break; + } + ret = ao_lisp_integer_poly(r); + } else if (ao_lisp_number_typep(rt) && ao_lisp_number_typep(ct)) { + float r = ao_lisp_poly_number(ret); + float c = ao_lisp_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; +#if 0 case builtin_quotient: if (c == 0) return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "quotient by zero"); @@ -346,10 +390,11 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) if ((r < 0) != (c < 0)) r += c; break; +#endif default: break; } - ret = ao_lisp_integer_poly(r); + ret = ao_lisp_float_get(r); } else if (rt == AO_LISP_STRING && ct == AO_LISP_STRING && op == builtin_plus) @@ -357,11 +402,6 @@ ao_lisp_math(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) ao_lisp_poly_string(car))); else return ao_lisp_error(AO_LISP_INVALID, "invalid args"); - - cdr = cons->cdr; - if (cdr != AO_LISP_NIL && ao_lisp_poly_type(cdr) != AO_LISP_CONS) - return ao_lisp_error(AO_LISP_INVALID, "improper list"); - cons = ao_lisp_poly_cons(cdr); } return ret; } @@ -417,8 +457,7 @@ ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) return _ao_lisp_bool_true; left = cons->car; - cons = ao_lisp_poly_cons(cons->cdr); - while (cons) { + for (cons = ao_lisp_cons_cdr(cons); cons; cons = ao_lisp_cons_cdr(cons)) { ao_poly right = cons->car; if (op == builtin_equal) { @@ -477,7 +516,6 @@ ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) } } left = right; - cons = ao_lisp_poly_cons(cons->cdr); } return _ao_lisp_bool_true; } @@ -640,6 +678,20 @@ ao_lisp_do_pairp(struct ao_lisp_cons *cons) return ao_lisp_do_typep(AO_LISP_CONS, cons); } +ao_poly +ao_lisp_do_integerp(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) { + case AO_LISP_INT: + case AO_LISP_BIGINT: + return _ao_lisp_bool_true; + default: + return _ao_lisp_bool_false; + } +} + ao_poly ao_lisp_do_numberp(struct ao_lisp_cons *cons) { @@ -648,6 +700,7 @@ ao_lisp_do_numberp(struct ao_lisp_cons *cons) switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) { case AO_LISP_INT: case AO_LISP_BIGINT: + case AO_LISP_FLOAT: return _ao_lisp_bool_true; default: return _ao_lisp_bool_false; diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt index c324ca67..2e11bdad 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/lisp/ao_lisp_builtin.txt @@ -42,7 +42,8 @@ f_lambda nullp null? f_lambda not f_lambda listp list? f_lambda pairp pair? -f_lambda numberp number? integer? +f_lambda integerp integer? exact? exact-integer? +f_lambda numberp number? real? f_lambda booleanp boolean? f_lambda set_car set-car! f_lambda set_cdr set-cdr! @@ -58,3 +59,7 @@ f_lambda exit f_lambda current_jiffy current-jiffy f_lambda current_second current-second f_lambda jiffies_per_second jiffies-per-second +f_lambda finitep finite? +f_lambda infinitep infinite? +f_lambda inexactp inexact? +f_lambda sqrt diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index 9379597c..c70aa1ca 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -105,6 +105,19 @@ ao_lisp_cons_cons(ao_poly car, ao_poly cdr) return cons; } +struct ao_lisp_cons * +ao_lisp_cons_cdr(struct ao_lisp_cons *cons) +{ + ao_poly cdr = cons->cdr; + if (cdr == AO_LISP_NIL) + return NULL; + if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) { + (void) ao_lisp_error(AO_LISP_INVALID, "improper list"); + return NULL; + } + return ao_lisp_poly_cons(cdr); +} + ao_poly ao_lisp__cons(ao_poly car, ao_poly cdr) { diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 861a4fc8..9fb7634c 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -159,9 +159,6 @@ (odd? 3) (odd? -1) -(define exact? number?) -(defun inexact? (x) #f) - ; (if ) ; (if + * + * 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_lisp.h" +#include + +static void float_mark(void *addr) +{ + (void) addr; +} + +static int float_size(void *addr) +{ + if (!addr) + return 0; + return sizeof (struct ao_lisp_float); +} + +static void float_move(void *addr) +{ + (void) addr; +} + +const struct ao_lisp_type ao_lisp_float_type = { + .mark = float_mark, + .size = float_size, + .move = float_move, + .name = "float", +}; + +void +ao_lisp_float_write(ao_poly p) +{ + struct ao_lisp_float *f = ao_lisp_poly_float(p); + float v = f->value; + + if (isnanf(v)) + printf("+nan.0"); + else if (isinff(v)) { + if (v < 0) + printf("-"); + else + printf("+"); + printf("inf.0"); + } else + printf ("%g", f->value); +} + +float +ao_lisp_poly_number(ao_poly p) +{ + switch (ao_lisp_poly_base_type(p)) { + case AO_LISP_INT: + return ao_lisp_poly_int(p); + case AO_LISP_OTHER: + switch (ao_lisp_other_type(ao_lisp_poly_other(p))) { + case AO_LISP_BIGINT: + return ao_lisp_bigint_int(ao_lisp_poly_bigint(p)->value); + case AO_LISP_FLOAT: + return ao_lisp_poly_float(p)->value; + } + } + return NAN; +} + +ao_poly +ao_lisp_float_get(float value) +{ + struct ao_lisp_float *f; + + f = ao_lisp_alloc(sizeof (struct ao_lisp_float)); + f->type = AO_LISP_FLOAT; + f->value = value; + return ao_lisp_float_poly(f); +} + +ao_poly +ao_lisp_do_inexactp(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + if (ao_lisp_poly_type(ao_lisp_arg(cons, 0)) == AO_LISP_FLOAT) + return _ao_lisp_bool_true; + return _ao_lisp_bool_false; +} + +ao_poly +ao_lisp_do_finitep(struct ao_lisp_cons *cons) +{ + ao_poly value; + float f; + + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + value = ao_lisp_arg(cons, 0); + switch (ao_lisp_poly_type(value)) { + case AO_LISP_INT: + case AO_LISP_BIGINT: + return _ao_lisp_bool_true; + case AO_LISP_FLOAT: + f = ao_lisp_poly_float(value)->value; + if (!isnan(f) && !isinf(f)) + return _ao_lisp_bool_true; + } + return _ao_lisp_bool_false; +} + +ao_poly +ao_lisp_do_infinitep(struct ao_lisp_cons *cons) +{ + ao_poly value; + float f; + + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + value = ao_lisp_arg(cons, 0); + switch (ao_lisp_poly_type(value)) { + case AO_LISP_FLOAT: + f = ao_lisp_poly_float(value)->value; + if (isinf(f)) + return _ao_lisp_bool_true; + } + return _ao_lisp_bool_false; +} + +ao_poly +ao_lisp_do_sqrt(struct ao_lisp_cons *cons) +{ + ao_poly value; + + if (!ao_lisp_check_argc(_ao_lisp_atom_sqrt, cons, 1, 1)) + return AO_LISP_NIL; + value = ao_lisp_arg(cons, 0); + if (!ao_lisp_number_typep(ao_lisp_poly_type(value))) + return ao_lisp_error(AO_LISP_INVALID, "%s: non-numeric", ao_lisp_poly_atom(_ao_lisp_atom_sqrt)->name); + return ao_lisp_float_get(sqrtf(ao_lisp_poly_number(value))); +} diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index f333073a..dc0008c4 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -459,6 +459,7 @@ static const struct ao_lisp_type *ao_lisp_types[AO_LISP_NUM_TYPE] = { [AO_LISP_STACK] = &ao_lisp_stack_type, [AO_LISP_BOOL] = &ao_lisp_bool_type, [AO_LISP_BIGINT] = &ao_lisp_bigint_type, + [AO_LISP_FLOAT] = &ao_lisp_float_type, }; static int diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c index 94ecd042..e93e1192 100644 --- a/src/lisp/ao_lisp_poly.c +++ b/src/lisp/ao_lisp_poly.c @@ -60,6 +60,10 @@ static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { .write = ao_lisp_bigint_write, .display = ao_lisp_bigint_write, }, + [AO_LISP_FLOAT] = { + .write = ao_lisp_float_write, + .display = ao_lisp_float_write, + }, }; static const struct ao_lisp_funcs * diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index 5115f46e..c5a238cc 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -14,6 +14,7 @@ #include "ao_lisp.h" #include "ao_lisp_read.h" +#include static const uint16_t lex_classes[128] = { IGNORE, /* ^@ */ @@ -62,7 +63,7 @@ static const uint16_t lex_classes[128] = { PRINTABLE|SIGN, /* + */ PRINTABLE, /* , */ PRINTABLE|SIGN, /* - */ - PRINTABLE|SPECIAL, /* . */ + PRINTABLE|DOTC|FLOATC, /* . */ PRINTABLE, /* / */ PRINTABLE|DIGIT, /* 0 */ PRINTABLE|DIGIT, /* 1 */ @@ -85,7 +86,7 @@ static const uint16_t lex_classes[128] = { PRINTABLE, /* B */ PRINTABLE, /* C */ PRINTABLE, /* D */ - PRINTABLE, /* E */ + PRINTABLE|FLOATC, /* E */ PRINTABLE, /* F */ PRINTABLE, /* G */ PRINTABLE, /* H */ @@ -117,7 +118,7 @@ static const uint16_t lex_classes[128] = { PRINTABLE, /* b */ PRINTABLE, /* c */ PRINTABLE, /* d */ - PRINTABLE, /* e */ + PRINTABLE|FLOATC, /* e */ PRINTABLE, /* f */ PRINTABLE, /* g */ PRINTABLE, /* h */ @@ -140,7 +141,7 @@ static const uint16_t lex_classes[128] = { PRINTABLE, /* y */ PRINTABLE, /* z */ PRINTABLE, /* { */ - PRINTABLE|VBAR, /* | */ + PRINTABLE, /* | */ PRINTABLE, /* } */ PRINTABLE, /* ~ */ IGNORE, /* ^? */ @@ -247,16 +248,36 @@ lex_quoted(void) static char token_string[AO_LISP_TOKEN_MAX]; static int32_t token_int; static int token_len; +static float token_float; static inline void add_token(int c) { if (c && token_len < AO_LISP_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'; } +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]) + static int _lex(void) { @@ -279,7 +300,7 @@ _lex(void) continue; } - if (lex_class & SPECIAL) { + if (lex_class & (SPECIAL|DOTC)) { add_token(c); end_token(); switch (c) { @@ -357,47 +378,72 @@ _lex(void) } } if (lex_class & PRINTABLE) { - int isnum; + int isfloat; int hasdigit; int isneg; + int isint; + int epos; - isnum = 1; + isfloat = 1; + isint = 1; hasdigit = 0; token_int = 0; isneg = 0; + epos = 0; for (;;) { if (!(lex_class & NUMBER)) { - isnum = 0; + isint = 0; + isfloat = 0; } else { - if (token_len != 0 && + if (!(lex_class & INTEGER)) + isint = 0; + if (token_len != epos && (lex_class & SIGN)) { - isnum = 0; + isint = 0; + isfloat = 0; } if (c == '-') isneg = 1; + if (c == '.' && epos != 0) + isfloat = 0; + if (c == 'e' || c == 'E') { + if (token_len == 0) + isfloat = 0; + else + epos = token_len + 1; + } if (lex_class & DIGIT) { hasdigit = 1; - if (isnum) + if (isint) token_int = token_int * 10 + c - '0'; } } add_token (c); c = lexc (); - if (lex_class & (NOTNAME)) { + if ((lex_class & (NOTNAME)) && (c != '.' || !isfloat)) { + unsigned int u; // if (lex_class & ENDOFFILE) // clearerr (f); lex_unget(c); end_token (); - if (isnum && hasdigit) { + if (isint && hasdigit) { if (isneg) token_int = -token_int; return NUM; } + if (isfloat && hasdigit) { + token_float = atof(token_string); + return FLOAT; + } + for (u = 0; u < NUM_NAMED_FLOATS; u++) + if (!strcmp(namedfloats[u].name, token_string)) { + token_float = namedfloats[u].value; + return FLOAT; + } return NAME; } } - } } } @@ -499,6 +545,9 @@ ao_lisp_read(void) case NUM: v = ao_lisp_integer_poly(token_int); break; + case FLOAT: + v = ao_lisp_float_get(token_float); + break; case BOOL: if (token_string[0] == 't') v = _ao_lisp_bool_true; diff --git a/src/lisp/ao_lisp_read.h b/src/lisp/ao_lisp_read.h index fc74a8e4..20c9c18a 100644 --- a/src/lisp/ao_lisp_read.h +++ b/src/lisp/ao_lisp_read.h @@ -26,28 +26,30 @@ # define QUOTE 4 # define STRING 5 # define NUM 6 -# define DOT 7 -# define BOOL 8 +# define FLOAT 7 +# define DOT 8 +# define BOOL 9 /* * character classes */ # define PRINTABLE 0x0001 /* \t \n ' ' - '~' */ -# define QUOTED 0x0002 /* \ anything */ -# define SPECIAL 0x0004 /* ( [ { ) ] } ' . */ +# define SPECIAL 0x0002 /* ( [ { ) ] } ' */ +# define DOTC 0x0004 /* . */ # define WHITE 0x0008 /* ' ' \t \n */ # define DIGIT 0x0010 /* [0-9] */ # define SIGN 0x0020 /* +- */ -# define ENDOFFILE 0x0040 /* end of file */ -# define COMMENT 0x0080 /* ; */ -# define IGNORE 0x0100 /* \0 - ' ' */ -# define BACKSLASH 0x0200 /* \ */ -# define VBAR 0x0400 /* | */ +# define FLOATC 0x0040 /* . e E */ +# 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|VBAR|COMMENT|ENDOFFILE|WHITE|SPECIAL) -# define NUMBER (DIGIT|SIGN) +# define NOTNAME (STRINGC|COMMENT|ENDOFFILE|WHITE|SPECIAL) +# define INTEGER (DIGIT|SIGN) +# define NUMBER (INTEGER|FLOATC) #endif /* _AO_LISP_READ_H_ */ -- cgit v1.2.3 From 5f9f97cc2d43936d1941da3a9a130c279bc70b99 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 19 Nov 2017 21:07:23 -0800 Subject: altos/test: Update to build altos lisp test app Signed-off-by: Keith Packard --- src/test/Makefile | 2 +- src/test/hanoi.lisp | 15 ++++++++------- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/src/test/Makefile b/src/test/Makefile index 9fe886b9..4ac2c893 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -104,7 +104,7 @@ AO_LISP_SRCS=$(LISP_SRCS) ao_lisp_test.c AO_LISP_OBJS=$(AO_LISP_SRCS:.c=.o) ao_lisp_test: $(AO_LISP_OBJS) - cc $(CFLAGS) -o $@ $(AO_LISP_OBJS) + cc $(CFLAGS) -o $@ $(AO_LISP_OBJS) -lm $(AO_LISP_OBJS): $(LISP_HDRS) ao_lisp_const.h diff --git a/src/test/hanoi.lisp b/src/test/hanoi.lisp index e873c796..02e16876 100644 --- a/src/test/hanoi.lisp +++ b/src/test/hanoi.lisp @@ -41,7 +41,8 @@ (define towers ()) -(define 1- (lambda (x) (- x 1))) +(define one- (lambda (x) (- x 1))) +(define one+ (lambda (x) (+ x 1))) ; Display one tower, clearing any ; space above it @@ -49,13 +50,13 @@ (cond ((= 0 clear) (cond ((not (null? tower)) (display-string x y (car tower)) - (display-tower x (1+ y) 0 (cdr tower)) + (display-tower x (one+ y) 0 (cdr tower)) ) ) ) (else (display-string x y " ") - (display-tower x (1+ y) (1- clear) tower) + (display-tower x (one+ y) (one- clear) tower) ) ) ) @@ -106,7 +107,7 @@ (define replace (lambda (list pos member) (cond ((= pos 0) (cons member (cdr list))) - ((cons (car list) (replace (cdr list) (1- pos) member))) + ((cons (car list) (replace (cdr list) (one- pos) member))) ) ) ) @@ -125,7 +126,7 @@ (set! towers (replace towers from from-tower)) (set! towers (replace towers to to-tower)) (display-hanoi) -; (delay move-delay) + (delay move-delay) ) ) ) @@ -137,9 +138,9 @@ (move-piece from to) ) (else - (_hanoi (1- n) from use to) + (_hanoi (one- n) from use to) (_hanoi 1 from to use) - (_hanoi (1- n) use to from) + (_hanoi (one- n) use to from) ) ) ) -- cgit v1.2.3 From 00bf2ca86b60e6501880011897cea073865c5a03 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 25 Nov 2017 17:29:10 -0800 Subject: altos/lisp: Rename progn to begin Match scheme name. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 2 +- src/lisp/ao_lisp_builtin.c | 4 ++-- src/lisp/ao_lisp_builtin.txt | 2 +- src/lisp/ao_lisp_const.lisp | 22 +++++++++++++++++++++- src/lisp/ao_lisp_eval.c | 20 ++++++++++---------- src/lisp/ao_lisp_stack.c | 2 +- 6 files changed, 36 insertions(+), 16 deletions(-) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index cbbbe9a4..858212dd 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -229,7 +229,7 @@ enum eval_state { eval_apply, /* Execute apply */ eval_cond, /* Start next cond clause */ eval_cond_test, /* Check cond condition */ - eval_progn, /* Start next progn entry */ + eval_begin, /* Start next begin entry */ eval_while, /* Start while condition */ eval_while_test, /* Check while condition */ eval_macro, /* Finished with macro generation */ diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index d4dc8a86..693cc3ca 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -232,9 +232,9 @@ ao_lisp_do_cond(struct ao_lisp_cons *cons) } ao_poly -ao_lisp_do_progn(struct ao_lisp_cons *cons) +ao_lisp_do_begin(struct ao_lisp_cons *cons) { - ao_lisp_stack->state = eval_progn; + ao_lisp_stack->state = eval_begin; ao_lisp_stack->sexprs = ao_lisp_cons_poly(cons); return AO_LISP_NIL; } diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt index 2e11bdad..236cadb4 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/lisp/ao_lisp_builtin.txt @@ -13,7 +13,7 @@ nlambda quote f_lambda set macro setq set! nlambda cond -nlambda progn +nlambda begin nlambda while f_lexpr write f_lexpr display diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 9fb7634c..f8a70979 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -25,7 +25,7 @@ (set (quote define) (macro (name val rest) (list - 'progn + 'begin (list 'set (list 'quote name) @@ -520,6 +520,26 @@ '(54 0 37 -3 245 19)) #t)) +(define repeat (macro (count rest) + (list + let + (list + (list '__count__ count)) + (append + (list + while + (list + <= + 0 + (list + set! + '__count__ + (list + - + '__count__ + 1)))) + rest)))) + ;(define number->string (lexpr (arg opt) ; (let ((base (if (null? opt) 10 (car opt))) ; diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index cfa71fa7..1044aa48 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -283,7 +283,7 @@ ao_lisp_eval_exec(void) break; case AO_LISP_LAMBDA: DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - ao_lisp_stack->state = eval_progn; + ao_lisp_stack->state = eval_begin; v = ao_lisp_lambda_eval(); ao_lisp_stack->sexprs = v; ao_lisp_stack->values = AO_LISP_NIL; @@ -388,7 +388,7 @@ ao_lisp_eval_cond_test(void) ao_poly c = car->cdr; if (c) { - ao_lisp_stack->state = eval_progn; + ao_lisp_stack->state = eval_begin; ao_lisp_stack->sexprs = c; } else ao_lisp_stack->state = eval_val; @@ -403,17 +403,17 @@ ao_lisp_eval_cond_test(void) /* * Evaluate a list of sexprs, returning the value from the last one. * - * ao_lisp_progn records the list in stack->sexprs, so we just need to + * ao_lisp_begin records the list in stack->sexprs, so we just need to * walk that list. Set ao_lisp_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_progn set so that we come + * 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_lisp_eval_progn(void) +ao_lisp_eval_begin(void) { - DBGI("progn: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); + DBGI("begin: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); @@ -428,7 +428,7 @@ ao_lisp_eval_progn(void) * return the value of the last one by just landing in eval_sexpr */ if (ao_lisp_stack->sexprs) { - ao_lisp_stack->state = eval_progn; + ao_lisp_stack->state = eval_begin; if (!ao_lisp_stack_push()) return 0; } @@ -476,7 +476,7 @@ ao_lisp_eval_while_test(void) ao_lisp_stack->state = eval_while; if (!ao_lisp_stack_push()) return 0; - ao_lisp_stack->state = eval_progn; + ao_lisp_stack->state = eval_begin; ao_lisp_stack->sexprs = ao_lisp_v; } else @@ -516,7 +516,7 @@ static int (*const evals[])(void) = { [eval_apply] = ao_lisp_eval_apply, [eval_cond] = ao_lisp_eval_cond, [eval_cond_test] = ao_lisp_eval_cond_test, - [eval_progn] = ao_lisp_eval_progn, + [eval_begin] = ao_lisp_eval_begin, [eval_while] = ao_lisp_eval_while, [eval_while_test] = ao_lisp_eval_while_test, [eval_macro] = ao_lisp_eval_macro, @@ -530,7 +530,7 @@ const char *ao_lisp_state_names[] = { [eval_apply] = "apply", [eval_cond] = "cond", [eval_cond_test] = "cond_test", - [eval_progn] = "progn", + [eval_begin] = "begin", [eval_while] = "while", [eval_while_test] = "while_test", [eval_macro] = "macro", diff --git a/src/lisp/ao_lisp_stack.c b/src/lisp/ao_lisp_stack.c index af68b656..9d6cccc4 100644 --- a/src/lisp/ao_lisp_stack.c +++ b/src/lisp/ao_lisp_stack.c @@ -273,6 +273,6 @@ ao_lisp_do_call_cc(struct ao_lisp_cons *cons) cons->cdr = AO_LISP_NIL; v = ao_lisp_lambda_eval(); ao_lisp_stack->sexprs = v; - ao_lisp_stack->state = eval_progn; + ao_lisp_stack->state = eval_begin; return AO_LISP_NIL; } -- cgit v1.2.3 From cd0bd9791a77868c226d285bf4d57e8c321755d5 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 1 Dec 2017 10:12:38 +0100 Subject: altos/lisp: Add quasiquote This adds read support for quasiquote syntax, and then adds a quasiquote implementation in lisp Signed-off-by: Keith Packard --- src/lisp/ao_lisp_builtin.txt | 3 + src/lisp/ao_lisp_const.lisp | 573 ++++++++++++++++++++++++++++-------------- src/lisp/ao_lisp_make_builtin | 48 ++-- src/lisp/ao_lisp_read.c | 34 ++- src/lisp/ao_lisp_read.h | 27 +- 5 files changed, 458 insertions(+), 227 deletions(-) diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt index 236cadb4..6925ac17 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/lisp/ao_lisp_builtin.txt @@ -10,6 +10,9 @@ f_lambda cons f_lambda last f_lambda length nlambda quote +atom quasiquote +atom unquote +atom unquote_splicing unquote-splicing f_lambda set macro setq set! nlambda cond diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index f8a70979..f1c2ed00 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -14,107 +14,320 @@ ; Lisp code placed in ROM ; return a list containing all of the arguments - (set (quote list) (lexpr (l) l)) - ; - ; Define a variable without returning the value - ; Useful when defining functions to avoid - ; having lots of output generated - ; +(set (quote set!) + (macro (name value rest) + (list + set + (list + quote + name) + value) + ) + ) -(set (quote define) (macro (name val rest) - (list - 'begin - (list - 'set - (list 'quote name) - val) - (list 'quote name) - ) - ) +(set! append + (lexpr (args) + ((lambda (append-list append-lists) + (set! append-list + (lambda (a b) + (cond ((null? a) b) + (else (cons (car a) (append-list (cdr a) b))) + ) + ) + ) + (set! 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 '(a b c) '(d e f) '(g h i)) + + ; boolean operators + +(set! or + (macro (l) + ((lambda (_or) + (set! _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)) ()))) + + ; execute to resolve macros + +(or #f #t) + + +(set! and + (macro (l) + ((lambda (_and) + (set! _and + (lambda (l) + (cond ((null? l) #t) + ((null? (cdr l)) + (car l)) + (else + (list + cond + (list + (car l) + (_and (cdr l)) + ) + ) + ) + ) + ) + ) + (_and l)) ()) + ) ) + + ; execute to resolve macros + +(and #t #f) + +(set! quasiquote + (macro (x rest) + ((lambda (constant? combine-skeletons expand-quasiquote) + (set! 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)) + ) + ) + ) + ) + (set! 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) + ) + ) + ) + ) + + (set! 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) + ) + ) + ) + ) + (expand-quasiquote x 0) + ) () () ()) + ) + ) ; - ; A slightly more convenient form - ; for defining lambdas. + ; Define a variable without returning the value + ; Useful when defining functions to avoid + ; having lots of output generated. ; - ; (defun () s-exprs) + ; Also accepts the alternate + ; form for defining lambdas of + ; (define (name x y z) sexprs ...) ; -(define defun (macro (name args exprs) - (list - define - name - (cons 'lambda (cons args exprs)) +(set! define + (macro (first rest) + + ; check for alternate lambda definition form + + (cond ((list? first) + (set! rest + (append + (list + 'lambda + (cdr first)) + rest)) + (set! first (car first)) + ) + (else + (set! rest (car rest)) + ) ) - ) - ) + `(begin + (set! ,first ,rest) + (quote ,first)) + ) + ) ; basic list accessors -(defun caar (l) (car (car l))) +(define (caar l) (car (car l))) -(defun cadr (l) (car (cdr l))) +(define (cadr l) (car (cdr l))) -(defun caddr (l) (car (cdr (cdr l)))) +(define (cdar l) (cdr (car l))) -(define list-tail (lambda (x k) - (if (zero? k) - x - (list-tail (cdr x (- k 1))) - ) - ) - ) +(define (caddr l) (car (cdr (cdr l)))) -(define list-ref (lambda (x k) - (car (list-tail x k)) - ) +(define (list-tail x k) + (if (zero? k) + x + (list-tail (cdr x (- k 1))) + ) ) - ; simple math operators +(define (list-ref x k) + (car (list-tail x k)) + ) -(defun 1+ (x) (+ x 1)) -(defun 1- (x) (- x 1)) + ; (if ) + ; (if 3 2) 'yes) +(if (> 3 2) 'yes 'no) +(if (> 2 3) 'no 'yes) +(if (> 2 3) 'no) + + ; simple math operators + +(define zero? (macro (value rest) `(eq? ,value 0))) + (zero? 1) (zero? 0) (zero? "hello") -(define positive? (macro (value rest) - (list - > - value - 0) - ) - ) +(define positive? (macro (value rest) `(> ,value 0))) (positive? 12) (positive? -12) -(define negative? (macro (value rest) - (list - < - value - 0) - ) - ) +(define negative? (macro (value rest) `(< ,value 0))) (negative? 12) (negative? -12) -(defun abs (x) (cond ((>= x 0) x) - (else (- x))) - ) +(define (abs x) (if (>= x 0) x (- x))) (abs 12) (abs -12) @@ -145,44 +358,20 @@ (min 1 2 3) (min 3 2 1) -(defun even? (x) (zero? (% x 2))) +(define (even? x) (zero? (% x 2))) (even? 2) (even? -2) (even? 3) (even? -1) -(defun odd? (x) (not (even? x))) +(define (odd? x) (not (even? x))) (odd? 2) (odd? -2) (odd? 3) (odd? -1) - ; (if ) - ; (if 3 2) 'yes) -(if (> 3 2) 'yes 'no) -(if (> 2 3) 'no 'yes) -(if (> 2 3) 'no) ; define a set of local ; variables and then evaluate @@ -213,6 +402,7 @@ (cond ((not (null? vars)) (cons (car (car vars)) (make-names (cdr vars)))) + (else ()) ) ) ) @@ -235,7 +425,7 @@ (make-exprs (cdr vars) exprs) ) ) - (exprs) + (else exprs) ) ) ) @@ -245,6 +435,7 @@ (set! make-nils (lambda (vars) (cond ((not (null? vars)) (cons () (make-nils (cdr vars)))) + (else ()) ) ) ) @@ -269,65 +460,22 @@ (let ((x 1)) x) (define let* let) - ; boolean operators -(define or (lexpr (l) - (let ((ret #f)) - (while (not (null? l)) - (cond ((car l) (set! ret #t) (set! l ())) - ((set! l (cdr l))))) - ret - ) - ) - ) +(define when (macro (test l) + (list + cond + (cons test l)))) - ; execute to resolve macros - -(or #f #t) +(when #t (display 'when)) -(define and (lexpr (l) - (let ((ret #t)) - (while (not (null? l)) - (cond ((car l) - (set! l (cdr l))) - (#t - (set! ret #f) - (set! l ())) - ) - ) - ret - ) - ) - ) - - ; execute to resolve macros - -(and #t #f) - - -(define append (lexpr (args) - (let ((append-list (lambda (a b) - (cond ((null? a) b) - (else (cons (car a) (append-list (cdr a) b))) - ) - ) - ) - (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) - ) - ) - ) +(define unless (macro (test l) + (list + cond + (cons (list not test) l)))) -(append '(a b c) '(d e f) '(g h i)) +(unless #f (display 'unless)) -(defun reverse (list) +(define (reverse list) (let ((result ())) (while (not (null? list)) (set! result (cons (car list) result)) @@ -338,22 +486,20 @@ (reverse '(1 2 3)) -(define list-tail - (lambda (x k) - (if (zero? k) - x - (list-tail (cdr x) (- k 1))))) +(define (list-tail x k) + (if (zero? k) + x + (list-tail (cdr x) (- k 1))))) (list-tail '(1 2 3) 2) -(defun list-ref (x k) (car (list-tail x k))) +(define (list-ref x k) (car (list-tail x k))) (list-ref '(1 2 3) 2) - ; recursive equality -(defun equal? (a b) +(define (equal? a b) (cond ((eq? a b) #t) ((and (pair? a) (pair? b)) (and (equal? (car a) (car b)) @@ -366,32 +512,32 @@ (equal? '(a b c) '(a b c)) (equal? '(a b c) '(a b b)) -(defun _member (obj list test?) +(define (_member obj list test?) (if (null? list) #f (if (test? obj (car list)) list (memq obj (cdr list))))) -(defun memq (obj list) (_member obj list eq?)) +(define (memq obj list) (_member obj list eq?)) (memq 2 '(1 2 3)) (memq 4 '(1 2 3)) -(defun memv (obj list) (_member obj list eqv?)) +(define (memv obj list) (_member obj list eqv?)) (memv 2 '(1 2 3)) (memv 4 '(1 2 3)) -(defun member (obj list) (_member obj list equal?)) +(define (member obj list) (_member obj list equal?)) (member '(2) '((1) (2) (3))) (member '(4) '((1) (2) (3))) -(defun _assoc (obj list test?) +(define (_assoc obj list test?) (if (null? list) #f (if (test? obj (caar list)) @@ -401,9 +547,9 @@ ) ) -(defun assq (obj list) (_assoc obj list eq?)) -(defun assv (obj list) (_assoc obj list eqv?)) -(defun assoc (obj list) (_assoc obj list equal?)) +(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))) @@ -414,52 +560,52 @@ (char? #\q) (char? "h") -(defun char-upper-case? (c) (<= #\A c #\Z)) +(define (char-upper-case? c) (<= #\A c #\Z)) (char-upper-case? #\a) (char-upper-case? #\B) (char-upper-case? #\0) (char-upper-case? #\space) -(defun char-lower-case? (c) (<= #\a c #\a)) +(define (char-lower-case? c) (<= #\a c #\a)) (char-lower-case? #\a) (char-lower-case? #\B) (char-lower-case? #\0) (char-lower-case? #\space) -(defun char-alphabetic? (c) (or (char-upper-case? c) (char-lower-case? c))) +(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) -(defun char-numeric? (c) (<= #\0 c #\9)) +(define (char-numeric? c) (<= #\0 c #\9)) (char-numeric? #\a) (char-numeric? #\B) (char-numeric? #\0) (char-numeric? #\space) -(defun char-whitespace? (c) (or (<= #\tab c #\return) (= #\space c))) +(define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c))) (char-whitespace? #\a) (char-whitespace? #\B) (char-whitespace? #\0) (char-whitespace? #\space) -(defun char->integer (c) c) -(defun integer->char (c) char-integer) +(define (char->integer c) c) +(define (integer->char c) char-integer) -(defun char-upcase (c) (if (char-lower-case? c) (+ c (- #\A #\a)) c)) +(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) -(defun char-downcase (c) (if (char-upper-case? c) (+ c (- #\a #\A)) c)) +(define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c)) (char-downcase #\a) (char-downcase #\B) @@ -493,17 +639,17 @@ (for-each display '("hello" " " "world" "\n")) -(define -string-ml (lambda (strings) +(define _string-ml (lambda (strings) (if (null? strings) () - (cons (string->list (car strings)) (-string-ml (cdr strings)))))) + (cons (string->list (car strings)) (_string-ml (cdr strings)))))) (define string-map (lexpr (proc strings) - (list->string (apply map proc (-string-ml strings)))))) + (list->string (apply map proc (_string-ml strings)))))) -(string-map 1+ "HAL") +(string-map (lambda (x) (+ 1 x)) "HAL") (define string-for-each (lexpr (proc strings) - (apply for-each proc (-string-ml strings)))) + (apply for-each proc (_string-ml strings)))) (string-for-each write-char "IBM\n") @@ -520,25 +666,64 @@ '(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) - (list - let - (list - (list '__count__ count)) - (append - (list - while - (list - <= - 0 - (list - set! - '__count__ - (list - - - '__count__ - 1)))) - rest)))) + `(let ((__count__ ,count)) + (while (<= 0 (set! __count__ (- __count__ 1))) ,@rest)))) + +(repeat 2 (write 'hello)) +(repeat 3 (write 'goodbye)) + +(define case (macro (test l) + (let ((_unarrow + ; construct the body of the + ; case, dealing with the + ; lambda version ( => lambda) + + (lambda (l) + (cond ((null? l) l) + ((eq? (car l) '=>) `(( ,(cadr l) __key__))) + (else l)))) + (_case (lambda (l) + + ; Build the case elements, which is + ; simply a list of cond clauses + + (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")) ;(define number->string (lexpr (arg opt) ; (let ((base (if (null? opt) 10 (car opt))) diff --git a/src/lisp/ao_lisp_make_builtin b/src/lisp/ao_lisp_make_builtin index 531e388d..c4ba9d94 100644 --- a/src/lisp/ao_lisp_make_builtin +++ b/src/lisp/ao_lisp_make_builtin @@ -13,6 +13,7 @@ string[string] type_map = { "macro" => "MACRO", "f_lambda" => "F_LAMBDA", "f_lexpr" => "F_LEXPR", + "atom" => "atom", }; string[*] @@ -50,13 +51,16 @@ read_builtins(file f) { return builtins; } +bool is_atom(builtin_t b) = b.type == "atom"; + void dump_ids(builtin_t[*] builtins) { printf("#ifdef AO_LISP_BUILTIN_ID\n"); printf("#undef AO_LISP_BUILTIN_ID\n"); printf("enum ao_lisp_builtin_id {\n"); for (int i = 0; i < dim(builtins); i++) - printf("\tbuiltin_%s,\n", builtins[i].c_name); + if (!is_atom(builtins[i])) + printf("\tbuiltin_%s,\n", builtins[i].c_name); printf("\t_builtin_last\n"); printf("};\n"); printf("#endif /* AO_LISP_BUILTIN_ID */\n"); @@ -69,8 +73,9 @@ dump_casename(builtin_t[*] builtins) { printf("static char *ao_lisp_builtin_name(enum ao_lisp_builtin_id b) {\n"); printf("\tswitch(b) {\n"); for (int i = 0; i < dim(builtins); i++) - printf("\tcase builtin_%s: return ao_lisp_poly_atom(_atom(\"%s\"))->name;\n", - builtins[i].c_name, builtins[i].lisp_names[0]); + if (!is_atom(builtins[i])) + printf("\tcase builtin_%s: return ao_lisp_poly_atom(_atom(\"%s\"))->name;\n", + builtins[i].c_name, builtins[i].lisp_names[0]); printf("\tdefault: return \"???\";\n"); printf("\t}\n"); printf("}\n"); @@ -94,10 +99,12 @@ dump_arrayname(builtin_t[*] builtins) { printf("#undef AO_LISP_BUILTIN_ARRAYNAME\n"); printf("static const ao_poly builtin_names[] = {\n"); for (int i = 0; i < dim(builtins); i++) { - printf("\t[builtin_%s] = _ao_lisp_atom_", - builtins[i].c_name); - cify_lisp(builtins[i].lisp_names[0]); - printf(",\n"); + if (!is_atom(builtins[i])) { + printf("\t[builtin_%s] = _ao_lisp_atom_", + builtins[i].c_name); + cify_lisp(builtins[i].lisp_names[0]); + printf(",\n"); + } } printf("};\n"); printf("#endif /* AO_LISP_BUILTIN_ARRAYNAME */\n"); @@ -109,9 +116,10 @@ dump_funcs(builtin_t[*] builtins) { printf("#undef AO_LISP_BUILTIN_FUNCS\n"); printf("const ao_lisp_func_t ao_lisp_builtins[] = {\n"); for (int i = 0; i < dim(builtins); i++) { - printf("\t[builtin_%s] = ao_lisp_do_%s,\n", - builtins[i].c_name, - builtins[i].c_name); + if (!is_atom(builtins[i])) + printf("\t[builtin_%s] = ao_lisp_do_%s,\n", + builtins[i].c_name, + builtins[i].c_name); } printf("};\n"); printf("#endif /* AO_LISP_BUILTIN_FUNCS */\n"); @@ -122,9 +130,11 @@ dump_decls(builtin_t[*] builtins) { printf("#ifdef AO_LISP_BUILTIN_DECLS\n"); printf("#undef AO_LISP_BUILTIN_DECLS\n"); for (int i = 0; i < dim(builtins); i++) { - printf("ao_poly\n"); - printf("ao_lisp_do_%s(struct ao_lisp_cons *cons);\n", - builtins[i].c_name); + if (!is_atom(builtins[i])) { + printf("ao_poly\n"); + printf("ao_lisp_do_%s(struct ao_lisp_cons *cons);\n", + builtins[i].c_name); + } } printf("#endif /* AO_LISP_BUILTIN_DECLS */\n"); } @@ -135,11 +145,13 @@ dump_consts(builtin_t[*] builtins) { printf("#undef AO_LISP_BUILTIN_CONSTS\n"); printf("struct builtin_func funcs[] = {\n"); for (int i = 0; i < dim(builtins); i++) { - for (int j = 0; j < dim(builtins[i].lisp_names); j++) { - printf ("\t{ .name = \"%s\", .args = AO_LISP_FUNC_%s, .func = builtin_%s },\n", - builtins[i].lisp_names[j], - builtins[i].type, - builtins[i].c_name); + if (!is_atom(builtins[i])) { + for (int j = 0; j < dim(builtins[i].lisp_names); j++) { + printf ("\t{ .name = \"%s\", .args = AO_LISP_FUNC_%s, .func = builtin_%s },\n", + builtins[i].lisp_names[j], + builtins[i].type, + builtins[i].c_name); + } } } printf("};\n"); diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index c5a238cc..747963ab 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -61,7 +61,7 @@ static const uint16_t lex_classes[128] = { PRINTABLE|SPECIAL, /* ) */ PRINTABLE, /* * */ PRINTABLE|SIGN, /* + */ - PRINTABLE, /* , */ + PRINTABLE|SPECIAL, /* , */ PRINTABLE|SIGN, /* - */ PRINTABLE|DOTC|FLOATC, /* . */ PRINTABLE, /* / */ @@ -113,7 +113,7 @@ static const uint16_t lex_classes[128] = { PRINTABLE, /* ] */ PRINTABLE, /* ^ */ PRINTABLE, /* _ */ - PRINTABLE, /* ` */ + PRINTABLE|SPECIAL, /* ` */ PRINTABLE, /* a */ PRINTABLE, /* b */ PRINTABLE, /* c */ @@ -314,6 +314,18 @@ _lex(void) return QUOTE; case '.': return DOT; + case '`': + return QUASIQUOTE; + case ',': + c = lexc(); + if (c == '@') { + add_token(c); + end_token(); + return UNQUOTE_SPLICING; + } else { + lex_unget(c); + return UNQUOTE; + } } } if (lex_class & POUND) { @@ -562,11 +574,27 @@ ao_lisp_read(void) v = AO_LISP_NIL; break; case QUOTE: + case QUASIQUOTE: + case UNQUOTE: + case UNQUOTE_SPLICING: if (!push_read_stack(cons, read_state)) return AO_LISP_NIL; cons++; read_state = READ_IN_QUOTE; - v = _ao_lisp_atom_quote; + switch (parse_token) { + case QUOTE: + v = _ao_lisp_atom_quote; + break; + case QUASIQUOTE: + v = _ao_lisp_atom_quasiquote; + break; + case UNQUOTE: + v = _ao_lisp_atom_unquote; + break; + case UNQUOTE_SPLICING: + v = _ao_lisp_atom_unquote2dsplicing; + break; + } break; case CLOSE: if (!cons) { diff --git a/src/lisp/ao_lisp_read.h b/src/lisp/ao_lisp_read.h index 20c9c18a..8f6bf130 100644 --- a/src/lisp/ao_lisp_read.h +++ b/src/lisp/ao_lisp_read.h @@ -19,23 +19,26 @@ * token classes */ -# define END 0 -# define NAME 1 -# define OPEN 2 -# define CLOSE 3 -# define QUOTE 4 -# define STRING 5 -# define NUM 6 -# define FLOAT 7 -# define DOT 8 -# define BOOL 9 +# define END 0 +# define NAME 1 +# define OPEN 2 +# define CLOSE 3 +# define QUOTE 4 +# define QUASIQUOTE 5 +# define UNQUOTE 6 +# define UNQUOTE_SPLICING 7 +# define STRING 8 +# define NUM 9 +# define FLOAT 10 +# define DOT 11 +# define BOOL 12 /* * character classes */ -# define PRINTABLE 0x0001 /* \t \n ' ' - '~' */ -# define SPECIAL 0x0002 /* ( [ { ) ] } ' */ +# define PRINTABLE 0x0001 /* \t \n ' ' - ~ */ +# define SPECIAL 0x0002 /* ( [ { ) ] } ' ` , */ # define DOTC 0x0004 /* . */ # define WHITE 0x0008 /* ' ' \t \n */ # define DIGIT 0x0010 /* [0-9] */ -- cgit v1.2.3 From 796017262cd433af5d143cc7168c944e1e05f4e2 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 1 Dec 2017 11:31:29 +0100 Subject: altos/lisp: Fix pairp builtin Pairs are non-nil cons values; add an explicit check for nil here Signed-off-by: Keith Packard --- src/lisp/ao_lisp_builtin.c | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index 693cc3ca..f13f2180 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -675,7 +675,13 @@ ao_lisp_do_typep(int type, struct ao_lisp_cons *cons) ao_poly ao_lisp_do_pairp(struct ao_lisp_cons *cons) { - return ao_lisp_do_typep(AO_LISP_CONS, cons); + ao_poly v; + if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) + return AO_LISP_NIL; + v = ao_lisp_arg(cons, 0); + if (v != AO_LISP_NIL && ao_lisp_poly_type(v) == AO_LISP_CONS) + return _ao_lisp_bool_true; + return _ao_lisp_bool_false; } ao_poly -- cgit v1.2.3 From 5d0b85f25fa1e5cc816a8256afb38cf9552f6d9d Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 1 Dec 2017 11:32:27 +0100 Subject: altos/lisp: return from unmatched cond is #f, not nil Fix the return value when we fall off the end of a cond expression to be #f Signed-off-by: Keith Packard --- src/lisp/ao_lisp_eval.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 1044aa48..fa25edf0 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -350,7 +350,7 @@ ao_lisp_eval_cond(void) DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); if (!ao_lisp_stack->sexprs) { - ao_lisp_v = AO_LISP_NIL; + ao_lisp_v = _ao_lisp_bool_false; ao_lisp_stack->state = eval_val; } else { ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car; -- cgit v1.2.3 From 835bf4131f9e20575bfdf2179462ebdf54a14761 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 1 Dec 2017 12:06:04 +0100 Subject: altos/lisp: Make let distinct from let* let is supposed to define the values all at once, evaluating the initializers in the enclosing context. let* defines the new names and then initializes them one at a time. Signed-off-by: Keith Packard --- src/lisp/ao_lisp_const.lisp | 183 ++++++++++++++++++++++++++++++-------------- 1 file changed, 124 insertions(+), 59 deletions(-) diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index f1c2ed00..5c1aa75b 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -374,8 +374,9 @@ ; define a set of local - ; variables and then evaluate - ; a list of sexprs + ; variables all at once and + ; then evaluate a list of + ; sexprs ; ; (let (var-defines) sexprs) ; @@ -392,6 +393,71 @@ ; (let ((x 1) (y)) (set! y (+ x 1)) y) (define let (macro (vars exprs) + ((lambda (make-names make-vals) + + ; + ; make the list of names in the let + ; + + (set! make-names (lambda (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 + + (set! make-vals (lambda (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) ((lambda (make-names make-exprs make-nils) ; @@ -446,9 +512,7 @@ ; build the lambda. - (cons (cons 'lambda (cons (make-names vars) exprs)) - (make-nils vars) - ) + `((lambda ,(make-names vars) ,@exprs) ,@(make-nils vars)) ) () () @@ -457,23 +521,15 @@ ) ) -(let ((x 1)) x) +(let* ((x 1)) x) -(define let* let) +(define when (macro (test l) `(cond (,test ,@l)))) -(define when (macro (test l) - (list - cond - (cons test l)))) +(when #t (write 'when)) -(when #t (display 'when)) +(define unless (macro (test l) `(cond ((not ,test) ,@l)))) -(define unless (macro (test l) - (list - cond - (cons (list not test) l)))) - -(unless #f (display 'unless)) +(unless #f (write 'unless)) (define (reverse list) (let ((result ())) @@ -512,30 +568,39 @@ (equal? '(a b c) '(a b c)) (equal? '(a b c) '(a b b)) -(define (_member obj list test?) - (if (null? list) - #f - (if (test? obj (car list)) - list - (memq obj (cdr list))))) +(define member (lexpr (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?)) +(define (memq obj list) (member obj list eq?)) (memq 2 '(1 2 3)) (memq 4 '(1 2 3)) -(define (memv obj list) (_member obj list eqv?)) +(memq '(2) '((1) (2) (3))) + +(define (memv obj list) (member obj list eqv?)) (memv 2 '(1 2 3)) (memv 4 '(1 2 3)) -(define (member obj list) (_member obj list equal?)) - -(member '(2) '((1) (2) (3))) - -(member '(4) '((1) (2) (3))) +(memv '(2) '((1) (2) (3))) (define (_assoc obj list test?) (if (null? list) @@ -618,17 +683,17 @@ (apply cons '(a b)) (define map (lexpr (proc lists) - (let ((args (lambda (lists) - (if (null? lists) () - (cons (caar lists) (args (cdr lists)))))) - (next (lambda (lists) - (if (null? lists) () - (cons (cdr (car lists)) (next (cdr lists)))))) - (domap (lambda (lists) - (if (null? (car lists)) () - (cons (apply proc (args lists)) (domap (next lists))) - ))) - ) + (let* ((args (lambda (lists) + (if (null? lists) () + (cons (caar lists) (args (cdr lists)))))) + (next (lambda (lists) + (if (null? lists) () + (cons (cdr (car lists)) (next (cdr lists)))))) + (domap (lambda (lists) + (if (null? (car lists)) () + (cons (apply proc (args lists)) (domap (next lists))) + ))) + ) (domap lists)))) (map cadr '((a b) (d e) (g h))) @@ -684,36 +749,36 @@ (repeat 3 (write 'goodbye)) (define case (macro (test l) - (let ((_unarrow + (let* ((_unarrow ; construct the body of the ; case, dealing with the ; lambda version ( => lambda) - - (lambda (l) - (cond ((null? l) l) - ((eq? (car l) '=>) `(( ,(cadr l) __key__))) - (else l)))) - (_case (lambda (l) + + (lambda (l) + (cond ((null? l) l) + ((eq? (car l) '=>) `(( ,(cadr l) __key__))) + (else l)))) + (_case (lambda (l) ; Build the case elements, which is ; simply a list of cond clauses - (cond ((null? l) ()) + (cond ((null? l) ()) ; else case - ((eq? (caar l) 'else) - `((else ,@(_unarrow (cdr (car l)))))) + ((eq? (caar l) 'else) + `((else ,@(_unarrow (cdr (car l)))))) ; regular case - (else - (cons - `((eqv? ,(caar l) __key__) - ,@(_unarrow (cdr (car l)))) - (_case (cdr l))) - ) - )))) + (else + (cons + `((eqv? ,(caar l) __key__) + ,@(_unarrow (cdr (car l)))) + (_case (cdr l))) + ) + )))) ; now construct the overall ; expression, using a lambda -- cgit v1.2.3 From 98923ae1189f062b8b94120d47a56892db25493f Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 1 Dec 2017 18:28:16 +0100 Subject: altos/lisp: Split out frame vals from frame struct This lets the frame be resized without moving the base structure. The plan is to allow all frames to be resized, not just the global frame. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 38 ++++++-- src/lisp/ao_lisp_error.c | 5 +- src/lisp/ao_lisp_frame.c | 207 ++++++++++++++++++++++++------------------ src/lisp/ao_lisp_make_const.c | 5 +- src/lisp/ao_lisp_mem.c | 42 +++++++++ src/lisp/ao_lisp_poly.c | 4 + 6 files changed, 200 insertions(+), 101 deletions(-) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 858212dd..96a7a05f 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -92,12 +92,13 @@ extern uint8_t ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA] __attribute__((a #define AO_LISP_ATOM 4 #define AO_LISP_BUILTIN 5 #define AO_LISP_FRAME 6 -#define AO_LISP_LAMBDA 7 -#define AO_LISP_STACK 8 -#define AO_LISP_BOOL 9 -#define AO_LISP_BIGINT 10 -#define AO_LISP_FLOAT 11 -#define AO_LISP_NUM_TYPE 12 +#define AO_LISP_FRAME_VALS 7 +#define AO_LISP_LAMBDA 8 +#define AO_LISP_STACK 9 +#define AO_LISP_BOOL 10 +#define AO_LISP_BIGINT 11 +#define AO_LISP_FLOAT 12 +#define AO_LISP_NUM_TYPE 13 /* Leave two bits for types to use as they please */ #define AO_LISP_OTHER_TYPE_MASK 0x3f @@ -154,11 +155,17 @@ struct ao_lisp_val { ao_poly val; }; +struct ao_lisp_frame_vals { + uint8_t type; + uint8_t size; + struct ao_lisp_val vals[]; +}; + struct ao_lisp_frame { uint8_t type; uint8_t num; ao_poly prev; - struct ao_lisp_val vals[]; + ao_poly vals; }; struct ao_lisp_bool { @@ -221,6 +228,16 @@ ao_lisp_frame_poly(struct ao_lisp_frame *frame) { return ao_lisp_poly(frame, AO_LISP_OTHER); } +static inline struct ao_lisp_frame_vals * +ao_lisp_poly_frame_vals(ao_poly poly) { + return ao_lisp_ref(poly); +} + +static inline ao_poly +ao_lisp_frame_vals_poly(struct ao_lisp_frame_vals *vals) { + return ao_lisp_poly(vals, AO_LISP_OTHER); +} + enum eval_state { eval_sexpr, /* Evaluate an sexpr */ eval_val, /* Value computed */ @@ -528,6 +545,12 @@ ao_lisp_stack_fetch(int id) { return ao_lisp_poly_stack(ao_lisp_poly_fetch(id)); } +void +ao_lisp_frame_stash(int id, struct ao_lisp_frame *frame); + +struct ao_lisp_frame * +ao_lisp_frame_fetch(int id); + /* bool */ extern const struct ao_lisp_type ao_lisp_bool_type; @@ -713,6 +736,7 @@ ao_lisp_read_eval_print(void); /* frame */ extern const struct ao_lisp_type ao_lisp_frame_type; +extern const struct ao_lisp_type ao_lisp_frame_vals_type; #define AO_LISP_FRAME_FREE 6 diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c index d1c9b941..ba135834 100644 --- a/src/lisp/ao_lisp_error.c +++ b/src/lisp/ao_lisp_error.c @@ -57,6 +57,7 @@ ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) tabs(indent); printf ("%s{", name); if (frame) { + struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); if (frame->type & AO_LISP_FRAME_PRINT) printf("recurse..."); else { @@ -66,9 +67,9 @@ ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) tabs(indent); printf(" "); } - ao_lisp_poly_write(frame->vals[f].atom); + ao_lisp_poly_write(vals->vals[f].atom); printf(" = "); - ao_lisp_poly_write(frame->vals[f].val); + ao_lisp_poly_write(vals->vals[f].val); printf("\n"); } if (frame->prev) diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index ebdb7757..dd29e079 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -15,37 +15,77 @@ #include "ao_lisp.h" static inline int -frame_num_size(int num) +frame_vals_num_size(int num) { - return sizeof (struct ao_lisp_frame) + num * sizeof (struct ao_lisp_val); + return sizeof (struct ao_lisp_frame_vals) + num * sizeof (struct ao_lisp_val); } +static int +frame_vals_size(void *addr) +{ + struct ao_lisp_frame_vals *vals = addr; + return frame_vals_num_size(vals->size); +} + +static void +frame_vals_mark(void *addr) +{ + struct ao_lisp_frame_vals *vals = addr; + int f; + + for (f = 0; f < vals->size; f++) { + struct ao_lisp_val *v = &vals->vals[f]; + + ao_lisp_poly_mark(v->val, 0); + MDBG_MOVE("frame mark atom %s %d val %d at %d\n", + ao_lisp_poly_atom(v->atom)->name, + MDBG_OFFSET(ao_lisp_ref(v->atom)), + MDBG_OFFSET(ao_lisp_ref(v->val)), f); + } +} + +static void +frame_vals_move(void *addr) +{ + struct ao_lisp_frame_vals *vals = addr; + int f; + + for (f = 0; f < vals->size; f++) { + struct ao_lisp_val *v = &vals->vals[f]; + + ao_lisp_poly_move(&v->atom, 0); + ao_lisp_poly_move(&v->val, 0); + MDBG_MOVE("frame move atom %s %d val %d at %d\n", + ao_lisp_poly_atom(v->atom)->name, + MDBG_OFFSET(ao_lisp_ref(v->atom)), + MDBG_OFFSET(ao_lisp_ref(v->val)), f); + } +} + +const struct ao_lisp_type ao_lisp_frame_vals_type = { + .mark = frame_vals_mark, + .size = frame_vals_size, + .move = frame_vals_move, + .name = "frame_vals" +}; + static int frame_size(void *addr) { - struct ao_lisp_frame *frame = addr; - return frame_num_size(frame->num); + (void) addr; + return sizeof (struct ao_lisp_frame); } static void frame_mark(void *addr) { struct ao_lisp_frame *frame = addr; - int f; for (;;) { MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); if (!AO_LISP_IS_POOL(frame)) break; - for (f = 0; f < frame->num; f++) { - struct ao_lisp_val *v = &frame->vals[f]; - - ao_lisp_poly_mark(v->val, 0); - MDBG_MOVE("frame mark atom %s %d val %d at %d\n", - ao_lisp_poly_atom(v->atom)->name, - MDBG_OFFSET(ao_lisp_ref(v->atom)), - MDBG_OFFSET(ao_lisp_ref(v->val)), f); - } + ao_lisp_poly_mark(frame->vals, 0); frame = ao_lisp_poly_frame(frame->prev); MDBG_MOVE("frame next %d\n", MDBG_OFFSET(frame)); if (!frame) @@ -59,7 +99,6 @@ static void frame_move(void *addr) { struct ao_lisp_frame *frame = addr; - int f; for (;;) { struct ao_lisp_frame *prev; @@ -68,16 +107,7 @@ frame_move(void *addr) MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); if (!AO_LISP_IS_POOL(frame)) break; - for (f = 0; f < frame->num; f++) { - struct ao_lisp_val *v = &frame->vals[f]; - - ao_lisp_poly_move(&v->atom, 0); - ao_lisp_poly_move(&v->val, 0); - MDBG_MOVE("frame move atom %s %d val %d at %d\n", - ao_lisp_poly_atom(v->atom)->name, - MDBG_OFFSET(ao_lisp_ref(v->atom)), - MDBG_OFFSET(ao_lisp_ref(v->val)), f); - } + ao_lisp_poly_move(&frame->vals, 0); prev = ao_lisp_poly_frame(frame->prev); if (!prev) break; @@ -104,8 +134,9 @@ const struct ao_lisp_type ao_lisp_frame_type = { void ao_lisp_frame_write(ao_poly p) { - struct ao_lisp_frame *frame = ao_lisp_poly_frame(p); - int f; + struct ao_lisp_frame *frame = ao_lisp_poly_frame(p); + struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); + int f; printf ("{"); if (frame) { @@ -116,9 +147,9 @@ ao_lisp_frame_write(ao_poly p) for (f = 0; f < frame->num; f++) { if (f != 0) printf(", "); - ao_lisp_poly_write(frame->vals[f].atom); + ao_lisp_poly_write(vals->vals[f].atom); printf(" = "); - ao_lisp_poly_write(frame->vals[f].val); + ao_lisp_poly_write(vals->vals[f].val); } if (frame->prev) ao_lisp_poly_write(frame->prev); @@ -131,11 +162,13 @@ ao_lisp_frame_write(ao_poly p) static int ao_lisp_frame_find(struct ao_lisp_frame *frame, int top, ao_poly atom) { - int l = 0; - int r = top - 1; + struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); + int l = 0; + int r = top - 1; + while (l <= r) { int m = (l + r) >> 1; - if (frame->vals[m].atom < atom) + if (vals->vals[m].atom < atom) l = m + 1; else r = m - 1; @@ -146,62 +179,57 @@ ao_lisp_frame_find(struct ao_lisp_frame *frame, int top, ao_poly atom) ao_poly * ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom) { - int l = ao_lisp_frame_find(frame, frame->num, atom); + struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); + int l = ao_lisp_frame_find(frame, frame->num, atom); if (l >= frame->num) return NULL; - if (frame->vals[l].atom != atom) + if (vals->vals[l].atom != atom) return NULL; - return &frame->vals[l].val; + return &vals->vals[l].val; } -int -ao_lisp_frame_set(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val) -{ - while (frame) { - if (!AO_LISP_IS_CONST(frame)) { - ao_poly *ref = ao_lisp_frame_ref(frame, atom); - if (ref) { - *ref = val; - return 1; - } - } - frame = ao_lisp_poly_frame(frame->prev); - } - return 0; -} +struct ao_lisp_frame *ao_lisp_frame_free_list[AO_LISP_FRAME_FREE]; -ao_poly -ao_lisp_frame_get(struct ao_lisp_frame *frame, ao_poly atom) +static struct ao_lisp_frame_vals * +ao_lisp_frame_vals_new(int num) { - while (frame) { - ao_poly *ref = ao_lisp_frame_ref(frame, atom); - if (ref) - return *ref; - frame = ao_lisp_poly_frame(frame->prev); - } - return AO_LISP_NIL; -} + struct ao_lisp_frame_vals *vals; -struct ao_lisp_frame *ao_lisp_frame_free_list[AO_LISP_FRAME_FREE]; + vals = ao_lisp_alloc(frame_vals_num_size(num)); + if (!vals) + return NULL; + vals->type = AO_LISP_FRAME_VALS; + vals->size = num; + return vals; +} struct ao_lisp_frame * ao_lisp_frame_new(int num) { - struct ao_lisp_frame *frame; + struct ao_lisp_frame *frame; + struct ao_lisp_frame_vals *vals; - if (num < AO_LISP_FRAME_FREE && (frame = ao_lisp_frame_free_list[num])) + if (num < AO_LISP_FRAME_FREE && (frame = ao_lisp_frame_free_list[num])) { ao_lisp_frame_free_list[num] = ao_lisp_poly_frame(frame->prev); - else { - frame = ao_lisp_alloc(frame_num_size(num)); + vals = ao_lisp_poly_frame_vals(frame->vals); + } else { + frame = ao_lisp_alloc(sizeof (struct ao_lisp_frame)); if (!frame) return NULL; + frame->type = AO_LISP_FRAME; + frame->num = 0; + frame->prev = AO_LISP_NIL; + frame->vals = AO_LISP_NIL; + ao_lisp_poly_stash(0, ao_lisp_frame_poly(frame)); + vals = ao_lisp_frame_vals_new(num); + frame = ao_lisp_poly_frame(ao_lisp_poly_fetch(0)); + frame->vals = ao_lisp_frame_vals_poly(vals); } - frame->type = AO_LISP_FRAME; frame->num = num; frame->prev = AO_LISP_NIL; - memset(frame->vals, '\0', num * sizeof (struct ao_lisp_val)); + memset(vals, '\0', vals->size * sizeof (struct ao_lisp_val)); return frame; } @@ -227,47 +255,46 @@ ao_lisp_frame_free(struct ao_lisp_frame *frame) } static struct ao_lisp_frame * -ao_lisp_frame_realloc(struct ao_lisp_frame **frame_ref, int new_num) +ao_lisp_frame_realloc(struct ao_lisp_frame *frame, int new_num) { - struct ao_lisp_frame *frame = *frame_ref; - struct ao_lisp_frame *new; - int copy; + struct ao_lisp_frame_vals *vals; + struct ao_lisp_frame_vals *new_vals; + int copy; if (new_num == frame->num) return frame; - new = ao_lisp_frame_new(new_num); - if (!new) + ao_lisp_frame_stash(0, frame); + new_vals = ao_lisp_frame_vals_new(new_num); + if (!new_vals) return NULL; - /* - * Re-fetch the frame as it may have moved - * during the allocation - */ - frame = *frame_ref; + frame = ao_lisp_frame_fetch(0); + vals = ao_lisp_poly_frame_vals(frame->vals); copy = new_num; if (copy > frame->num) copy = frame->num; - memcpy(new->vals, frame->vals, copy * sizeof (struct ao_lisp_val)); - new->prev = frame->prev; - ao_lisp_frame_free(frame); - return new; + memcpy(new_vals->vals, vals->vals, copy * sizeof (struct ao_lisp_val)); + frame->vals = ao_lisp_frame_vals_poly(new_vals); + frame->num = new_num; + return frame; } void ao_lisp_frame_bind(struct ao_lisp_frame *frame, int num, ao_poly atom, ao_poly val) { - int l = ao_lisp_frame_find(frame, num, atom); + struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); + int l = ao_lisp_frame_find(frame, num, atom); - memmove(&frame->vals[l+1], - &frame->vals[l], + memmove(&vals->vals[l+1], + &vals->vals[l], (num - l) * sizeof (struct ao_lisp_val)); - frame->vals[l].atom = atom; - frame->vals[l].val = val; + vals->vals[l].atom = atom; + vals->vals[l].val = val; } int ao_lisp_frame_add(struct ao_lisp_frame **frame_ref, ao_poly atom, ao_poly val) { - struct ao_lisp_frame *frame = *frame_ref; + struct ao_lisp_frame *frame = *frame_ref; ao_poly *ref = frame ? ao_lisp_frame_ref(frame, atom) : NULL; if (!ref) { @@ -276,14 +303,14 @@ ao_lisp_frame_add(struct ao_lisp_frame **frame_ref, ao_poly atom, ao_poly val) ao_lisp_poly_stash(1, val); if (frame) { f = frame->num; - frame = ao_lisp_frame_realloc(frame_ref, f + 1); + frame = ao_lisp_frame_realloc(frame, f + 1); } else { f = 0; frame = ao_lisp_frame_new(1); + *frame_ref = frame; } if (!frame) return 0; - *frame_ref = frame; atom = ao_lisp_poly_fetch(0); val = ao_lisp_poly_fetch(1); ao_lisp_frame_bind(frame, frame->num - 1, atom, val); diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index f23d34db..f9bb5452 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -326,10 +326,11 @@ main(int argc, char **argv) ao_lisp_collect(AO_LISP_COLLECT_FULL); for (f = 0; f < ao_lisp_frame_global->num; f++) { - val = ao_has_macro(ao_lisp_frame_global->vals[f].val); + struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(ao_lisp_frame_global->vals); + val = ao_has_macro(vals->vals[f].val); if (val != AO_LISP_NIL) { printf("error: function %s contains unresolved macro: ", - ao_lisp_poly_atom(ao_lisp_frame_global->vals[f].atom)->name); + ao_lisp_poly_atom(vals->vals[f].atom)->name); ao_lisp_poly_write(val); printf("\n"); exit(1); diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index dc0008c4..890eba1b 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -148,6 +148,7 @@ struct ao_lisp_root { static struct ao_lisp_cons *save_cons[2]; static char *save_string[2]; +static struct ao_lisp_frame *save_frame[1]; static ao_poly save_poly[3]; static const struct ao_lisp_root ao_lisp_root[] = { @@ -167,6 +168,10 @@ static const struct ao_lisp_root ao_lisp_root[] = { .type = &ao_lisp_string_type, .addr = (void **) &save_string[1], }, + { + .type = &ao_lisp_frame_type, + .addr = (void **) &save_frame[0], + }, { .type = NULL, .addr = (void **) (void *) &save_poly[0] @@ -455,6 +460,7 @@ static const struct ao_lisp_type *ao_lisp_types[AO_LISP_NUM_TYPE] = { [AO_LISP_ATOM] = &ao_lisp_atom_type, [AO_LISP_BUILTIN] = &ao_lisp_builtin_type, [AO_LISP_FRAME] = &ao_lisp_frame_type, + [AO_LISP_FRAME_VALS] = &ao_lisp_frame_vals_type, [AO_LISP_LAMBDA] = &ao_lisp_lambda_type, [AO_LISP_STACK] = &ao_lisp_stack_type, [AO_LISP_BOOL] = &ao_lisp_bool_type, @@ -620,6 +626,29 @@ ao_lisp_collect(uint8_t style) * Mark interfaces for objects */ + +/* + * Mark a block of memory with an explicit size + */ + +int +ao_lisp_mark_block(void *addr, int size) +{ + int offset; + if (!AO_LISP_IS_POOL(addr)) + return 1; + + offset = pool_offset(addr); + MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); + if (busy(ao_lisp_busy, offset)) { + MDBG_MOVE("already marked\n"); + return 1; + } + mark(ao_lisp_busy, offset); + note_chunk(offset, size); + return 0; +} + /* * Note a reference to memory and collect information about a few * object sizes at a time @@ -891,3 +920,16 @@ ao_lisp_string_fetch(int id) return string; } +void +ao_lisp_frame_stash(int id, struct ao_lisp_frame *frame) +{ + save_frame[id] = frame; +} + +struct ao_lisp_frame * +ao_lisp_frame_fetch(int id) +{ + struct ao_lisp_frame *frame = save_frame[id]; + save_frame[id] = NULL; + return frame; +} diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c index e93e1192..d14f4151 100644 --- a/src/lisp/ao_lisp_poly.c +++ b/src/lisp/ao_lisp_poly.c @@ -44,6 +44,10 @@ static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { .write = ao_lisp_frame_write, .display = ao_lisp_frame_write, }, + [AO_LISP_FRAME_VALS] = { + .write = NULL, + .display = NULL, + }, [AO_LISP_LAMBDA] = { .write = ao_lisp_lambda_write, .display = ao_lisp_lambda_write, -- cgit v1.2.3 From c31744299e5a4342bbe26d3735ee2d8f09192ae9 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Fri, 1 Dec 2017 15:40:23 -0600 Subject: altos/lisp: split set/def. Add def support to lambdas In scheme, set can only re-define existing variables while def cannot redefine existing variables in lambda context. Def within lambda creates a new variable at the nearest enclosing scope. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 19 +- src/lisp/ao_lisp_atom.c | 54 +++-- src/lisp/ao_lisp_builtin.c | 13 +- src/lisp/ao_lisp_builtin.txt | 1 + src/lisp/ao_lisp_const.lisp | 487 ++++++++++++++++++++---------------------- src/lisp/ao_lisp_eval.c | 2 + src/lisp/ao_lisp_frame.c | 43 ++-- src/lisp/ao_lisp_make_const.c | 8 +- src/lisp/ao_lisp_mem.c | 2 + src/lisp/ao_lisp_stack.c | 4 +- src/test/ao_lisp_os.h | 2 +- src/test/hanoi.lisp | 152 ++++++------- 12 files changed, 395 insertions(+), 392 deletions(-) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 96a7a05f..1f3fb2b4 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -111,8 +111,9 @@ extern uint16_t ao_lisp_top; #define AO_LISP_DIVIDE_BY_ZERO 0x02 #define AO_LISP_INVALID 0x04 #define AO_LISP_UNDEFINED 0x08 -#define AO_LISP_EOF 0x10 -#define AO_LISP_EXIT 0x20 +#define AO_LISP_REDEFINED 0x10 +#define AO_LISP_EOF 0x20 +#define AO_LISP_EXIT 0x40 extern uint8_t ao_lisp_exception; @@ -627,7 +628,7 @@ struct ao_lisp_atom * ao_lisp_atom_intern(char *name); ao_poly * -ao_lisp_atom_ref(struct ao_lisp_frame *frame, ao_poly atom); +ao_lisp_atom_ref(ao_poly atom); ao_poly ao_lisp_atom_get(ao_poly atom); @@ -635,6 +636,9 @@ ao_lisp_atom_get(ao_poly atom); ao_poly ao_lisp_atom_set(ao_poly atom, ao_poly val); +ao_poly +ao_lisp_atom_def(ao_poly atom, ao_poly val); + /* int */ void ao_lisp_int_write(ao_poly i); @@ -757,12 +761,15 @@ ao_lisp_frame_free(struct ao_lisp_frame *frame); void ao_lisp_frame_bind(struct ao_lisp_frame *frame, int num, ao_poly atom, ao_poly val); -int -ao_lisp_frame_add(struct ao_lisp_frame **frame, ao_poly atom, ao_poly val); +ao_poly +ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val); void ao_lisp_frame_write(ao_poly p); +void +ao_lisp_frame_init(void); + /* lambda */ extern const struct ao_lisp_type ao_lisp_lambda_type; @@ -864,7 +871,7 @@ ao_lisp_frames_dump(void) #include extern int dbg_move_depth; #define MDBG_DUMP 1 -#define MDBG_OFFSET(a) ((int) ((uint8_t *) (a) - ao_lisp_pool)) +#define MDBG_OFFSET(a) ((a) ? (int) ((uint8_t *) (a) - ao_lisp_pool) : -1) extern int dbg_mem; diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c index ede13567..a633c223 100644 --- a/src/lisp/ao_lisp_atom.c +++ b/src/lisp/ao_lisp_atom.c @@ -98,42 +98,25 @@ ao_lisp_atom_intern(char *name) return atom; } -struct ao_lisp_frame *ao_lisp_frame_global; -struct ao_lisp_frame *ao_lisp_frame_current; - -static void -ao_lisp_atom_init(void) -{ - if (!ao_lisp_frame_global) - ao_lisp_frame_global = ao_lisp_frame_new(0); -} - ao_poly * -ao_lisp_atom_ref(struct ao_lisp_frame *frame, ao_poly atom) +ao_lisp_atom_ref(ao_poly atom) { ao_poly *ref; - ao_lisp_atom_init(); - while (frame) { + struct ao_lisp_frame *frame; + + for (frame = ao_lisp_frame_current; frame; frame = ao_lisp_poly_frame(frame->prev)) { ref = ao_lisp_frame_ref(frame, atom); if (ref) return ref; - frame = ao_lisp_poly_frame(frame->prev); } - if (ao_lisp_frame_global) { - ref = ao_lisp_frame_ref(ao_lisp_frame_global, atom); - if (ref) - return ref; - } - return NULL; + return ao_lisp_frame_ref(ao_lisp_frame_global, atom); } ao_poly ao_lisp_atom_get(ao_poly atom) { - ao_poly *ref = ao_lisp_atom_ref(ao_lisp_frame_current, atom); + ao_poly *ref = ao_lisp_atom_ref(atom); - if (!ref && ao_lisp_frame_global) - ref = ao_lisp_frame_ref(ao_lisp_frame_global, atom); #ifdef ao_builtin_frame if (!ref) ref = ao_lisp_frame_ref(ao_lisp_poly_frame(ao_builtin_frame), atom); @@ -146,17 +129,28 @@ ao_lisp_atom_get(ao_poly atom) ao_poly ao_lisp_atom_set(ao_poly atom, ao_poly val) { - ao_poly *ref = ao_lisp_atom_ref(ao_lisp_frame_current, atom); + ao_poly *ref = ao_lisp_atom_ref(atom); - if (!ref && ao_lisp_frame_global) - ref = ao_lisp_frame_ref(ao_lisp_frame_global, atom); - if (ref) - *ref = val; - else - ao_lisp_frame_add(&ao_lisp_frame_global, atom, val); + if (!ref) + return ao_lisp_error(AO_LISP_UNDEFINED, "undefined atom %s", ao_lisp_poly_atom(atom)->name); + *ref = val; return val; } +ao_poly +ao_lisp_atom_def(ao_poly atom, ao_poly val) +{ + ao_poly *ref = ao_lisp_atom_ref(atom); + + if (ref) { + if (ao_lisp_frame_current) + return ao_lisp_error(AO_LISP_REDEFINED, "attempt to redefine atom %s", ao_lisp_poly_atom(atom)->name); + *ref = val; + return val; + } + return ao_lisp_frame_add(ao_lisp_frame_current ? ao_lisp_frame_current : ao_lisp_frame_global, atom, val); +} + void ao_lisp_atom_write(ao_poly a) { diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index f13f2180..d4751ac2 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -207,6 +207,17 @@ ao_lisp_do_set(struct ao_lisp_cons *cons) return ao_lisp_atom_set(ao_lisp_arg(cons, 0), ao_lisp_arg(cons, 1)); } +ao_poly +ao_lisp_do_def(struct ao_lisp_cons *cons) +{ + if (!ao_lisp_check_argc(_ao_lisp_atom_def, cons, 2, 2)) + return AO_LISP_NIL; + if (!ao_lisp_check_argt(_ao_lisp_atom_def, cons, 0, AO_LISP_ATOM, 0)) + return AO_LISP_NIL; + + return ao_lisp_atom_def(ao_lisp_arg(cons, 0), ao_lisp_arg(cons, 1)); +} + ao_poly ao_lisp_do_setq(struct ao_lisp_cons *cons) { @@ -216,7 +227,7 @@ ao_lisp_do_setq(struct ao_lisp_cons *cons) name = cons->car; if (ao_lisp_poly_type(name) != AO_LISP_ATOM) return ao_lisp_error(AO_LISP_INVALID, "set! of non-atom"); - if (!ao_lisp_atom_ref(ao_lisp_frame_current, name)) + if (!ao_lisp_atom_ref(name)) return ao_lisp_error(AO_LISP_INVALID, "atom not defined"); return ao_lisp__cons(_ao_lisp_atom_set, ao_lisp__cons(ao_lisp__cons(_ao_lisp_atom_quote, diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt index 6925ac17..abed7afe 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/lisp/ao_lisp_builtin.txt @@ -15,6 +15,7 @@ atom unquote atom unquote_splicing unquote-splicing f_lambda set macro setq set! +f_lambda def nlambda cond nlambda begin nlambda while diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 5c1aa75b..436da3dc 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -14,187 +14,185 @@ ; Lisp code placed in ROM ; return a list containing all of the arguments -(set (quote list) (lexpr (l) l)) +(def (quote list) (lexpr (l) l)) -(set (quote set!) +(def (quote def!) (macro (name value rest) (list - set - (list - quote - name) + def + (list quote name) value) ) ) -(set! append - (lexpr (args) - ((lambda (append-list append-lists) - (set! append-list - (lambda (a b) - (cond ((null? a) b) - (else (cons (car a) (append-list (cdr a) b))) - ) - ) - ) - (set! 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) - ) () ()) - ) - ) +(begin + (def! append + (lexpr (args) + ((lambda (append-list append-lists) + (set! append-list + (lambda (a b) + (cond ((null? a) b) + (else (cons (car a) (append-list (cdr a) b))) + ) + ) + ) + (set! 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 -(set! or - (macro (l) - ((lambda (_or) - (set! _or - (lambda (l) - (cond ((null? l) #f) - ((null? (cdr l)) - (car l)) - (else - (list - cond - (list - (car l)) - (list - 'else - (_or (cdr l)) - ) - ) - ) - ) +(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 l))) + 'or) ; execute to resolve macros (or #f #t) - -(set! and - (macro (l) - ((lambda (_and) - (set! _and - (lambda (l) - (cond ((null? l) #t) - ((null? (cdr l)) - (car l)) - (else - (list - cond - (list - (car l) - (_and (cdr l)) - ) - ) - ) - ) +(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 l))) + 'and) ; execute to resolve macros (and #t #f) -(set! quasiquote - (macro (x rest) - ((lambda (constant? combine-skeletons expand-quasiquote) - (set! constant? +(begin + (def! quasiquote + (macro (x rest) + (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)) - ) - ) - ) - ) - (set! 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))) + (lambda (exp) + (cond ((pair? exp) + (eq? (car exp) 'quote) ) (else - (list 'cons left right) + (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) + ) + ) + ) + ) - (set! expand-quasiquote - (lambda (exp nesting) - (cond + (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) - ) - ) - ) + ((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)) - ) - ) + ((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)) + ((and (eq? (car exp) 'quasiquote) (= (length exp) 2)) + (combine-skeletons ''quasiquote + (expand-quasiquote (cdr exp) (+ nesting 1)) + exp)) ; check for an ; unquote-splicing member, @@ -202,36 +200,36 @@ ; 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)) - ) - ) + ((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) - ) - ) - ) - ) - (expand-quasiquote x 0) - ) () () ()) - ) - ) + (else (combine-skeletons (expand-quasiquote (car exp) nesting) + (expand-quasiquote (cdr exp) nesting) + exp) + ) + ) + ) + ) + (expand-quasiquote x 0) + ) + ) + 'quasiquote) ; ; Define a variable without returning the value ; Useful when defining functions to avoid @@ -242,9 +240,8 @@ ; (define (name x y z) sexprs ...) ; -(set! define +(def! define (macro (first rest) - ; check for alternate lambda definition form (cond ((list? first) @@ -261,14 +258,13 @@ ) ) `(begin - (set! ,first ,rest) + (def (quote ,first) ,rest) (quote ,first)) ) ) ; basic list accessors - (define (caar l) (car (car l))) (define (cadr l) (car (cdr l))) @@ -392,47 +388,36 @@ ; ; (let ((x 1) (y)) (set! y (+ x 1)) y) -(define let (macro (vars exprs) - ((lambda (make-names make-vals) - - ; - ; make the list of names in the let - ; - - (set! make-names (lambda (vars) - (cond ((not (null? vars)) - (cons (car (car vars)) - (make-names (cdr vars)))) - (else ()) - ) - ) - ) +(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 - (set! make-vals (lambda (vars) - (cond ((not (null? vars)) - (cons (cond ((null? (cdr (car vars))) ()) - (else - (car (cdr (car vars)))) - ) - (make-vals (cdr vars)))) - (else ()) - ) - ) - ) + (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)) - ) - () - () - ) - ) + `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars)) + ) ) @@ -457,71 +442,58 @@ ; ; (let* ((x 1) (y)) (set! y (+ x 1)) y) -(define let* (macro (vars exprs) - ((lambda (make-names make-exprs make-nils) +(define let* + (macro (vars exprs) ; ; make the list of names in the let ; - (set! make-names (lambda (vars) - (cond ((not (null? vars)) - (cons (car (car vars)) - (make-names (cdr vars)))) - (else ()) - ) - ) - ) + (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 - (set! make-exprs (lambda (vars exprs) - (cond ((not (null? vars)) - (cons - (list set - (list quote - (car (car vars)) - ) - (cond ((null? (cdr (car vars))) ()) - (else (cadr (car vars)))) - ) - (make-exprs (cdr vars) exprs) - ) - ) - (else exprs) - ) - ) + (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 - (set! make-nils (lambda (vars) - (cond ((not (null? vars)) (cons () (make-nils (cdr vars)))) - (else ()) - ) - ) - ) - ; prepend the set operations - ; to the expressions - - (set! exprs (make-exprs vars exprs)) - + (define (make-nils vars) + (cond ((null? vars) ()) + (else (cons () (make-nils (cdr vars)))) + ) + ) ; build the lambda. - `((lambda ,(make-names vars) ,@exprs) ,@(make-nils vars)) - ) - () - () - () - ) - ) + `((lambda ,(make-names vars) ,@(make-exprs vars exprs)) ,@(make-nils vars)) + ) ) -(let* ((x 1)) x) +(let* ((x 1) (y x)) (+ x y)) (define when (macro (test l) `(cond (,test ,@l)))) @@ -545,7 +517,7 @@ (define (list-tail x k) (if (zero? k) x - (list-tail (cdr x) (- k 1))))) + (list-tail (cdr x) (- k 1)))) (list-tail '(1 2 3) 2) @@ -682,19 +654,32 @@ (display "apply\n") (apply cons '(a b)) -(define map (lexpr (proc lists) - (let* ((args (lambda (lists) - (if (null? lists) () - (cons (caar lists) (args (cdr lists)))))) - (next (lambda (lists) - (if (null? lists) () - (cons (cdr (car lists)) (next (cdr lists)))))) - (domap (lambda (lists) - (if (null? (car lists)) () - (cons (apply proc (args lists)) (domap (next lists))) - ))) - ) - (domap lists)))) +(define map + (lexpr (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))) diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index fa25edf0..02329ee6 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -559,6 +559,8 @@ ao_lisp_eval(ao_poly _v) { ao_lisp_v = _v; + ao_lisp_frame_init(); + if (!ao_lisp_stack_push()) return AO_LISP_NIL; diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index dd29e079..13a68b38 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -37,10 +37,12 @@ frame_vals_mark(void *addr) struct ao_lisp_val *v = &vals->vals[f]; ao_lisp_poly_mark(v->val, 0); - MDBG_MOVE("frame mark atom %s %d val %d at %d\n", + MDBG_MOVE("frame mark atom %s %d val %d at %d ", ao_lisp_poly_atom(v->atom)->name, MDBG_OFFSET(ao_lisp_ref(v->atom)), MDBG_OFFSET(ao_lisp_ref(v->val)), f); + MDBG_DO(ao_lisp_poly_write(v->val)); + MDBG_DO(printf("\n")); } } @@ -202,6 +204,7 @@ ao_lisp_frame_vals_new(int num) return NULL; vals->type = AO_LISP_FRAME_VALS; vals->size = num; + memset(vals->vals, '\0', num * sizeof (struct ao_lisp_val)); return vals; } @@ -226,10 +229,9 @@ ao_lisp_frame_new(int num) vals = ao_lisp_frame_vals_new(num); frame = ao_lisp_poly_frame(ao_lisp_poly_fetch(0)); frame->vals = ao_lisp_frame_vals_poly(vals); + frame->num = num; } - frame->num = num; frame->prev = AO_LISP_NIL; - memset(vals, '\0', vals->size * sizeof (struct ao_lisp_val)); return frame; } @@ -245,9 +247,13 @@ ao_lisp_frame_mark(struct ao_lisp_frame *frame) void ao_lisp_frame_free(struct ao_lisp_frame *frame) { - if (!ao_lisp_frame_marked(frame)) { + if (frame && !ao_lisp_frame_marked(frame)) { int num = frame->num; if (num < AO_LISP_FRAME_FREE) { + struct ao_lisp_frame_vals *vals; + + vals = ao_lisp_poly_frame_vals(frame->vals); + memset(vals->vals, '\0', vals->size * sizeof (struct ao_lisp_val)); frame->prev = ao_lisp_frame_poly(ao_lisp_frame_free_list[num]); ao_lisp_frame_free_list[num] = frame; } @@ -291,30 +297,33 @@ ao_lisp_frame_bind(struct ao_lisp_frame *frame, int num, ao_poly atom, ao_poly v vals->vals[l].val = val; } -int -ao_lisp_frame_add(struct ao_lisp_frame **frame_ref, ao_poly atom, ao_poly val) +ao_poly +ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val) { - struct ao_lisp_frame *frame = *frame_ref; ao_poly *ref = frame ? ao_lisp_frame_ref(frame, atom) : NULL; if (!ref) { int f; ao_lisp_poly_stash(0, atom); ao_lisp_poly_stash(1, val); - if (frame) { - f = frame->num; - frame = ao_lisp_frame_realloc(frame, f + 1); - } else { - f = 0; - frame = ao_lisp_frame_new(1); - *frame_ref = frame; - } + f = frame->num; + frame = ao_lisp_frame_realloc(frame, f + 1); if (!frame) - return 0; + return AO_LISP_NIL; atom = ao_lisp_poly_fetch(0); val = ao_lisp_poly_fetch(1); ao_lisp_frame_bind(frame, frame->num - 1, atom, val); } else *ref = val; - return 1; + return val; +} + +struct ao_lisp_frame *ao_lisp_frame_global; +struct ao_lisp_frame *ao_lisp_frame_current; + +void +ao_lisp_frame_init(void) +{ + if (!ao_lisp_frame_global) + ao_lisp_frame_global = ao_lisp_frame_new(0); } diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index f9bb5452..f3ea6be0 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -133,7 +133,7 @@ ao_has_macro(ao_poly p); ao_poly ao_macro_test_get(ao_poly atom) { - ao_poly *ref = ao_lisp_atom_ref(ao_lisp_frame_global, atom); + ao_poly *ref = ao_lisp_atom_ref(atom); if (ref) return *ref; return AO_LISP_NIL; @@ -289,6 +289,8 @@ main(int argc, char **argv) } } + ao_lisp_frame_init(); + /* Boolean values #f and #t */ ao_lisp_bool_get(0); ao_lisp_bool_get(1); @@ -298,13 +300,13 @@ main(int argc, char **argv) if (funcs[f].func != prev_func) b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); a = ao_lisp_atom_intern(funcs[f].name); - ao_lisp_atom_set(ao_lisp_atom_poly(a), + ao_lisp_atom_def(ao_lisp_atom_poly(a), ao_lisp_builtin_poly(b)); } /* end of file value */ a = ao_lisp_atom_intern("eof"); - ao_lisp_atom_set(ao_lisp_atom_poly(a), + ao_lisp_atom_def(ao_lisp_atom_poly(a), ao_lisp_atom_poly(a)); /* 'else' */ diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 890eba1b..3a704380 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -501,6 +501,7 @@ ao_lisp_collect(uint8_t style) MDBG_MOVE("collect %d\n", ao_lisp_collects[style]); #endif + MDBG_DO(ao_lisp_frame_write(ao_lisp_frame_poly(ao_lisp_frame_global))); /* The first time through, we're doing a full collect */ if (ao_lisp_last_top == 0) @@ -875,6 +876,7 @@ ao_lisp_alloc(int size) } addr = ao_lisp_pool + ao_lisp_top; ao_lisp_top += size; + MDBG_MOVE("alloc %d size %d\n", MDBG_OFFSET(addr), size); return addr; } diff --git a/src/lisp/ao_lisp_stack.c b/src/lisp/ao_lisp_stack.c index 9d6cccc4..e7c89801 100644 --- a/src/lisp/ao_lisp_stack.c +++ b/src/lisp/ao_lisp_stack.c @@ -103,7 +103,9 @@ ao_lisp_stack_new(void) int ao_lisp_stack_push(void) { - struct ao_lisp_stack *stack = ao_lisp_stack_new(); + struct ao_lisp_stack *stack; + + stack = ao_lisp_stack_new(); if (!stack) return 0; diff --git a/src/test/ao_lisp_os.h b/src/test/ao_lisp_os.h index 9b021900..ebd16bb4 100644 --- a/src/test/ao_lisp_os.h +++ b/src/test/ao_lisp_os.h @@ -22,7 +22,7 @@ #include #include -#define AO_LISP_POOL_TOTAL 3072 +#define AO_LISP_POOL_TOTAL 16384 #define AO_LISP_SAVE 1 #define DBG_MEM_STATS 1 diff --git a/src/test/hanoi.lisp b/src/test/hanoi.lisp index 02e16876..4afde883 100644 --- a/src/test/hanoi.lisp +++ b/src/test/hanoi.lisp @@ -16,20 +16,17 @@ ; ANSI control sequences -(define move-to (lambda (col row) - (for-each display (list "\033[" row ";" col "H")) - ) +(define (move-to col row) + (for-each display (list "\033[" row ";" col "H")) ) -(define clear (lambda () - (display "\033[2J") - ) +(define (clear) + (display "\033[2J") ) -(define display-string (lambda (x y str) - (move-to x y) - (display str) - ) +(define (display-string x y str) + (move-to x y) + (display str) ) ; Here's the pieces to display @@ -41,75 +38,69 @@ (define towers ()) -(define one- (lambda (x) (- x 1))) -(define one+ (lambda (x) (+ x 1))) +(define (one- x) (- x 1)) +(define (one+ x) (+ x 1)) ; Display one tower, clearing any ; space above it -(define display-tower (lambda (x y clear tower) - (cond ((= 0 clear) - (cond ((not (null? tower)) - (display-string x y (car tower)) - (display-tower x (one+ y) 0 (cdr tower)) - ) - ) - ) - (else - (display-string x y " ") - (display-tower x (one+ y) (one- clear) tower) - ) - ) - ) +(define (display-tower x y clear tower) + (cond ((= 0 clear) + (cond ((not (null? tower)) + (display-string x y (car tower)) + (display-tower x (one+ y) 0 (cdr tower)) + ) + ) + ) + (else + (display-string x y " ") + (display-tower x (one+ y) (one- clear) tower) + ) + ) ) ; Position of the top of the tower on the screen ; Shorter towers start further down the screen -(define tower-pos (lambda (y tower) - (- y (length tower)) - ) +(define (tower-pos y tower) + (- y (length tower)) ) ; Display all of the towers, spaced 20 columns apart -(define display-towers (lambda (x y towers) - (cond ((not (null? towers)) - (display-tower x 0 (tower-pos y (car towers)) (car towers)) - (display-towers (+ x 20) y (cdr towers))) - ) - ) +(define (display-towers x y towers) + (cond ((not (null? towers)) + (display-tower x 0 (tower-pos y (car towers)) (car towers)) + (display-towers (+ x 20) y (cdr towers))) + ) ) (define top 0) ; Display all of the towers, then move the cursor ; out of the way and flush the output -(define display-hanoi (lambda () - (display-towers 0 top towers) - (move-to 1 21) - (flush-output) - ) +(define (display-hanoi) + (display-towers 0 top towers) + (move-to 1 21) + (flush-output) ) ; Reset towers to the starting state, with ; all of the pieces in the first tower and the ; other two empty -(define reset-towers (lambda () - (set! towers (list tower () ())) - (set! top (+ (length tower) 3)) - (length tower) - ) +(define (reset-towers) + (set! towers (list tower () ())) + (set! top (+ (length tower) 3)) + (length tower) ) ; Replace a tower in the list of towers ; with a new value -(define replace (lambda (list pos member) - (cond ((= pos 0) (cons member (cdr list))) - ((cons (car list) (replace (cdr list) (one- pos) member))) - ) - ) +(define (replace list pos member) + (cond ((= pos 0) (cons member (cdr list))) + (else (cons (car list) (replace (cdr list) (one- pos) member))) + ) ) ; Move a piece from the top of one tower @@ -117,33 +108,31 @@ (define move-delay 10) -(define move-piece (lambda (from to) - (let* ((from-tower (list-ref towers from)) - (to-tower (list-ref towers to)) - (piece (car from-tower))) - (set! from-tower (cdr from-tower)) - (set! to-tower (cons piece to-tower)) - (set! towers (replace towers from from-tower)) - (set! towers (replace towers to to-tower)) - (display-hanoi) - (delay move-delay) - ) - ) +(define (move-piece from to) + (let* ((from-tower (list-ref towers from)) + (to-tower (list-ref towers to)) + (piece (car from-tower))) + (set! from-tower (cdr from-tower)) + (set! to-tower (cons piece to-tower)) + (set! towers (replace towers from from-tower)) + (set! towers (replace towers to to-tower)) + (display-hanoi) + (delay move-delay) + ) ) ; The implementation of the game -(define _hanoi (lambda (n from to use) - (cond ((= 1 n) - (move-piece from to) - ) - (else - (_hanoi (one- n) from use to) - (_hanoi 1 from to use) - (_hanoi (one- n) use to from) - ) - ) - ) +(define (_hanoi n from to use) + (cond ((= 1 n) + (move-piece from to) + ) + (else + (_hanoi (one- n) from use to) + (_hanoi 1 from to use) + (_hanoi (one- n) use to from) + ) + ) ) ; A pretty interface which @@ -151,13 +140,12 @@ ; clears the screen and runs ; the program -(define hanoi (lambda () - (let ((len)) - (set! len (reset-towers)) - (clear) - (_hanoi len 0 1 2) - (move-to 0 23) - #t - ) - ) +(define (hanoi) + (let ((len (reset-towers))) + (clear) + (_hanoi len 0 1 2) + (move-to 0 23) + #t + ) + ) ) -- cgit v1.2.3 From f0068719b17019c5cd7ed318364a0581caf64e1a Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 2 Dec 2017 15:32:38 -0600 Subject: altos/kernel: MPU9250 support Use MPU9250 for accel, gyro and mag data in logging, telemetry and flight status computations. Signed-off-by: Keith Packard --- src/kernel/ao_data.h | 58 +++++++++++++++++++++++++++++++++++++++++++++++ src/kernel/ao_flight.c | 2 +- src/kernel/ao_log.h | 3 ++- src/kernel/ao_log_mega.c | 11 +++++++++ src/kernel/ao_sample.c | 6 ++--- src/kernel/ao_telemetry.c | 16 ++++++++++++- 6 files changed, 90 insertions(+), 6 deletions(-) diff --git a/src/kernel/ao_data.h b/src/kernel/ao_data.h index 9a3b389c..88d0e916 100644 --- a/src/kernel/ao_data.h +++ b/src/kernel/ao_data.h @@ -330,6 +330,47 @@ typedef int16_t angle_t; /* in degrees */ #define ao_data_pitch(packet) ((packet)->mpu6000.gyro_x) #define ao_data_yaw(packet) ((packet)->mpu6000.gyro_z) +static inline float ao_convert_gyro(float sensor) +{ + return ao_mpu6000_gyro(sensor); +} + +static inline float ao_convert_accel(int16_t sensor) +{ + return ao_mpu6000_accel(sensor); +} + +#endif + +#if !HAS_GYRO && HAS_MPU9250 + +#define HAS_GYRO 1 + +typedef int16_t gyro_t; /* in raw sample units */ +typedef int16_t angle_t; /* in degrees */ + +/* Y axis is aligned with the direction of motion (along) */ +/* X axis is aligned in the other board axis (across) */ +/* Z axis is aligned perpendicular to the board (through) */ + +#define ao_data_along(packet) ((packet)->mpu9250.accel_y) +#define ao_data_across(packet) ((packet)->mpu9250.accel_x) +#define ao_data_through(packet) ((packet)->mpu9250.accel_z) + +#define ao_data_roll(packet) ((packet)->mpu9250.gyro_y) +#define ao_data_pitch(packet) ((packet)->mpu9250.gyro_x) +#define ao_data_yaw(packet) ((packet)->mpu9250.gyro_z) + +static inline float ao_convert_gyro(float sensor) +{ + return ao_mpu9250_gyro(sensor); +} + +static inline float ao_convert_accel(int16_t sensor) +{ + return ao_mpu9250_accel(sensor); +} + #endif #if !HAS_MAG && HAS_HMC5883 @@ -344,4 +385,21 @@ typedef int16_t ao_mag_t; /* in raw sample units */ #endif +#if !HAS_MAG && HAS_MPU9250 + +#define HAS_MAG 1 + +typedef int16_t ao_mag_t; /* in raw sample units */ + +/* Note that this order is different from the accel and gyro. For some + * reason, the mag sensor axes aren't the same as the other two + * sensors. Also, the Z axis is flipped in sign. + */ + +#define ao_data_mag_along(packet) ((packet)->mpu9250.mag_x) +#define ao_data_mag_across(packet) ((packet)->mpu9250.mag_y) +#define ao_data_mag_through(packet) ((packet)->mpu9250.mag_z) + +#endif + #endif /* _AO_DATA_H_ */ diff --git a/src/kernel/ao_flight.c b/src/kernel/ao_flight.c index f06125cd..cb02c454 100644 --- a/src/kernel/ao_flight.c +++ b/src/kernel/ao_flight.c @@ -21,7 +21,7 @@ #include #endif -#if HAS_MPU6000 +#if HAS_MPU6000 || HAS_MPU9250 #include #endif diff --git a/src/kernel/ao_log.h b/src/kernel/ao_log.h index 1c186364..5f04ef9a 100644 --- a/src/kernel/ao_log.h +++ b/src/kernel/ao_log.h @@ -54,6 +54,7 @@ extern __pdata enum ao_flight_state ao_log_state; #define AO_LOG_FORMAT_TELEMINI3 12 /* 16-byte MS5607 baro only, 3.3V supply, stm32f042 SoC */ #define AO_LOG_FORMAT_TELEFIRETWO 13 /* 32-byte test stand data */ #define AO_LOG_FORMAT_EASYMINI2 14 /* 16-byte MS5607 baro only, 3.3V supply, stm32f042 SoC */ +#define AO_LOG_FORMAT_TELEMEGA_3 15 /* 32 byte typed telemega records with 32 bit gyro cal and mpu9250 */ #define AO_LOG_FORMAT_NONE 127 /* No log at all */ /* Return the flight number from the given log slot, 0 if none, -slot on failure */ @@ -473,7 +474,7 @@ struct ao_log_gps { } u; }; -#if AO_LOG_FORMAT == AO_LOG_FOMAT_TELEMEGA_OLD || AO_LOG_FORMAT == AO_LOG_FORMAT_TELEMEGA +#if AO_LOG_FORMAT == AO_LOG_FOMAT_TELEMEGA_OLD || AO_LOG_FORMAT == AO_LOG_FORMAT_TELEMEGA || AO_LOG_FORMAT == AO_LOG_FORMAT_TELEMEGA_3 typedef struct ao_log_mega ao_log_type; #endif diff --git a/src/kernel/ao_log_mega.c b/src/kernel/ao_log_mega.c index d1cf4f13..c6bdf1e2 100644 --- a/src/kernel/ao_log_mega.c +++ b/src/kernel/ao_log_mega.c @@ -93,6 +93,17 @@ ao_log(void) log.u.sensor.mag_x = ao_data_ring[ao_log_data_pos].hmc5883.x; log.u.sensor.mag_z = ao_data_ring[ao_log_data_pos].hmc5883.z; log.u.sensor.mag_y = ao_data_ring[ao_log_data_pos].hmc5883.y; +#endif +#if HAS_MPU9250 + log.u.sensor.accel_x = ao_data_ring[ao_log_data_pos].mpu9250.accel_x; + log.u.sensor.accel_y = ao_data_ring[ao_log_data_pos].mpu9250.accel_y; + log.u.sensor.accel_z = ao_data_ring[ao_log_data_pos].mpu9250.accel_z; + log.u.sensor.gyro_x = ao_data_ring[ao_log_data_pos].mpu9250.gyro_x; + log.u.sensor.gyro_y = ao_data_ring[ao_log_data_pos].mpu9250.gyro_y; + log.u.sensor.gyro_z = ao_data_ring[ao_log_data_pos].mpu9250.gyro_z; + log.u.sensor.mag_x = ao_data_ring[ao_log_data_pos].mpu9250.mag_x; + log.u.sensor.mag_z = ao_data_ring[ao_log_data_pos].mpu9250.mag_z; + log.u.sensor.mag_y = ao_data_ring[ao_log_data_pos].mpu9250.mag_y; #endif log.u.sensor.accel = ao_data_accel(&ao_data_ring[ao_log_data_pos]); ao_log_write(&log); diff --git a/src/kernel/ao_sample.c b/src/kernel/ao_sample.c index f0ab0169..61519478 100644 --- a/src/kernel/ao_sample.c +++ b/src/kernel/ao_sample.c @@ -184,9 +184,9 @@ ao_sample_rotate(void) #else static const float dt = 1/TIME_DIV; #endif - float x = ao_mpu6000_gyro((float) ((ao_sample_pitch << 9) - ao_ground_pitch) / 512.0f) * dt; - float y = ao_mpu6000_gyro((float) ((ao_sample_yaw << 9) - ao_ground_yaw) / 512.0f) * dt; - float z = ao_mpu6000_gyro((float) ((ao_sample_roll << 9) - ao_ground_roll) / 512.0f) * dt; + float x = ao_convert_gyro((float) ((ao_sample_pitch << 9) - ao_ground_pitch) / 512.0f) * dt; + float y = ao_convert_gyro((float) ((ao_sample_yaw << 9) - ao_ground_yaw) / 512.0f) * dt; + float z = ao_convert_gyro((float) ((ao_sample_roll << 9) - ao_ground_roll) / 512.0f) * dt; struct ao_quaternion rot; ao_quaternion_init_half_euler(&rot, x, y, z); diff --git a/src/kernel/ao_telemetry.c b/src/kernel/ao_telemetry.c index 2ae1e41b..9ed612ce 100644 --- a/src/kernel/ao_telemetry.c +++ b/src/kernel/ao_telemetry.c @@ -141,7 +141,7 @@ ao_send_mega_sensor(void) telemetry.generic.tick = packet->tick; telemetry.generic.type = AO_TELEMETRY_MEGA_SENSOR; -#if HAS_MPU6000 +#if HAS_MPU6000 || HAS_MPU9250 telemetry.mega_sensor.orient = ao_sample_orient; #endif telemetry.mega_sensor.accel = ao_data_accel(packet); @@ -164,6 +164,20 @@ ao_send_mega_sensor(void) telemetry.mega_sensor.mag_y = packet->hmc5883.y; #endif +#if HAS_MPU9250 + telemetry.mega_sensor.accel_x = packet->mpu9250.accel_x; + telemetry.mega_sensor.accel_y = packet->mpu9250.accel_y; + telemetry.mega_sensor.accel_z = packet->mpu9250.accel_z; + + telemetry.mega_sensor.gyro_x = packet->mpu9250.gyro_x; + telemetry.mega_sensor.gyro_y = packet->mpu9250.gyro_y; + telemetry.mega_sensor.gyro_z = packet->mpu9250.gyro_z; + + telemetry.mega_sensor.mag_x = packet->mpu9250.mag_x; + telemetry.mega_sensor.mag_z = packet->mpu9250.mag_z; + telemetry.mega_sensor.mag_y = packet->mpu9250.mag_y; +#endif + ao_telemetry_send(); } -- cgit v1.2.3 From ecc075596d6cd2b9c0a3107036d5368ebc3a77bd Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 2 Dec 2017 15:31:06 -0600 Subject: altos: Add TeleMega v3.0 Adds files to build telemega v3.0 flash loader and firmware Signed-off-by: Keith Packard --- src/telemega-v3.0/.gitignore | 2 + src/telemega-v3.0/Makefile | 153 ++++++++++++ src/telemega-v3.0/ao_pins.h | 402 +++++++++++++++++++++++++++++++ src/telemega-v3.0/ao_telemega.c | 104 ++++++++ src/telemega-v3.0/flash-loader/Makefile | 8 + src/telemega-v3.0/flash-loader/ao_pins.h | 35 +++ 6 files changed, 704 insertions(+) create mode 100644 src/telemega-v3.0/.gitignore create mode 100644 src/telemega-v3.0/Makefile create mode 100644 src/telemega-v3.0/ao_pins.h create mode 100644 src/telemega-v3.0/ao_telemega.c create mode 100644 src/telemega-v3.0/flash-loader/Makefile create mode 100644 src/telemega-v3.0/flash-loader/ao_pins.h diff --git a/src/telemega-v3.0/.gitignore b/src/telemega-v3.0/.gitignore new file mode 100644 index 00000000..e67759a2 --- /dev/null +++ b/src/telemega-v3.0/.gitignore @@ -0,0 +1,2 @@ +ao_product.h +telemega-*.elf diff --git a/src/telemega-v3.0/Makefile b/src/telemega-v3.0/Makefile new file mode 100644 index 00000000..ae22bf01 --- /dev/null +++ b/src/telemega-v3.0/Makefile @@ -0,0 +1,153 @@ +# +# AltOS build +# +# + +include ../stm/Makefile.defs + +INC = \ + ao.h \ + ao_arch.h \ + ao_arch_funcs.h \ + ao_boot.h \ + ao_companion.h \ + ao_data.h \ + ao_sample.h \ + ao_pins.h \ + altitude-pa.h \ + ao_kalman.h \ + ao_product.h \ + ao_ms5607.h \ + ao_mpu9250.h \ + ao_mma655x.h \ + ao_cc1200_CC1200.h \ + ao_profile.h \ + ao_task.h \ + ao_whiten.h \ + ao_sample_profile.h \ + ao_quaternion.h \ + math.h \ + ao_mpu.h \ + stm32l.h \ + math.h \ + ao_ms5607_convert.c \ + Makefile + +# +# Common AltOS sources +# + +#PROFILE=ao_profile.c +#PROFILE_DEF=-DAO_PROFILE=1 + +#SAMPLE_PROFILE=ao_sample_profile.c \ +# ao_sample_profile_timer.c +#SAMPLE_PROFILE_DEF=-DHAS_SAMPLE_PROFILE=1 + +#STACK_GUARD=ao_mpu_stm.c +#STACK_GUARD_DEF=-DHAS_STACK_GUARD=1 + +MATH_SRC=\ + ef_acos.c \ + ef_sqrt.c \ + ef_rem_pio2.c \ + kf_cos.c \ + kf_sin.c \ + kf_rem_pio2.c \ + sf_copysign.c \ + sf_cos.c \ + sf_fabs.c \ + sf_floor.c \ + sf_scalbn.c \ + sf_sin.c \ + ef_log.c + +ALTOS_SRC = \ + ao_boot_chain.c \ + ao_interrupt.c \ + ao_product.c \ + ao_romconfig.c \ + ao_cmd.c \ + ao_config.c \ + ao_task.c \ + ao_led.c \ + ao_stdio.c \ + ao_panic.c \ + ao_timer.c \ + ao_mutex.c \ + ao_serial_stm.c \ + ao_gps_ublox.c \ + ao_gps_show.c \ + ao_gps_report_mega.c \ + ao_ignite.c \ + ao_freq.c \ + ao_dma_stm.c \ + ao_spi_stm.c \ + ao_cc1200.c \ + ao_data.c \ + ao_ms5607.c \ + ao_mma655x.c \ + ao_adc_stm.c \ + ao_beep_stm.c \ + ao_eeprom_stm.c \ + ao_storage.c \ + ao_m25.c \ + ao_usb_stm.c \ + ao_exti_stm.c \ + ao_report.c \ + ao_i2c_stm.c \ + ao_mpu9250.c \ + ao_convert_pa.c \ + ao_convert_volt.c \ + ao_log.c \ + ao_log_mega.c \ + ao_sample.c \ + ao_kalman.c \ + ao_flight.c \ + ao_telemetry.c \ + ao_packet_slave.c \ + ao_packet.c \ + ao_companion.c \ + ao_pyro.c \ + ao_aprs.c \ + ao_pwm_stm.c \ + $(MATH_SRC) \ + $(PROFILE) \ + $(SAMPLE_PROFILE) \ + $(STACK_GUARD) + +PRODUCT=TeleMega-v3.0 +PRODUCT_DEF=-DTELEMEGA +IDPRODUCT=0x0023 + +CFLAGS = $(PRODUCT_DEF) $(STM_CFLAGS) $(PROFILE_DEF) $(SAMPLE_PROFILE_DEF) $(STACK_GUARD_DEF) -Os -g + +PROGNAME=telemega-v3.0 +PROG=$(PROGNAME)-$(VERSION).elf +HEX=$(PROGNAME)-$(VERSION).ihx + +SRC=$(ALTOS_SRC) ao_telemega.c +OBJ=$(SRC:.c=.o) + +all: $(PROG) $(HEX) + +$(PROG): Makefile $(OBJ) altos.ld + $(call quiet,CC) $(LDFLAGS) $(CFLAGS) -o $(PROG) $(OBJ) $(LIBS) + +../altitude-pa.h: make-altitude-pa + nickle $< > $@ + +$(OBJ): $(INC) + +ao_product.h: ao-make-product.5c ../Version + $(call quiet,NICKLE,$<) $< -m altusmetrum.org -i $(IDPRODUCT) -p $(PRODUCT) -v $(VERSION) > $@ + +distclean: clean + +clean: + rm -f *.o $(PROGNAME)-*.elf $(PROGNAME)-*.ihx + rm -f ao_product.h + +install: + +uninstall: diff --git a/src/telemega-v3.0/ao_pins.h b/src/telemega-v3.0/ao_pins.h new file mode 100644 index 00000000..73278600 --- /dev/null +++ b/src/telemega-v3.0/ao_pins.h @@ -0,0 +1,402 @@ +/* + * Copyright © 2017 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * 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_PINS_H_ +#define _AO_PINS_H_ + +#define HAS_TASK_QUEUE 1 + +/* 8MHz High speed external crystal */ +#define AO_HSE 8000000 + +/* PLLVCO = 96MHz (so that USB will work) */ +#define AO_PLLMUL 12 +#define AO_RCC_CFGR_PLLMUL (STM_RCC_CFGR_PLLMUL_12) + +/* SYSCLK = 32MHz (no need to go faster than CPU) */ +#define AO_PLLDIV 3 +#define AO_RCC_CFGR_PLLDIV (STM_RCC_CFGR_PLLDIV_3) + +/* HCLK = 32MHz (CPU clock) */ +#define AO_AHB_PRESCALER 1 +#define AO_RCC_CFGR_HPRE_DIV STM_RCC_CFGR_HPRE_DIV_1 + +/* Run APB1 at 16MHz (HCLK/2) */ +#define AO_APB1_PRESCALER 2 +#define AO_RCC_CFGR_PPRE1_DIV STM_RCC_CFGR_PPRE2_DIV_2 + +/* Run APB2 at 16MHz (HCLK/2) */ +#define AO_APB2_PRESCALER 2 +#define AO_RCC_CFGR_PPRE2_DIV STM_RCC_CFGR_PPRE2_DIV_2 + +#define HAS_SERIAL_1 0 +#define USE_SERIAL_1_STDIN 0 +#define SERIAL_1_PB6_PB7 0 +#define SERIAL_1_PA9_PA10 1 + +#define HAS_SERIAL_2 0 +#define USE_SERIAL_2_STDIN 0 +#define SERIAL_2_PA2_PA3 0 +#define SERIAL_2_PD5_PD6 0 + +#define HAS_SERIAL_3 1 +#define USE_SERIAL_3_STDIN 0 +#define SERIAL_3_PB10_PB11 0 +#define SERIAL_3_PC10_PC11 1 +#define SERIAL_3_PD8_PD9 0 + +#define ao_gps_getchar ao_serial3_getchar +#define ao_gps_putchar ao_serial3_putchar +#define ao_gps_set_speed ao_serial3_set_speed +#define ao_gps_fifo (ao_stm_usart3.rx_fifo) + +#define AO_CONFIG_DEFAULT_FLIGHT_LOG_MAX (1024 * 1024) +#define AO_CONFIG_MAX_SIZE 1024 +#define LOG_ERASE_MARK 0x55 +#define LOG_MAX_ERASE 128 +#define AO_LOG_FORMAT AO_LOG_FORMAT_TELEMEGA_3 + +#define HAS_EEPROM 1 +#define USE_INTERNAL_FLASH 0 +#define USE_EEPROM_CONFIG 1 +#define USE_STORAGE_CONFIG 0 +#define HAS_USB 1 +#define HAS_BEEP 1 +#define HAS_BATTERY_REPORT 1 +#define HAS_RADIO 1 +#define HAS_TELEMETRY 1 +#define HAS_APRS 1 +#define HAS_COMPANION 1 + +#define HAS_SPI_1 1 +#define SPI_1_PA5_PA6_PA7 1 /* Barometer */ +#define SPI_1_PB3_PB4_PB5 0 +#define SPI_1_PE13_PE14_PE15 1 /* Accelerometer, Gyro */ +#define SPI_1_OSPEEDR STM_OSPEEDR_10MHz + +#define HAS_SPI_2 1 +#define SPI_2_PB13_PB14_PB15 1 /* Flash, Companion */ +#define SPI_2_PD1_PD3_PD4 0 +#define SPI_2_OSPEEDR STM_OSPEEDR_10MHz + +#define SPI_2_PORT (&stm_gpiob) +#define SPI_2_SCK_PIN 13 +#define SPI_2_MISO_PIN 14 +#define SPI_2_MOSI_PIN 15 + +#define HAS_I2C_1 1 +#define I2C_1_PB8_PB9 1 + +#define HAS_I2C_2 0 +#define I2C_2_PB10_PB11 0 + +#define PACKET_HAS_SLAVE 1 +#define PACKET_HAS_MASTER 0 + +#define LOW_LEVEL_DEBUG 0 + +#define LED_PORT_ENABLE STM_RCC_AHBENR_GPIOCEN +#define LED_PORT (&stm_gpioc) +#define LED_PIN_RED 8 +#define LED_PIN_GREEN 9 +#define AO_LED_RED (1 << LED_PIN_RED) +#define AO_LED_GREEN (1 << LED_PIN_GREEN) + +#define LEDS_AVAILABLE (AO_LED_RED | AO_LED_GREEN) + +#define HAS_GPS 1 +#define HAS_FLIGHT 1 +#define HAS_ADC 1 +#define HAS_ADC_TEMP 1 +#define HAS_LOG 1 + +/* + * Igniter + */ + +#define HAS_IGNITE 1 +#define HAS_IGNITE_REPORT 1 + +#define AO_SENSE_PYRO(p,n) ((p)->adc.sense[n]) +#define AO_SENSE_DROGUE(p) ((p)->adc.sense[4]) +#define AO_SENSE_MAIN(p) ((p)->adc.sense[5]) +#define AO_IGNITER_CLOSED 400 +#define AO_IGNITER_OPEN 60 + +/* Pyro A */ +#define AO_PYRO_PORT_0 (&stm_gpiod) +#define AO_PYRO_PIN_0 6 + +/* Pyro B */ +#define AO_PYRO_PORT_1 (&stm_gpiod) +#define AO_PYRO_PIN_1 7 + +/* Pyro C */ +#define AO_PYRO_PORT_2 (&stm_gpiob) +#define AO_PYRO_PIN_2 5 + +/* Pyro D */ +#define AO_PYRO_PORT_3 (&stm_gpioe) +#define AO_PYRO_PIN_3 4 + +/* Drogue */ +#define AO_IGNITER_DROGUE_PORT (&stm_gpioe) +#define AO_IGNITER_DROGUE_PIN 6 + +/* Main */ +#define AO_IGNITER_MAIN_PORT (&stm_gpioe) +#define AO_IGNITER_MAIN_PIN 5 + +/* Number of general purpose pyro channels available */ +#define AO_PYRO_NUM 4 + +#define AO_IGNITER_SET_DROGUE(v) stm_gpio_set(AO_IGNITER_DROGUE_PORT, AO_IGNITER_DROGUE_PIN, v) +#define AO_IGNITER_SET_MAIN(v) stm_gpio_set(AO_IGNITER_MAIN_PORT, AO_IGNITER_MAIN_PIN, v) + +/* + * ADC + */ +#define AO_DATA_RING 32 +#define AO_ADC_NUM_SENSE 6 + +struct ao_adc { + int16_t sense[AO_ADC_NUM_SENSE]; + int16_t v_batt; + int16_t v_pbatt; + int16_t temp; +}; + +#define AO_ADC_DUMP(p) \ + printf("tick: %5u A: %5d B: %5d C: %5d D: %5d drogue: %5d main: %5d batt: %5d pbatt: %5d temp: %5d\n", \ + (p)->tick, \ + (p)->adc.sense[0], (p)->adc.sense[1], (p)->adc.sense[2], \ + (p)->adc.sense[3], (p)->adc.sense[4], (p)->adc.sense[5], \ + (p)->adc.v_batt, (p)->adc.v_pbatt, (p)->adc.temp) + +#define AO_ADC_SENSE_A 0 +#define AO_ADC_SENSE_A_PORT (&stm_gpioa) +#define AO_ADC_SENSE_A_PIN 0 + +#define AO_ADC_SENSE_B 1 +#define AO_ADC_SENSE_B_PORT (&stm_gpioa) +#define AO_ADC_SENSE_B_PIN 1 + +#define AO_ADC_SENSE_C 2 +#define AO_ADC_SENSE_C_PORT (&stm_gpioa) +#define AO_ADC_SENSE_C_PIN 2 + +#define AO_ADC_SENSE_D 3 +#define AO_ADC_SENSE_D_PORT (&stm_gpioa) +#define AO_ADC_SENSE_D_PIN 3 + +#define AO_ADC_SENSE_DROGUE 4 +#define AO_ADC_SENSE_DROGUE_PORT (&stm_gpioa) +#define AO_ADC_SENSE_DROGUE_PIN 4 + +#define AO_ADC_SENSE_MAIN 22 +#define AO_ADC_SENSE_MAIN_PORT (&stm_gpioe) +#define AO_ADC_SENSE_MAIN_PIN 7 + +#define AO_ADC_V_BATT 8 +#define AO_ADC_V_BATT_PORT (&stm_gpiob) +#define AO_ADC_V_BATT_PIN 0 + +#define AO_ADC_V_PBATT 9 +#define AO_ADC_V_PBATT_PORT (&stm_gpiob) +#define AO_ADC_V_PBATT_PIN 1 + +#define AO_ADC_TEMP 16 + +#define AO_ADC_RCC_AHBENR ((1 << STM_RCC_AHBENR_GPIOAEN) | \ + (1 << STM_RCC_AHBENR_GPIOEEN) | \ + (1 << STM_RCC_AHBENR_GPIOBEN)) + +#define AO_NUM_ADC_PIN (AO_ADC_NUM_SENSE + 2) + +#define AO_ADC_PIN0_PORT AO_ADC_SENSE_A_PORT +#define AO_ADC_PIN0_PIN AO_ADC_SENSE_A_PIN +#define AO_ADC_PIN1_PORT AO_ADC_SENSE_B_PORT +#define AO_ADC_PIN1_PIN AO_ADC_SENSE_B_PIN +#define AO_ADC_PIN2_PORT AO_ADC_SENSE_C_PORT +#define AO_ADC_PIN2_PIN AO_ADC_SENSE_C_PIN +#define AO_ADC_PIN3_PORT AO_ADC_SENSE_D_PORT +#define AO_ADC_PIN3_PIN AO_ADC_SENSE_D_PIN +#define AO_ADC_PIN4_PORT AO_ADC_SENSE_DROGUE_PORT +#define AO_ADC_PIN4_PIN AO_ADC_SENSE_DROGUE_PIN +#define AO_ADC_PIN5_PORT AO_ADC_SENSE_MAIN_PORT +#define AO_ADC_PIN5_PIN AO_ADC_SENSE_MAIN_PIN +#define AO_ADC_PIN6_PORT AO_ADC_V_BATT_PORT +#define AO_ADC_PIN6_PIN AO_ADC_V_BATT_PIN +#define AO_ADC_PIN7_PORT AO_ADC_V_PBATT_PORT +#define AO_ADC_PIN7_PIN AO_ADC_V_PBATT_PIN + +#define AO_NUM_ADC (AO_ADC_NUM_SENSE + 3) + +#define AO_ADC_SQ1 AO_ADC_SENSE_A +#define AO_ADC_SQ2 AO_ADC_SENSE_B +#define AO_ADC_SQ3 AO_ADC_SENSE_C +#define AO_ADC_SQ4 AO_ADC_SENSE_D +#define AO_ADC_SQ5 AO_ADC_SENSE_DROGUE +#define AO_ADC_SQ6 AO_ADC_SENSE_MAIN +#define AO_ADC_SQ7 AO_ADC_V_BATT +#define AO_ADC_SQ8 AO_ADC_V_PBATT +#define AO_ADC_SQ9 AO_ADC_TEMP + +/* + * Voltage divider on ADC battery sampler + */ +#define AO_BATTERY_DIV_PLUS 56 /* 5.6k */ +#define AO_BATTERY_DIV_MINUS 100 /* 10k */ + +/* + * Voltage divider on ADC igniter samplers + */ +#define AO_IGNITE_DIV_PLUS 100 /* 100k */ +#define AO_IGNITE_DIV_MINUS 27 /* 27k */ + +/* + * ADC reference in decivolts + */ +#define AO_ADC_REFERENCE_DV 33 + +/* + * Pressure sensor settings + */ +#define HAS_MS5607 1 +#define HAS_MS5611 0 +#define AO_MS5607_PRIVATE_PINS 1 +#define AO_MS5607_CS_PORT (&stm_gpioc) +#define AO_MS5607_CS_PIN 4 +#define AO_MS5607_CS_MASK (1 << AO_MS5607_CS) +#define AO_MS5607_MISO_PORT (&stm_gpioa) +#define AO_MS5607_MISO_PIN 6 +#define AO_MS5607_MISO_MASK (1 << AO_MS5607_MISO) +#define AO_MS5607_SPI_INDEX AO_SPI_1_PA5_PA6_PA7 + +/* + * SPI Flash memory + */ + +#define M25_MAX_CHIPS 1 +#define AO_M25_SPI_CS_PORT (&stm_gpiod) +#define AO_M25_SPI_CS_MASK (1 << 3) +#define AO_M25_SPI_BUS AO_SPI_2_PB13_PB14_PB15 + +/* + * Radio (cc1120) + */ + +/* gets pretty close to 434.550 */ + +#define AO_RADIO_CAL_DEFAULT 5695733 + +#define AO_FEC_DEBUG 0 +#define AO_CC1200_SPI_CS_PORT (&stm_gpioc) +#define AO_CC1200_SPI_CS_PIN 5 +#define AO_CC1200_SPI_BUS AO_SPI_2_PB13_PB14_PB15 +#define AO_CC1200_SPI stm_spi2 +#define AO_CC1200_SPI_SPEED AO_SPI_SPEED_FAST + +#define AO_CC1200_INT_PORT (&stm_gpioe) +#define AO_CC1200_INT_PIN 1 +#define AO_CC1200_MCU_WAKEUP_PORT (&stm_gpioc) +#define AO_CC1200_MCU_WAKEUP_PIN (0) + +#define AO_CC1200_INT_GPIO 2 +#define AO_CC1200_INT_GPIO_IOCFG CC1200_IOCFG2 + +#define AO_CC1200_MARC_GPIO 3 +#define AO_CC1200_MARC_GPIO_IOCFG CC1200_IOCFG3 + +#define HAS_BOOT_RADIO 0 + +/* + * mpu9250 + */ + +#define HAS_MPU9250 1 +#define AO_MPU9250_INT_PORT (&stm_gpioe) +#define AO_MPU9250_INT_PIN 0 +#define AO_MPU9250_SPI_BUS AO_SPI_1_PE13_PE14_PE15 +#define AO_MPU9250_SPI_CS_PORT (&stm_gpiod) +#define AO_MPU9250_SPI_CS_PIN 2 +#define HAS_IMU 1 + +/* + * mma655x + */ + +#define HAS_MMA655X 1 +#define AO_MMA655X_INVERT 0 +#define AO_MMA655X_SPI_INDEX AO_SPI_1_PE13_PE14_PE15 +#define AO_MMA655X_CS_PORT (&stm_gpiod) +#define AO_MMA655X_CS_PIN 4 + +#define NUM_CMDS 16 + +/* + * Companion + */ + +#define AO_COMPANION_CS_PORT (&stm_gpiob) +#define AO_COMPANION_CS_PIN_0 (6) +#define AO_COMPANION_CS_PIN AO_COMPANION_CS_PIN_0 +#define AO_COMPANION_CS_PIN_1 (7) +#define AO_COMPANION_SPI_BUS AO_SPI_2_PB13_PB14_PB15 + +/* + * Monitor + */ + +#define HAS_MONITOR 0 +#define LEGACY_MONITOR 0 +#define HAS_MONITOR_PUT 1 +#define AO_MONITOR_LED 0 +#define HAS_RSSI 0 + +/* + * Profiling Viterbi decoding + */ + +#ifndef AO_PROFILE +#define AO_PROFILE 0 +#endif + +/* + * PWM output + */ + +#define NUM_PWM 4 +#define PWM_MAX 20000 +#define AO_PWM_TIMER stm_tim4 +#define AO_PWM_TIMER_ENABLE STM_RCC_APB1ENR_TIM4EN +#define AO_PWM_TIMER_SCALE 32 + +#define AO_PWM_0_GPIO (&stm_gpiod) +#define AO_PWM_0_PIN 12 + +#define AO_PWM_1_GPIO (&stm_gpiod) +#define AO_PWM_1_PIN 13 + +#define AO_PWM_2_GPIO (&stm_gpiod) +#define AO_PWM_2_PIN 14 + +#define AO_PWM_3_GPIO (&stm_gpiod) +#define AO_PWM_3_PIN 15 + +#endif /* _AO_PINS_H_ */ diff --git a/src/telemega-v3.0/ao_telemega.c b/src/telemega-v3.0/ao_telemega.c new file mode 100644 index 00000000..2259c751 --- /dev/null +++ b/src/telemega-v3.0/ao_telemega.c @@ -0,0 +1,104 @@ +/* + * Copyright © 2017 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * 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 +#include +#include +#include +#include +#include +#include +#include +#include +#if HAS_SAMPLE_PROFILE +#include +#endif +#include +#if HAS_STACK_GUARD +#include +#endif +#include + +int +main(void) +{ + ao_clock_init(); + +#if HAS_STACK_GUARD + ao_mpu_init(); +#endif + + ao_task_init(); + ao_serial_init(); + ao_led_init(LEDS_AVAILABLE); + ao_led_on(LEDS_AVAILABLE); + ao_timer_init(); + + ao_i2c_init(); + ao_spi_init(); + ao_dma_init(); + ao_exti_init(); + + ao_adc_init(); +#if HAS_BEEP + ao_beep_init(); +#endif + ao_cmd_init(); + +#if HAS_MS5607 + ao_ms5607_init(); +#endif +#if HAS_MPU9250 + ao_mpu9250_init(); +#endif +#if HAS_MMA655X + ao_mma655x_init(); +#endif + + ao_eeprom_init(); + ao_storage_init(); + + ao_flight_init(); + ao_log_init(); + ao_report_init(); + + ao_usb_init(); + ao_gps_init(); + ao_gps_report_mega_init(); + ao_telemetry_init(); + ao_radio_init(); + ao_packet_slave_init(FALSE); + ao_igniter_init(); + ao_companion_init(); + ao_pyro_init(); + + ao_config_init(); +#if AO_PROFILE + ao_profile_init(); +#endif +#if HAS_SAMPLE_PROFILE + ao_sample_profile_init(); +#endif + + ao_pwm_init(); + + ao_led_off(LEDS_AVAILABLE); + + ao_start_scheduler(); + return 0; +} diff --git a/src/telemega-v3.0/flash-loader/Makefile b/src/telemega-v3.0/flash-loader/Makefile new file mode 100644 index 00000000..9e00293f --- /dev/null +++ b/src/telemega-v3.0/flash-loader/Makefile @@ -0,0 +1,8 @@ +# +# AltOS flash loader build +# +# + +TOPDIR=../.. +HARDWARE=telemega-v3.0 +include $(TOPDIR)/stm/Makefile-flash.defs diff --git a/src/telemega-v3.0/flash-loader/ao_pins.h b/src/telemega-v3.0/flash-loader/ao_pins.h new file mode 100644 index 00000000..6e9bba57 --- /dev/null +++ b/src/telemega-v3.0/flash-loader/ao_pins.h @@ -0,0 +1,35 @@ +/* + * Copyright © 2017 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * 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_PINS_H_ +#define _AO_PINS_H_ + +/* External crystal at 8MHz */ +#define AO_HSE 8000000 + +#include + +/* Companion port cs_companion0 PB6 */ + +#define AO_BOOT_PIN 1 +#define AO_BOOT_APPLICATION_GPIO stm_gpiob +#define AO_BOOT_APPLICATION_PIN 6 +#define AO_BOOT_APPLICATION_VALUE 1 +#define AO_BOOT_APPLICATION_MODE AO_EXTI_MODE_PULL_UP + +#endif /* _AO_PINS_H_ */ -- cgit v1.2.3 From 8c19778d8b56aafa048ddf9654c40b32bd8c64b0 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 2 Dec 2017 15:53:05 -0600 Subject: altos: Build TeleMega v3.0 by default Signed-off-by: Keith Packard --- src/Makefile | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Makefile b/src/Makefile index 661fd333..defeea96 100644 --- a/src/Makefile +++ b/src/Makefile @@ -30,6 +30,7 @@ ARMM3DIRS=\ telemega-v0.1 telemega-v0.1/flash-loader \ telemega-v1.0 telemega-v1.0/flash-loader \ telemega-v2.0 telemega-v2.0/flash-loader \ + telemega-v3.0 telemega-v3.0/flash-loader \ telemetrum-v2.0 telemetrum-v2.0/flash-loader \ telemetrum-v3.0 telemetrum-v3.0/flash-loader \ megadongle-v0.1 megadongle-v0.1/flash-loader \ -- cgit v1.2.3 From b986a12b478a6d4ff550786d24aa8628dc0abe32 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 2 Dec 2017 15:59:17 -0600 Subject: altoslib: Add support for TeleMega v3.0 log files These look much like TeleMega v2.0 log files, except that the mag sensor data now comes from the mpu9250 instead of an external hmc5883. The gyro and 3-axis accel data from the mpu9250 are the same as the mpu6000. Signed-off-by: Keith Packard --- altoslib/AltosEepromRecordMega.java | 3 +++ altoslib/AltosEepromRecordSet.java | 1 + altoslib/AltosLib.java | 1 + 3 files changed, 5 insertions(+) diff --git a/altoslib/AltosEepromRecordMega.java b/altoslib/AltosEepromRecordMega.java index ea5aff5c..86343fe0 100644 --- a/altoslib/AltosEepromRecordMega.java +++ b/altoslib/AltosEepromRecordMega.java @@ -31,6 +31,7 @@ public class AltosEepromRecordMega extends AltosEepromRecord { private int ground_roll() { switch (log_format) { case AltosLib.AO_LOG_FORMAT_TELEMEGA: + case AltosLib.AO_LOG_FORMAT_TELEMEGA_3: return data32(16); case AltosLib.AO_LOG_FORMAT_TELEMEGA_OLD: return data16(14); @@ -41,6 +42,7 @@ public class AltosEepromRecordMega extends AltosEepromRecord { private int ground_pitch() { switch (log_format) { case AltosLib.AO_LOG_FORMAT_TELEMEGA: + case AltosLib.AO_LOG_FORMAT_TELEMEGA_3: return data32(20); case AltosLib.AO_LOG_FORMAT_TELEMEGA_OLD: return data16(16); @@ -51,6 +53,7 @@ public class AltosEepromRecordMega extends AltosEepromRecord { private int ground_yaw() { switch (log_format) { case AltosLib.AO_LOG_FORMAT_TELEMEGA: + case AltosLib.AO_LOG_FORMAT_TELEMEGA_3: return data32(24); case AltosLib.AO_LOG_FORMAT_TELEMEGA_OLD: return data16(18); diff --git a/altoslib/AltosEepromRecordSet.java b/altoslib/AltosEepromRecordSet.java index 82a5ea2a..36075931 100644 --- a/altoslib/AltosEepromRecordSet.java +++ b/altoslib/AltosEepromRecordSet.java @@ -69,6 +69,7 @@ public class AltosEepromRecordSet implements AltosRecordSet { case AltosLib.AO_LOG_FORMAT_TELEMETRY: case AltosLib.AO_LOG_FORMAT_TELESCIENCE: case AltosLib.AO_LOG_FORMAT_TELEMEGA: + case AltosLib.AO_LOG_FORMAT_TELEMEGA_3: case AltosLib.AO_LOG_FORMAT_TELEMEGA_OLD: record = new AltosEepromRecordMega(eeprom); break; diff --git a/altoslib/AltosLib.java b/altoslib/AltosLib.java index 77b3fcc4..c25a6273 100644 --- a/altoslib/AltosLib.java +++ b/altoslib/AltosLib.java @@ -363,6 +363,7 @@ public class AltosLib { public static final int AO_LOG_FORMAT_TELEMINI3 = 12; public static final int AO_LOG_FORMAT_TELEFIRETWO = 13; public static final int AO_LOG_FORMAT_EASYMINI2 = 14; + public static final int AO_LOG_FORMAT_TELEMEGA_3 = 15; public static final int AO_LOG_FORMAT_NONE = 127; public static boolean isspace(int c) { -- cgit v1.2.3 From 577911241db454bc3129fc47566c6a55752c4182 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 2 Dec 2017 23:19:44 -0600 Subject: altos/lisp: Overflow int computations to float When an int computation overflows, switch to float. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 2 ++ src/lisp/ao_lisp_builtin.c | 42 ++++++++++++++++-------------------------- 2 files changed, 18 insertions(+), 26 deletions(-) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 1f3fb2b4..7cd8b5a5 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -208,6 +208,8 @@ ao_lisp_bigint_int(uint32_t bi) { #define AO_LISP_MIN_INT (-(1 << (15 - AO_LISP_TYPE_SHIFT))) #define AO_LISP_MAX_INT ((1 << (15 - AO_LISP_TYPE_SHIFT)) - 1) +#define AO_LISP_MIN_BIGINT (-(1 << 24)) +#define AO_LISP_MAX_BIGINT ((1 << 24) - 1) #define AO_LISP_NOT_INTEGER 0x7fffffff diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index d4751ac2..ad8f4125 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -321,24 +321,30 @@ ao_lisp_math(struct ao_lisp_cons *orig_cons, enum ao_lisp_builtin_id op) } else if (ao_lisp_integer_typep(rt) && ao_lisp_integer_typep(ct)) { int32_t r = ao_lisp_poly_integer(ret); int32_t c = ao_lisp_poly_integer(car); + int64_t t; switch(op) { case builtin_plus: r += c; + check_overflow: + if (r < AO_LISP_MIN_BIGINT || AO_LISP_MAX_BIGINT < r) + goto inexact; break; case builtin_minus: r -= c; + goto check_overflow; break; case builtin_times: - r *= c; + t = (int64_t) r * (int64_t) c; + if (t < AO_LISP_MIN_BIGINT || AO_LISP_MAX_BIGINT < t) + goto inexact; + r = (int32_t) t; break; case builtin_divide: if (c != 0 && (r % c) == 0) r /= c; - else { - ret = ao_lisp_float_get((float) r / (float) c); - continue; - } + else + goto inexact; break; case builtin_quotient: if (c == 0) @@ -365,8 +371,10 @@ ao_lisp_math(struct ao_lisp_cons *orig_cons, enum ao_lisp_builtin_id op) } ret = ao_lisp_integer_poly(r); } else if (ao_lisp_number_typep(rt) && ao_lisp_number_typep(ct)) { - float r = ao_lisp_poly_number(ret); - float c = ao_lisp_poly_number(car); + float r, c; + inexact: + r = ao_lisp_poly_number(ret); + c = ao_lisp_poly_number(car); switch(op) { case builtin_plus: r += c; @@ -380,28 +388,10 @@ ao_lisp_math(struct ao_lisp_cons *orig_cons, enum ao_lisp_builtin_id op) case builtin_divide: r /= c; break; -#if 0 case builtin_quotient: - if (c == 0) - return ao_lisp_error(AO_LISP_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_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "remainder by zero"); - r %= c; - break; case builtin_modulo: - if (c == 0) - return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "modulo by zero"); - r %= c; - if ((r < 0) != (c < 0)) - r += c; - break; -#endif + return ao_lisp_error(AO_LISP_INVALID, "non-integer value in integer divide"); default: break; } -- cgit v1.2.3 From 880c35363a2596202c8a3d980bf4ac41eceead66 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 2 Dec 2017 23:21:01 -0600 Subject: altos/lisp: Convert more builtin lisp code to scheme format Use defines where possible, use (define (name args ...)) form for lambdas Signed-off-by: Keith Packard --- src/lisp/ao_lisp_const.lisp | 159 +++++++++++++++++++++++++------------------- 1 file changed, 92 insertions(+), 67 deletions(-) diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index 436da3dc..bb413e7d 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -28,24 +28,23 @@ (begin (def! append (lexpr (args) - ((lambda (append-list append-lists) - (set! append-list - (lambda (a b) - (cond ((null? a) b) - (else (cons (car a) (append-list (cdr a) b))) - ) - ) - ) - (set! 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) - ) () ()) + (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) @@ -240,28 +239,31 @@ ; (define (name x y z) sexprs ...) ; -(def! define - (macro (first rest) +(begin + (def! define + (macro (first rest) ; check for alternate lambda definition form - (cond ((list? first) - (set! rest - (append - (list - 'lambda - (cdr first)) - rest)) - (set! first (car first)) - ) - (else - (set! rest (car rest)) - ) - ) - `(begin - (def (quote ,first) ,rest) - (quote ,first)) - ) - ) + (cond ((list? first) + (set! rest + (append + (list + 'lambda + (cdr first)) + rest)) + (set! first (car first)) + ) + (else + (set! rest (car rest)) + ) + ) + `(begin + (def (quote ,first) ,rest) + (quote ,first)) + ) + ) + 'define + ) ; basic list accessors @@ -689,9 +691,11 @@ (for-each display '("hello" " " "world" "\n")) -(define _string-ml (lambda (strings) - (if (null? strings) () - (cons (string->list (car strings)) (_string-ml (cdr strings)))))) +(define (_string-ml strings) + (if (null? strings) () + (cons (string->list (car strings)) (_string-ml (cdr strings))) + ) + ) (define string-map (lexpr (proc strings) (list->string (apply map proc (_string-ml strings)))))) @@ -703,7 +707,7 @@ (string-for-each write-char "IBM\n") -(define newline (lambda () (write-char #\newline))) +(define (newline) (write-char #\newline)) (newline) @@ -726,52 +730,73 @@ `(hello ,(+ 1 2) ,@(list 1 2 3) `foo) -(define repeat (macro (count rest) - `(let ((__count__ ,count)) - (while (<= 0 (set! __count__ (- __count__ 1))) ,@rest)))) + +(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 3 (write 'goodbye)) +(repeat (x 3) (write 'goodbye x)) -(define case (macro (test l) - (let* ((_unarrow +(define case + (macro (test l) ; construct the body of the ; case, dealing with the ; lambda version ( => lambda) - - (lambda (l) - (cond ((null? l) l) - ((eq? (car l) '=>) `(( ,(cadr l) __key__))) - (else l)))) - (_case (lambda (l) + + (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 - (cond ((null? l) ()) + (define (_case l) + + (cond ((null? l) ()) ; else case - ((eq? (caar l) 'else) - `((else ,@(_unarrow (cdr (car l)))))) + ((eq? (caar l) 'else) + `((else ,@(_unarrow (cdr (car l)))))) ; regular case - - (else - (cons - `((eqv? ,(caar l) __key__) - ,@(_unarrow (cdr (car l)))) - (_case (cdr l))) - ) - )))) + + (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)))) + `((lambda (__key__) + (cond ,@(_case l))) ,test) + ) + ) (case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) -- cgit v1.2.3 From b9009b3916956db00b7b78bd06fb0df704690eb1 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 2 Dec 2017 23:21:55 -0600 Subject: altos/lisp: use strtof instead of atof atof returns double, strtof returns float. Signed-off-by: Keith Packard --- src/lisp/ao_lisp_read.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index 747963ab..f3b627bb 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -15,6 +15,7 @@ #include "ao_lisp.h" #include "ao_lisp_read.h" #include +#include static const uint16_t lex_classes[128] = { IGNORE, /* ^@ */ @@ -445,7 +446,7 @@ _lex(void) return NUM; } if (isfloat && hasdigit) { - token_float = atof(token_string); + token_float = strtof(token_string, NULL); return FLOAT; } for (u = 0; u < NUM_NAMED_FLOATS; u++) @@ -524,8 +525,7 @@ ao_lisp_read(void) char *string; int cons; int read_state; - ao_poly v; - + ao_poly v = AO_LISP_NIL; cons = 0; read_state = 0; -- cgit v1.2.3 From ed6967cef5d82baacafe1c23229f44d58c838326 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 3 Dec 2017 19:47:03 -0800 Subject: altos/lisp: Split out read debug, add memory validation Split read debug into a separate #define to reduce debug noise Add some memory validation -- validate stash API, and validate cons_free calls. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 42 ++++++++++++++++++++++++++++++++++++---- src/lisp/ao_lisp_builtin.c | 6 +++--- src/lisp/ao_lisp_cons.c | 3 +++ src/lisp/ao_lisp_error.c | 48 ++++++++++++++++++++++++++++++++++++++++------ src/lisp/ao_lisp_eval.c | 6 +++--- src/lisp/ao_lisp_mem.c | 31 ++++++++++++++++++++++++++++++ src/lisp/ao_lisp_read.c | 10 +++++----- 7 files changed, 125 insertions(+), 21 deletions(-) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index 7cd8b5a5..d32e7dcd 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -17,6 +17,9 @@ #define DBG_MEM 0 #define DBG_EVAL 0 +#define DBG_READ 0 +#define DBG_FREE_CONS 0 +#define NDEBUG 1 #include #include @@ -387,6 +390,16 @@ static inline int ao_lisp_poly_type(ao_poly poly) { return type; } +static inline int +ao_lisp_is_cons(ao_poly poly) { + return (ao_lisp_poly_base_type(poly) == AO_LISP_CONS); +} + +static inline int +ao_lisp_is_pair(ao_poly poly) { + return poly != AO_LISP_NIL && (ao_lisp_poly_base_type(poly) == AO_LISP_CONS); +} + static inline struct ao_lisp_cons * ao_lisp_poly_cons(ao_poly poly) { @@ -520,6 +533,11 @@ ao_lisp_alloc(int size); int ao_lisp_collect(uint8_t style); +#if DBG_FREE_CONS +void +ao_lisp_cons_check(struct ao_lisp_cons *cons); +#endif + void ao_lisp_cons_stash(int id, struct ao_lisp_cons *cons); @@ -812,6 +830,12 @@ ao_lisp_stack_eval(void); /* error */ +void +ao_lisp_vprintf(char *format, va_list args); + +void +ao_lisp_printf(char *format, ...); + void ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last); @@ -828,7 +852,7 @@ ao_lisp_error(int error, char *format, ...); /* debugging macros */ -#if DBG_EVAL +#if DBG_EVAL || DBG_READ || DBG_MEM #define DBG_CODE 1 int ao_lisp_stack_depth; #define DBG_DO(a) a @@ -836,8 +860,8 @@ int ao_lisp_stack_depth; #define DBG_IN() (++ao_lisp_stack_depth) #define DBG_OUT() (--ao_lisp_stack_depth) #define DBG_RESET() (ao_lisp_stack_depth = 0) -#define DBG(...) printf(__VA_ARGS__) -#define DBGI(...) do { DBG("%4d: ", __LINE__); DBG_INDENT(); DBG(__VA_ARGS__); } while (0) +#define DBG(...) ao_lisp_printf(__VA_ARGS__) +#define DBGI(...) do { printf("%4d: ", __LINE__); DBG_INDENT(); DBG(__VA_ARGS__); } while (0) #define DBG_CONS(a) ao_lisp_cons_write(ao_lisp_cons_poly(a)) #define DBG_POLY(a) ao_lisp_poly_write(a) #define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_lisp_pool) : -1) @@ -866,6 +890,16 @@ ao_lisp_frames_dump(void) #define DBG_FRAMES() #endif +#if DBG_READ +#define RDBGI(...) DBGI(__VA_ARGS__) +#define RDBG_IN() DBG_IN() +#define RDBG_OUT() DBG_OUT() +#else +#define RDBGI(...) +#define RDBG_IN() +#define RDBG_OUT() +#endif + #define DBG_MEM_START 1 #if DBG_MEM @@ -877,7 +911,7 @@ extern int dbg_move_depth; extern int dbg_mem; -#define MDBG_DO(a) a +#define MDBG_DO(a) DBG_DO(a) #define MDBG_MOVE(...) do { if (dbg_mem) { int d; for (d = 0; d < dbg_move_depth; d++) printf (" "); printf(__VA_ARGS__); } } while (0) #define MDBG_MORE(...) do { if (dbg_mem) printf(__VA_ARGS__); } while (0) #define MDBG_MOVE_IN() (dbg_move_depth++) diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index ad8f4125..fdca0208 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -125,7 +125,7 @@ ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type, ao_poly car = ao_lisp_arg(cons, argc); if ((!car && !nil_ok) || ao_lisp_poly_type(car) != type) - return ao_lisp_error(AO_LISP_INVALID, "%s: invalid type for arg %d", ao_lisp_poly_atom(name)->name, argc); + return ao_lisp_error(AO_LISP_INVALID, "%s: arg %d invalid type %v", ao_lisp_poly_atom(name)->name, argc, car); return _ao_lisp_bool_true; } @@ -226,9 +226,9 @@ ao_lisp_do_setq(struct ao_lisp_cons *cons) return AO_LISP_NIL; name = cons->car; if (ao_lisp_poly_type(name) != AO_LISP_ATOM) - return ao_lisp_error(AO_LISP_INVALID, "set! of non-atom"); + return ao_lisp_error(AO_LISP_INVALID, "set! of non-atom %v", name); if (!ao_lisp_atom_ref(name)) - return ao_lisp_error(AO_LISP_INVALID, "atom not defined"); + return ao_lisp_error(AO_LISP_INVALID, "atom %v not defined", name); return ao_lisp__cons(_ao_lisp_atom_set, ao_lisp__cons(ao_lisp__cons(_ao_lisp_atom_quote, ao_lisp__cons(name, AO_LISP_NIL)), diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index c70aa1ca..06e9d361 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -127,6 +127,9 @@ ao_lisp__cons(ao_poly car, ao_poly cdr) void ao_lisp_cons_free(struct ao_lisp_cons *cons) { +#if DBG_FREE_CONS + ao_lisp_cons_check(cons); +#endif while (cons) { ao_poly cdr = cons->cdr; cons->cdr = ao_lisp_cons_poly(ao_lisp_cons_free_list); diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c index ba135834..7f909487 100644 --- a/src/lisp/ao_lisp_error.c +++ b/src/lisp/ao_lisp_error.c @@ -82,6 +82,43 @@ ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) printf ("}\n"); } +void +ao_lisp_vprintf(char *format, va_list args) +{ + char c; + + while ((c = *format++) != '\0') { + if (c == '%') { + switch (c = *format++) { + case 'v': + ao_lisp_poly_write((ao_poly) va_arg(args, unsigned int)); + 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_lisp_printf(char *format, ...) +{ + va_list args; + va_start(args, format); + ao_lisp_vprintf(format, args); + va_end(args); +} ao_poly ao_lisp_error(int error, char *format, ...) @@ -90,14 +127,13 @@ ao_lisp_error(int error, char *format, ...) ao_lisp_exception |= error; va_start(args, format); - vprintf(format, args); + ao_lisp_vprintf(format, args); + putchar('\n'); va_end(args); - printf("\n"); - printf("Value: "); ao_lisp_poly_write(ao_lisp_v); printf("\n"); + ao_lisp_printf("Value: %v\n", ao_lisp_v); + ao_lisp_printf("Frame: %v\n", ao_lisp_frame_poly(ao_lisp_frame_current)); printf("Stack:\n"); ao_lisp_stack_write(ao_lisp_stack_poly(ao_lisp_stack)); - printf("Globals:\n\t"); - ao_lisp_frame_write(ao_lisp_frame_poly(ao_lisp_frame_global)); - printf("\n"); + ao_lisp_printf("Globals: %v\n", ao_lisp_frame_poly(ao_lisp_frame_global)); return AO_LISP_NIL; } diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index 02329ee6..ced182f6 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -68,7 +68,7 @@ func_type(ao_poly func) static int ao_lisp_eval_sexpr(void) { - DBGI("sexpr: "); DBG_POLY(ao_lisp_v); DBG("\n"); + DBGI("sexpr: %v\n", ao_lisp_v); switch (ao_lisp_poly_type(ao_lisp_v)) { case AO_LISP_CONS: if (ao_lisp_v == AO_LISP_NIL) { @@ -193,8 +193,8 @@ ao_lisp_eval_formal(void) ao_lisp_stack->sexprs = prev->sexprs; DBGI(".. start macro\n"); - DBGI(".. sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI(".. values "); DBG_POLY(ao_lisp_stack->values); DBG("\n"); + DBGI("\t.. sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); + DBGI("\t.. values "); DBG_POLY(ao_lisp_stack->values); DBG("\n"); DBG_FRAMES(); /* fall through ... */ diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c index 3a704380..5471b137 100644 --- a/src/lisp/ao_lisp_mem.c +++ b/src/lisp/ao_lisp_mem.c @@ -16,6 +16,7 @@ #include "ao_lisp.h" #include +#include #ifdef AO_LISP_MAKE_CONST @@ -623,6 +624,32 @@ ao_lisp_collect(uint8_t style) return AO_LISP_POOL - ao_lisp_top; } +#if DBG_FREE_CONS +void +ao_lisp_cons_check(struct ao_lisp_cons *cons) +{ + ao_poly cdr; + int offset; + + chunk_low = 0; + reset_chunks(); + walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref); + while (cons) { + if (!AO_LISP_IS_POOL(cons)) + break; + offset = pool_offset(cons); + if (busy(ao_lisp_busy, offset)) { + ao_lisp_printf("cons at %p offset %d poly %d is busy\n\t%v\n", cons, offset, ao_lisp_cons_poly(cons), ao_lisp_cons_poly(cons)); + abort(); + } + cdr = cons->cdr; + if (!ao_lisp_is_pair(cdr)) + break; + cons = ao_lisp_poly_cons(cdr); + } +} +#endif + /* * Mark interfaces for objects */ @@ -883,6 +910,7 @@ ao_lisp_alloc(int size) void ao_lisp_cons_stash(int id, struct ao_lisp_cons *cons) { + assert(save_cons[id] == 0); save_cons[id] = cons; } @@ -897,6 +925,7 @@ ao_lisp_cons_fetch(int id) void ao_lisp_poly_stash(int id, ao_poly poly) { + assert(save_poly[id] == AO_LISP_NIL); save_poly[id] = poly; } @@ -911,6 +940,7 @@ ao_lisp_poly_fetch(int id) void ao_lisp_string_stash(int id, char *string) { + assert(save_string[id] == NULL); save_string[id] = string; } @@ -925,6 +955,7 @@ ao_lisp_string_fetch(int id) void ao_lisp_frame_stash(int id, struct ao_lisp_frame *frame) { + assert(save_frame[id] == NULL); save_frame[id] = frame; } diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c index f3b627bb..0ca12a81 100644 --- a/src/lisp/ao_lisp_read.c +++ b/src/lisp/ao_lisp_read.c @@ -464,7 +464,7 @@ _lex(void) static inline int lex(void) { int parse_token = _lex(); - DBGI("token %d (%s)\n", parse_token, token_string); + RDBGI("token %d (%s)\n", parse_token, token_string); return parse_token; } @@ -481,8 +481,8 @@ struct ao_lisp_cons *ao_lisp_read_stack; static int push_read_stack(int cons, int read_state) { - DBGI("push read stack %p 0x%x\n", ao_lisp_read_cons, read_state); - DBG_IN(); + RDBGI("push read stack %p 0x%x\n", ao_lisp_read_cons, read_state); + RDBG_IN(); if (cons) { ao_lisp_read_stack = ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_read_cons), ao_lisp__cons(ao_lisp_int_poly(read_state), @@ -513,8 +513,8 @@ pop_read_stack(int cons) ao_lisp_read_cons_tail = 0; ao_lisp_read_stack = 0; } - DBG_OUT(); - DBGI("pop read stack %p %d\n", ao_lisp_read_cons, read_state); + RDBG_OUT(); + RDBGI("pop read stack %p %d\n", ao_lisp_read_cons, read_state); return read_state; } -- cgit v1.2.3 From 32ab76c3049b913283caafbaef873754d76dc9d4 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 3 Dec 2017 19:49:20 -0800 Subject: altos/lisp: Check only cdr base type when moving cons cells The cdr may have moved, so we can't look at the target object type. Fortunately, the base type encoded in the reference itself is sufficient to check for a non-cons cdr. Signed-off-by: Keith Packard --- src/lisp/ao_lisp_cons.c | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c index 06e9d361..d3b97383 100644 --- a/src/lisp/ao_lisp_cons.c +++ b/src/lisp/ao_lisp_cons.c @@ -58,8 +58,8 @@ static void cons_move(void *addr) cdr = cons->cdr; if (!cdr) break; - if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) { - (void) ao_lisp_poly_move(&cons->cdr, 1); + if (ao_lisp_poly_base_type(cdr) != AO_LISP_CONS) { + (void) ao_lisp_poly_move(&cons->cdr, 0); break; } c = ao_lisp_poly_cons(cdr); @@ -95,8 +95,8 @@ ao_lisp_cons_cons(ao_poly car, ao_poly cdr) ao_lisp_poly_stash(0, car); ao_lisp_poly_stash(1, cdr); cons = ao_lisp_alloc(sizeof (struct ao_lisp_cons)); - car = ao_lisp_poly_fetch(0); cdr = ao_lisp_poly_fetch(1); + car = ao_lisp_poly_fetch(0); if (!cons) return NULL; } -- cgit v1.2.3 From a1d013ab8cc508d4e17ae8876bc5465d1a2dfc1e Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 3 Dec 2017 19:52:11 -0800 Subject: altos/lisp: Fix stash usage across frame allocation Must un-stash before allocation failure check. Use frame_stash instead of poly_stash for frames. Signed-off-by: Keith Packard --- src/lisp/ao_lisp_frame.c | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c index 13a68b38..c285527e 100644 --- a/src/lisp/ao_lisp_frame.c +++ b/src/lisp/ao_lisp_frame.c @@ -225,9 +225,11 @@ ao_lisp_frame_new(int num) frame->num = 0; frame->prev = AO_LISP_NIL; frame->vals = AO_LISP_NIL; - ao_lisp_poly_stash(0, ao_lisp_frame_poly(frame)); + ao_lisp_frame_stash(0, frame); vals = ao_lisp_frame_vals_new(num); - frame = ao_lisp_poly_frame(ao_lisp_poly_fetch(0)); + frame = ao_lisp_frame_fetch(0); + if (!vals) + return NULL; frame->vals = ao_lisp_frame_vals_poly(vals); frame->num = num; } @@ -271,9 +273,9 @@ ao_lisp_frame_realloc(struct ao_lisp_frame *frame, int new_num) return frame; ao_lisp_frame_stash(0, frame); new_vals = ao_lisp_frame_vals_new(new_num); + frame = ao_lisp_frame_fetch(0); if (!new_vals) return NULL; - frame = ao_lisp_frame_fetch(0); vals = ao_lisp_poly_frame_vals(frame->vals); copy = new_num; if (copy > frame->num) @@ -303,15 +305,14 @@ ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val) ao_poly *ref = frame ? ao_lisp_frame_ref(frame, atom) : NULL; if (!ref) { - int f; + int f = frame->num; ao_lisp_poly_stash(0, atom); ao_lisp_poly_stash(1, val); - f = frame->num; frame = ao_lisp_frame_realloc(frame, f + 1); + val = ao_lisp_poly_fetch(1); + atom = ao_lisp_poly_fetch(0); if (!frame) return AO_LISP_NIL; - atom = ao_lisp_poly_fetch(0); - val = ao_lisp_poly_fetch(1); ao_lisp_frame_bind(frame, frame->num - 1, atom, val); } else *ref = val; -- cgit v1.2.3 From 9dbc686ad7d3289dc0f9bcf4a973f71100e02ded Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 3 Dec 2017 19:54:18 -0800 Subject: altos/lisp: Switch to scheme formal syntax for varargs Scheme uses bare symbols to indicate a varargs parameter; any bare (i.e., not wrapped in a cons cell) parameter will get the 'rest' of the parameter list. This works for lambdas, nlambdas and macros. As a result, the 'lexpr' form has been removed as it is equivalent to a lambda with a varargs formal. Signed-off-by: Keith Packard --- src/lisp/ao_lisp.h | 2 - src/lisp/ao_lisp_builtin.c | 2 - src/lisp/ao_lisp_builtin.txt | 33 ++++++------ src/lisp/ao_lisp_const.lisp | 90 +++++++++++++++++---------------- src/lisp/ao_lisp_eval.c | 14 +++--- src/lisp/ao_lisp_lambda.c | 114 +++++++++++++++++++++++------------------- src/lisp/ao_lisp_make_builtin | 2 - src/lisp/ao_lisp_make_const.c | 8 +-- 8 files changed, 140 insertions(+), 125 deletions(-) diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h index d32e7dcd..b5e03b1e 100644 --- a/src/lisp/ao_lisp.h +++ b/src/lisp/ao_lisp.h @@ -297,7 +297,6 @@ extern ao_poly ao_lisp_v; #define AO_LISP_FUNC_LAMBDA 0 #define AO_LISP_FUNC_NLAMBDA 1 #define AO_LISP_FUNC_MACRO 2 -#define AO_LISP_FUNC_LEXPR 3 #define AO_LISP_FUNC_FREE_ARGS 0x80 #define AO_LISP_FUNC_MASK 0x7f @@ -305,7 +304,6 @@ extern ao_poly ao_lisp_v; #define AO_LISP_FUNC_F_LAMBDA (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_LAMBDA) #define AO_LISP_FUNC_F_NLAMBDA (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_NLAMBDA) #define AO_LISP_FUNC_F_MACRO (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_MACRO) -#define AO_LISP_FUNC_F_LEXPR (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_LEXPR) struct ao_lisp_builtin { uint8_t type; diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c index fdca0208..6af2a6ea 100644 --- a/src/lisp/ao_lisp_builtin.c +++ b/src/lisp/ao_lisp_builtin.c @@ -50,7 +50,6 @@ char *ao_lisp_args_name(uint8_t args) { args &= AO_LISP_FUNC_MASK; switch (args) { case AO_LISP_FUNC_LAMBDA: return ao_lisp_poly_atom(_ao_lisp_atom_lambda)->name; - case AO_LISP_FUNC_LEXPR: return ao_lisp_poly_atom(_ao_lisp_atom_lexpr)->name; case AO_LISP_FUNC_NLAMBDA: return ao_lisp_poly_atom(_ao_lisp_atom_nlambda)->name; case AO_LISP_FUNC_MACRO: return ao_lisp_poly_atom(_ao_lisp_atom_macro)->name; default: return "???"; @@ -70,7 +69,6 @@ ao_lisp_builtin_name(enum ao_lisp_builtin_id b) { static const ao_poly ao_lisp_args_atoms[] = { [AO_LISP_FUNC_LAMBDA] = _ao_lisp_atom_lambda, - [AO_LISP_FUNC_LEXPR] = _ao_lisp_atom_lexpr, [AO_LISP_FUNC_NLAMBDA] = _ao_lisp_atom_nlambda, [AO_LISP_FUNC_MACRO] = _ao_lisp_atom_macro, }; diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt index abed7afe..cb65e252 100644 --- a/src/lisp/ao_lisp_builtin.txt +++ b/src/lisp/ao_lisp_builtin.txt @@ -1,7 +1,6 @@ f_lambda eval f_lambda read nlambda lambda -nlambda lexpr nlambda nlambda nlambda macro f_lambda car @@ -19,25 +18,25 @@ f_lambda def nlambda cond nlambda begin nlambda while -f_lexpr write -f_lexpr display -f_lexpr plus + -f_lexpr minus - -f_lexpr times * -f_lexpr divide / -f_lexpr modulo modulo % -f_lexpr remainder -f_lexpr quotient -f_lexpr equal = eq? eqv? -f_lexpr less < -f_lexpr greater > -f_lexpr less_equal <= -f_lexpr greater_equal >= +f_lambda write +f_lambda display +f_lambda plus + +f_lambda minus - +f_lambda times * +f_lambda divide / +f_lambda modulo modulo % +f_lambda remainder +f_lambda quotient +f_lambda equal = eq? eqv? +f_lambda less < +f_lambda greater > +f_lambda less_equal <= +f_lambda greater_equal >= f_lambda list_to_string list->string f_lambda string_to_list string->list f_lambda flush_output flush-output f_lambda delay -f_lexpr led +f_lambda led f_lambda save f_lambda restore f_lambda call_cc call-with-current-continuation call/cc @@ -56,7 +55,7 @@ f_lambda symbol_to_string symbol->string f_lambda string_to_symbol string->symbol f_lambda stringp string? f_lambda procedurep procedure? -lexpr apply +lambda apply f_lambda read_char read-char f_lambda write_char write-char f_lambda exit diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp index bb413e7d..422bdd63 100644 --- a/src/lisp/ao_lisp_const.lisp +++ b/src/lisp/ao_lisp_const.lisp @@ -14,10 +14,10 @@ ; Lisp code placed in ROM ; return a list containing all of the arguments -(def (quote list) (lexpr (l) l)) +(def (quote list) (lambda l l)) (def (quote def!) - (macro (name value rest) + (macro (name value) (list def (list quote name) @@ -27,7 +27,7 @@ (begin (def! append - (lexpr (args) + (lambda args (def! append-list (lambda (a b) (cond ((null? a) b) @@ -55,7 +55,7 @@ (begin (def! or - (macro (l) + (macro l (def! _or (lambda (l) (cond ((null? l) #f) @@ -84,7 +84,7 @@ (begin (def! and - (macro (l) + (macro l (def! _and (lambda (l) (cond ((null? l) #t) @@ -102,7 +102,9 @@ ) ) ) - (_and l))) + (_and l) + ) + ) 'and) ; execute to resolve macros @@ -111,7 +113,7 @@ (begin (def! quasiquote - (macro (x rest) + (macro (x) (def! constant? ; A constant value is either a pair starting with quote, ; or anything which is neither a pair nor a symbol @@ -225,10 +227,12 @@ ) ) ) - (expand-quasiquote x 0) + (def! result (expand-quasiquote x 0)) + result ) ) 'quasiquote) + ; ; Define a variable without returning the value ; Useful when defining functions to avoid @@ -241,7 +245,7 @@ (begin (def! define - (macro (first rest) + (macro (first . rest) ; check for alternate lambda definition form (cond ((list? first) @@ -257,9 +261,11 @@ (set! rest (car rest)) ) ) - `(begin - (def (quote ,first) ,rest) - (quote ,first)) + (def! result `(,begin + (,def (,quote ,first) ,rest) + (,quote ,first)) + ) + result ) ) 'define @@ -275,22 +281,11 @@ (define (caddr l) (car (cdr (cdr l)))) -(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)) - ) - ; (if ) ; (if ,value 0))) +(define positive? (macro (value) `(> ,value 0))) (positive? 12) (positive? -12) -(define negative? (macro (value rest) `(< ,value 0))) +(define negative? (macro (value) `(< ,value 0))) (negative? 12) (negative? -12) @@ -330,7 +325,7 @@ (abs 12) (abs -12) -(define max (lexpr (first rest) +(define max (lambda (first . rest) (while (not (null? rest)) (cond ((< first (car rest)) (set! first (car rest))) @@ -343,7 +338,7 @@ (max 1 2 3) (max 3 2 1) -(define min (lexpr (first rest) +(define min (lambda (first . rest) (while (not (null? rest)) (cond ((> first (car rest)) (set! first (car rest))) @@ -371,6 +366,17 @@ (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 @@ -391,7 +397,7 @@ ; (let ((x 1) (y)) (set! y (+ x 1)) y) (define let - (macro (vars exprs) + (macro (vars . exprs) (define (make-names vars) (cond ((not (null? vars)) (cons (car (car vars)) @@ -445,7 +451,7 @@ ; (let* ((x 1) (y)) (set! y (+ x 1)) y) (define let* - (macro (vars exprs) + (macro (vars . exprs) ; ; make the list of names in the let @@ -497,11 +503,11 @@ (let* ((x 1) (y x)) (+ x y)) -(define when (macro (test l) `(cond (,test ,@l)))) +(define when (macro (test . l) `(cond (,test ,@l)))) (when #t (write 'when)) -(define unless (macro (test l) `(cond ((not ,test) ,@l)))) +(define unless (macro (test . l) `(cond ((not ,test) ,@l)))) (unless #f (write 'unless)) @@ -542,7 +548,7 @@ (equal? '(a b c) '(a b c)) (equal? '(a b c) '(a b b)) -(define member (lexpr (obj list test?) +(define member (lambda (obj list . test?) (cond ((null? list) #f ) @@ -651,13 +657,13 @@ (char-downcase #\0) (char-downcase #\space) -(define string (lexpr (chars) (list->string chars))) +(define string (lambda chars (list->string chars))) (display "apply\n") (apply cons '(a b)) (define map - (lexpr (proc lists) + (lambda (proc . lists) (define (args lists) (cond ((null? lists) ()) (else @@ -685,7 +691,7 @@ (map cadr '((a b) (d e) (g h))) -(define for-each (lexpr (proc lists) +(define for-each (lambda (proc . lists) (apply map proc lists) #t)) @@ -697,12 +703,12 @@ ) ) -(define string-map (lexpr (proc 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 (lexpr (proc strings) +(define string-for-each (lambda (proc . strings) (apply for-each proc (_string-ml strings)))) (string-for-each write-char "IBM\n") @@ -732,7 +738,7 @@ (define repeat - (macro (count rest) + (macro (count . rest) (define counter '__count__) (cond ((pair? count) (set! counter (car count)) @@ -754,7 +760,7 @@ (repeat (x 3) (write 'goodbye x)) (define case - (macro (test l) + (macro (test . l) ; construct the body of the ; case, dealing with the ; lambda version ( => lambda) @@ -800,7 +806,7 @@ (case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else")) -;(define number->string (lexpr (arg opt) +;(define number->string (lambda (arg . opt) ; (let ((base (if (null? opt) 10 (car opt))) ; ; diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c index ced182f6..c3dd2ed2 100644 --- a/src/lisp/ao_lisp_eval.c +++ b/src/lisp/ao_lisp_eval.c @@ -152,9 +152,9 @@ ao_lisp_eval_val(void) * A formal has been computed. * * If this is the first formal, then check to see if we've got a - * lamda/lexpr or macro/nlambda. + * lamda, macro or nlambda. * - * For lambda/lexpr, go compute another formal. This will terminate + * 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 @@ -177,8 +177,7 @@ ao_lisp_eval_formal(void) if (!ao_lisp_stack->values) { switch (func_type(ao_lisp_v)) { case AO_LISP_FUNC_LAMBDA: - case AO_LISP_FUNC_LEXPR: - DBGI(".. lambda or lexpr\n"); + DBGI(".. lambda\n"); break; case AO_LISP_FUNC_MACRO: /* Evaluate the result once more */ @@ -272,8 +271,11 @@ ao_lisp_eval_exec(void) DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n"); }); builtin = ao_lisp_poly_builtin(ao_lisp_v); - if (builtin && builtin->args & AO_LISP_FUNC_FREE_ARGS && !ao_lisp_stack_marked(ao_lisp_stack) && !ao_lisp_skip_cons_free) - ao_lisp_cons_free(ao_lisp_poly_cons(ao_lisp_stack->values)); + if (builtin && (builtin->args & AO_LISP_FUNC_FREE_ARGS) && !ao_lisp_stack_marked(ao_lisp_stack) && !ao_lisp_skip_cons_free) { + struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); + ao_lisp_stack->values = AO_LISP_NIL; + ao_lisp_cons_free(cons); + } ao_lisp_v = v; ao_lisp_stack->values = AO_LISP_NIL; diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c index 71aebed0..e72281db 100644 --- a/src/lisp/ao_lisp_lambda.c +++ b/src/lisp/ao_lisp_lambda.c @@ -68,26 +68,33 @@ ao_lisp_lambda_write(ao_poly poly) ao_poly ao_lisp_lambda_alloc(struct ao_lisp_cons *code, int args) { + struct ao_lisp_lambda *lambda; + ao_poly formal; + struct ao_lisp_cons *cons; + + formal = ao_lisp_arg(code, 0); + while (formal != AO_LISP_NIL) { + switch (ao_lisp_poly_type(formal)) { + case AO_LISP_CONS: + cons = ao_lisp_poly_cons(formal); + if (ao_lisp_poly_type(cons->car) != AO_LISP_ATOM) + return ao_lisp_error(AO_LISP_INVALID, "formal %p is not atom", cons->car); + formal = cons->cdr; + break; + case AO_LISP_ATOM: + formal = AO_LISP_NIL; + break; + default: + return ao_lisp_error(AO_LISP_INVALID, "formal %p is not atom", formal); + } + } + ao_lisp_cons_stash(0, code); - struct ao_lisp_lambda *lambda = ao_lisp_alloc(sizeof (struct ao_lisp_lambda)); + lambda = ao_lisp_alloc(sizeof (struct ao_lisp_lambda)); code = ao_lisp_cons_fetch(0); - struct ao_lisp_cons *arg; - int f; - if (!lambda) return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_lambda, code, 0, AO_LISP_CONS, 1)) - return AO_LISP_NIL; - f = 0; - arg = ao_lisp_poly_cons(ao_lisp_arg(code, 0)); - while (arg) { - if (ao_lisp_poly_type(arg->car) != AO_LISP_ATOM) - return ao_lisp_error(AO_LISP_INVALID, "formal %d is not an atom", f); - arg = ao_lisp_poly_cons(arg->cdr); - f++; - } - lambda->type = AO_LISP_LAMBDA; lambda->args = args; lambda->code = ao_lisp_cons_poly(code); @@ -103,12 +110,6 @@ ao_lisp_do_lambda(struct ao_lisp_cons *cons) return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LAMBDA); } -ao_poly -ao_lisp_do_lexpr(struct ao_lisp_cons *cons) -{ - return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LEXPR); -} - ao_poly ao_lisp_do_nlambda(struct ao_lisp_cons *cons) { @@ -127,67 +128,78 @@ ao_lisp_lambda_eval(void) struct ao_lisp_lambda *lambda = ao_lisp_poly_lambda(ao_lisp_v); struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); struct ao_lisp_cons *code = ao_lisp_poly_cons(lambda->code); - struct ao_lisp_cons *args = ao_lisp_poly_cons(ao_lisp_arg(code, 0)); + ao_poly formals; struct ao_lisp_frame *next_frame; int args_wanted; + ao_poly varargs = AO_LISP_NIL; int args_provided; int f; struct ao_lisp_cons *vals; DBGI("lambda "); DBG_POLY(ao_lisp_lambda_poly(lambda)); DBG("\n"); - args_wanted = ao_lisp_cons_length(args); + args_wanted = 0; + for (formals = ao_lisp_arg(code, 0); + ao_lisp_is_pair(formals); + formals = ao_lisp_poly_cons(formals)->cdr) + ++args_wanted; + if (formals != AO_LISP_NIL) { + if (ao_lisp_poly_type(formals) != AO_LISP_ATOM) + return ao_lisp_error(AO_LISP_INVALID, "bad lambda form"); + varargs = formals; + } /* Create a frame to hold the variables */ args_provided = ao_lisp_cons_length(cons) - 1; - if (lambda->args == AO_LISP_FUNC_LAMBDA) { + if (varargs == AO_LISP_NIL) { if (args_wanted != args_provided) return ao_lisp_error(AO_LISP_INVALID, "need %d args, got %d", args_wanted, args_provided); } else { - if (args_provided < args_wanted - 1) + if (args_provided < args_wanted) return ao_lisp_error(AO_LISP_INVALID, "need at least %d args, got %d", args_wanted, args_provided); } - next_frame = ao_lisp_frame_new(args_wanted); + ao_lisp_poly_stash(1, varargs); + next_frame = ao_lisp_frame_new(args_wanted + (varargs != AO_LISP_NIL)); + varargs = ao_lisp_poly_fetch(1); + if (!next_frame) + return AO_LISP_NIL; /* Re-fetch all of the values in case something moved */ lambda = ao_lisp_poly_lambda(ao_lisp_v); cons = ao_lisp_poly_cons(ao_lisp_stack->values); code = ao_lisp_poly_cons(lambda->code); - args = ao_lisp_poly_cons(ao_lisp_arg(code, 0)); + formals = ao_lisp_arg(code, 0); vals = ao_lisp_poly_cons(cons->cdr); next_frame->prev = lambda->frame; ao_lisp_frame_current = next_frame; ao_lisp_stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); - switch (lambda->args) { - case AO_LISP_FUNC_LAMBDA: - for (f = 0; f < args_wanted; f++) { - DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); - ao_lisp_frame_bind(next_frame, f, args->car, vals->car); - args = ao_lisp_poly_cons(args->cdr); - vals = ao_lisp_poly_cons(vals->cdr); - } - if (!ao_lisp_stack_marked(ao_lisp_stack)) + for (f = 0; f < args_wanted; f++) { + struct ao_lisp_cons *arg = ao_lisp_poly_cons(formals); + DBGI("bind "); DBG_POLY(arg->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); + ao_lisp_frame_bind(next_frame, f, arg->car, vals->car); + formals = arg->cdr; + vals = ao_lisp_poly_cons(vals->cdr); + } + if (varargs) { + DBGI("bind "); DBG_POLY(varargs); DBG(" = "); DBG_POLY(ao_lisp_cons_poly(vals)); DBG("\n"); + /* + * Bind the rest of the arguments to the final parameter + */ + ao_lisp_frame_bind(next_frame, f, varargs, ao_lisp_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_LISP_FUNC_LAMBDA && !ao_lisp_stack_marked(ao_lisp_stack)) { + ao_lisp_stack->values = AO_LISP_NIL; ao_lisp_cons_free(cons); - cons = NULL; - break; - case AO_LISP_FUNC_LEXPR: - case AO_LISP_FUNC_NLAMBDA: - case AO_LISP_FUNC_MACRO: - for (f = 0; f < args_wanted - 1; f++) { - DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); - ao_lisp_frame_bind(next_frame, f, args->car, vals->car); - args = ao_lisp_poly_cons(args->cdr); - vals = ao_lisp_poly_cons(vals->cdr); } - DBGI("bind "); DBG_POLY(args->car); DBG(" = "); DBG_POLY(ao_lisp_cons_poly(vals)); DBG("\n"); - ao_lisp_frame_bind(next_frame, f, args->car, ao_lisp_cons_poly(vals)); - break; - default: - break; } DBGI("eval frame: "); DBG_POLY(ao_lisp_frame_poly(next_frame)); DBG("\n"); DBG_STACK(); diff --git a/src/lisp/ao_lisp_make_builtin b/src/lisp/ao_lisp_make_builtin index c4ba9d94..783ab378 100644 --- a/src/lisp/ao_lisp_make_builtin +++ b/src/lisp/ao_lisp_make_builtin @@ -9,10 +9,8 @@ typedef struct { string[string] type_map = { "lambda" => "LAMBDA", "nlambda" => "NLAMBDA", - "lexpr" => "LEXPR", "macro" => "MACRO", "f_lambda" => "F_LAMBDA", - "f_lexpr" => "F_LEXPR", "atom" => "atom", }; diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c index f3ea6be0..6e4b411e 100644 --- a/src/lisp/ao_lisp_make_const.c +++ b/src/lisp/ao_lisp_make_const.c @@ -191,6 +191,7 @@ ao_has_macro(ao_poly p) struct ao_lisp_cons *cons; struct ao_lisp_lambda *lambda; ao_poly m; + ao_poly list; if (p == AO_LISP_NIL) return AO_LISP_NIL; @@ -206,15 +207,16 @@ ao_has_macro(ao_poly p) if ((p = ao_is_macro(cons->car))) break; - cons = ao_lisp_poly_cons(cons->cdr); + list = cons->cdr; p = AO_LISP_NIL; - while (cons) { + while (list != AO_LISP_NIL && ao_lisp_poly_type(list) == AO_LISP_CONS) { + cons = ao_lisp_poly_cons(list); m = ao_has_macro(cons->car); if (m) { p = m; break; } - cons = ao_lisp_poly_cons(cons->cdr); + list = cons->cdr; } break; -- cgit v1.2.3 From 195cbeec19a6a44f309a9040d727d37fe4e2ec97 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 5 Dec 2017 10:29:13 -0800 Subject: altos/scheme: Rename to 'scheme', clean up build Constant block is now built in a subdir to avoid messing up source directory. Renamed to ao_scheme to reflect language target. Signed-off-by: Keith Packard --- src/lisp/.gitignore | 3 - src/lisp/Makefile | 24 - src/lisp/Makefile-inc | 24 - src/lisp/Makefile-lisp | 4 - src/lisp/README | 11 - src/lisp/ao_lisp.h | 928 --------------------------------- src/lisp/ao_lisp_atom.c | 159 ------ src/lisp/ao_lisp_bool.c | 73 --- src/lisp/ao_lisp_builtin.c | 868 ------------------------------- src/lisp/ao_lisp_builtin.txt | 68 --- src/lisp/ao_lisp_cons.c | 184 ------- src/lisp/ao_lisp_const.lisp | 813 ----------------------------- src/lisp/ao_lisp_error.c | 139 ----- src/lisp/ao_lisp_eval.c | 578 --------------------- src/lisp/ao_lisp_float.c | 148 ------ src/lisp/ao_lisp_frame.c | 330 ------------ src/lisp/ao_lisp_int.c | 79 --- src/lisp/ao_lisp_lambda.c | 208 -------- src/lisp/ao_lisp_lex.c | 16 - src/lisp/ao_lisp_make_builtin | 190 ------- src/lisp/ao_lisp_make_const.c | 395 -------------- src/lisp/ao_lisp_mem.c | 968 ----------------------------------- src/lisp/ao_lisp_os.h | 63 --- src/lisp/ao_lisp_poly.c | 118 ----- src/lisp/ao_lisp_read.c | 655 ------------------------ src/lisp/ao_lisp_read.h | 58 --- src/lisp/ao_lisp_rep.c | 36 -- src/lisp/ao_lisp_save.c | 77 --- src/lisp/ao_lisp_stack.c | 280 ---------- src/lisp/ao_lisp_string.c | 161 ------ src/scheme/.gitignore | 2 + src/scheme/Makefile | 16 + src/scheme/Makefile-inc | 24 + src/scheme/Makefile-scheme | 4 + src/scheme/README | 10 + src/scheme/ao_scheme.h | 928 +++++++++++++++++++++++++++++++++ src/scheme/ao_scheme_atom.c | 167 ++++++ src/scheme/ao_scheme_bool.c | 73 +++ src/scheme/ao_scheme_builtin.c | 868 +++++++++++++++++++++++++++++++ src/scheme/ao_scheme_builtin.txt | 68 +++ src/scheme/ao_scheme_cons.c | 201 ++++++++ src/scheme/ao_scheme_const.lisp | 813 +++++++++++++++++++++++++++++ src/scheme/ao_scheme_error.c | 139 +++++ src/scheme/ao_scheme_eval.c | 578 +++++++++++++++++++++ src/scheme/ao_scheme_float.c | 148 ++++++ src/scheme/ao_scheme_frame.c | 330 ++++++++++++ src/scheme/ao_scheme_int.c | 79 +++ src/scheme/ao_scheme_lambda.c | 208 ++++++++ src/scheme/ao_scheme_lex.c | 16 + src/scheme/ao_scheme_make_builtin | 190 +++++++ src/scheme/ao_scheme_make_const.c | 395 ++++++++++++++ src/scheme/ao_scheme_mem.c | 968 +++++++++++++++++++++++++++++++++++ src/scheme/ao_scheme_poly.c | 118 +++++ src/scheme/ao_scheme_read.c | 655 ++++++++++++++++++++++++ src/scheme/ao_scheme_read.h | 58 +++ src/scheme/ao_scheme_rep.c | 36 ++ src/scheme/ao_scheme_save.c | 77 +++ src/scheme/ao_scheme_stack.c | 280 ++++++++++ src/scheme/ao_scheme_string.c | 161 ++++++ src/scheme/make-const/.gitignore | 1 + src/scheme/make-const/Makefile | 26 + src/scheme/make-const/ao_scheme_os.h | 63 +++ src/test/ao_lisp_os.h | 68 --- src/test/ao_lisp_test.c | 134 ----- src/test/ao_scheme_os.h | 68 +++ src/test/ao_scheme_test.c | 134 +++++ 66 files changed, 7902 insertions(+), 7860 deletions(-) delete mode 100644 src/lisp/.gitignore delete mode 100644 src/lisp/Makefile delete mode 100644 src/lisp/Makefile-inc delete mode 100644 src/lisp/Makefile-lisp delete mode 100644 src/lisp/README delete mode 100644 src/lisp/ao_lisp.h delete mode 100644 src/lisp/ao_lisp_atom.c delete mode 100644 src/lisp/ao_lisp_bool.c delete mode 100644 src/lisp/ao_lisp_builtin.c delete mode 100644 src/lisp/ao_lisp_builtin.txt delete mode 100644 src/lisp/ao_lisp_cons.c delete mode 100644 src/lisp/ao_lisp_const.lisp delete mode 100644 src/lisp/ao_lisp_error.c delete mode 100644 src/lisp/ao_lisp_eval.c delete mode 100644 src/lisp/ao_lisp_float.c delete mode 100644 src/lisp/ao_lisp_frame.c delete mode 100644 src/lisp/ao_lisp_int.c delete mode 100644 src/lisp/ao_lisp_lambda.c delete mode 100644 src/lisp/ao_lisp_lex.c delete mode 100644 src/lisp/ao_lisp_make_builtin delete mode 100644 src/lisp/ao_lisp_make_const.c delete mode 100644 src/lisp/ao_lisp_mem.c delete mode 100644 src/lisp/ao_lisp_os.h delete mode 100644 src/lisp/ao_lisp_poly.c delete mode 100644 src/lisp/ao_lisp_read.c delete mode 100644 src/lisp/ao_lisp_read.h delete mode 100644 src/lisp/ao_lisp_rep.c delete mode 100644 src/lisp/ao_lisp_save.c delete mode 100644 src/lisp/ao_lisp_stack.c delete mode 100644 src/lisp/ao_lisp_string.c create mode 100644 src/scheme/.gitignore create mode 100644 src/scheme/Makefile create mode 100644 src/scheme/Makefile-inc create mode 100644 src/scheme/Makefile-scheme create mode 100644 src/scheme/README create mode 100644 src/scheme/ao_scheme.h create mode 100644 src/scheme/ao_scheme_atom.c create mode 100644 src/scheme/ao_scheme_bool.c create mode 100644 src/scheme/ao_scheme_builtin.c create mode 100644 src/scheme/ao_scheme_builtin.txt create mode 100644 src/scheme/ao_scheme_cons.c create mode 100644 src/scheme/ao_scheme_const.lisp create mode 100644 src/scheme/ao_scheme_error.c create mode 100644 src/scheme/ao_scheme_eval.c create mode 100644 src/scheme/ao_scheme_float.c create mode 100644 src/scheme/ao_scheme_frame.c create mode 100644 src/scheme/ao_scheme_int.c create mode 100644 src/scheme/ao_scheme_lambda.c create mode 100644 src/scheme/ao_scheme_lex.c create mode 100644 src/scheme/ao_scheme_make_builtin create mode 100644 src/scheme/ao_scheme_make_const.c create mode 100644 src/scheme/ao_scheme_mem.c create mode 100644 src/scheme/ao_scheme_poly.c create mode 100644 src/scheme/ao_scheme_read.c create mode 100644 src/scheme/ao_scheme_read.h create mode 100644 src/scheme/ao_scheme_rep.c create mode 100644 src/scheme/ao_scheme_save.c create mode 100644 src/scheme/ao_scheme_stack.c create mode 100644 src/scheme/ao_scheme_string.c create mode 100644 src/scheme/make-const/.gitignore create mode 100644 src/scheme/make-const/Makefile create mode 100644 src/scheme/make-const/ao_scheme_os.h delete mode 100644 src/test/ao_lisp_os.h delete mode 100644 src/test/ao_lisp_test.c create mode 100644 src/test/ao_scheme_os.h create mode 100644 src/test/ao_scheme_test.c diff --git a/src/lisp/.gitignore b/src/lisp/.gitignore deleted file mode 100644 index 1faa9b67..00000000 --- a/src/lisp/.gitignore +++ /dev/null @@ -1,3 +0,0 @@ -ao_lisp_make_const -ao_lisp_const.h -ao_lisp_builtin.h diff --git a/src/lisp/Makefile b/src/lisp/Makefile deleted file mode 100644 index 05f54550..00000000 --- a/src/lisp/Makefile +++ /dev/null @@ -1,24 +0,0 @@ -all: ao_lisp_builtin.h ao_lisp_const.h - -clean: - rm -f ao_lisp_const.h ao_lisp_builtin.h $(OBJS) ao_lisp_make_const - -ao_lisp_const.h: ao_lisp_const.lisp ao_lisp_make_const - ./ao_lisp_make_const -o $@ ao_lisp_const.lisp - -ao_lisp_builtin.h: ao_lisp_make_builtin ao_lisp_builtin.txt - nickle ./ao_lisp_make_builtin ao_lisp_builtin.txt > $@ - -include Makefile-inc -SRCS=$(LISP_SRCS) ao_lisp_make_const.c - -HDRS=$(LISP_HDRS) - -OBJS=$(SRCS:.c=.o) - -CFLAGS=-DAO_LISP_MAKE_CONST -O0 -g -I. -Wall -Wextra -no-pie - -ao_lisp_make_const: $(OBJS) - $(CC) $(CFLAGS) -o $@ $(OBJS) -lm - -$(OBJS): $(HDRS) diff --git a/src/lisp/Makefile-inc b/src/lisp/Makefile-inc deleted file mode 100644 index a097f1be..00000000 --- a/src/lisp/Makefile-inc +++ /dev/null @@ -1,24 +0,0 @@ -LISP_SRCS=\ - ao_lisp_mem.c \ - ao_lisp_cons.c \ - ao_lisp_string.c \ - ao_lisp_atom.c \ - ao_lisp_int.c \ - ao_lisp_poly.c \ - ao_lisp_bool.c \ - ao_lisp_float.c \ - ao_lisp_builtin.c \ - ao_lisp_read.c \ - ao_lisp_frame.c \ - ao_lisp_lambda.c \ - ao_lisp_eval.c \ - ao_lisp_rep.c \ - ao_lisp_save.c \ - ao_lisp_stack.c \ - ao_lisp_error.c - -LISP_HDRS=\ - ao_lisp.h \ - ao_lisp_os.h \ - ao_lisp_read.h \ - ao_lisp_builtin.h diff --git a/src/lisp/Makefile-lisp b/src/lisp/Makefile-lisp deleted file mode 100644 index 998c7673..00000000 --- a/src/lisp/Makefile-lisp +++ /dev/null @@ -1,4 +0,0 @@ -include ../lisp/Makefile-inc - -ao_lisp_const.h: $(LISP_SRCS) $(LISP_HDRS) - +cd ../lisp && make $@ diff --git a/src/lisp/README b/src/lisp/README deleted file mode 100644 index c1e84475..00000000 --- a/src/lisp/README +++ /dev/null @@ -1,11 +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; we have macros instead -* define inside of lambda does not add name to lambda scope -* No record types -* No libraries diff --git a/src/lisp/ao_lisp.h b/src/lisp/ao_lisp.h deleted file mode 100644 index b5e03b1e..00000000 --- a/src/lisp/ao_lisp.h +++ /dev/null @@ -1,928 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#ifndef _AO_LISP_H_ -#define _AO_LISP_H_ - -#define DBG_MEM 0 -#define DBG_EVAL 0 -#define DBG_READ 0 -#define DBG_FREE_CONS 0 -#define NDEBUG 1 - -#include -#include -#include -#ifndef __BYTE_ORDER -#include -#endif - -typedef uint16_t ao_poly; -typedef int16_t ao_signed_poly; - -#ifdef AO_LISP_SAVE - -struct ao_lisp_os_save { - ao_poly atoms; - ao_poly globals; - uint16_t const_checksum; - uint16_t const_checksum_inv; -}; - -#define AO_LISP_POOL_EXTRA (sizeof(struct ao_lisp_os_save)) -#define AO_LISP_POOL ((int) (AO_LISP_POOL_TOTAL - AO_LISP_POOL_EXTRA)) - -int -ao_lisp_os_save(void); - -int -ao_lisp_os_restore_save(struct ao_lisp_os_save *save, int offset); - -int -ao_lisp_os_restore(void); - -#endif - -#ifdef AO_LISP_MAKE_CONST -#define AO_LISP_POOL_CONST 16384 -extern uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4))); -#define ao_lisp_pool ao_lisp_const -#define AO_LISP_POOL AO_LISP_POOL_CONST - -#define _atom(n) ao_lisp_atom_poly(ao_lisp_atom_intern(n)) -#define _bool(v) ao_lisp_bool_poly(ao_lisp_bool_get(v)) - -#define _ao_lisp_bool_true _bool(1) -#define _ao_lisp_bool_false _bool(0) - -#define _ao_lisp_atom_eof _atom("eof") -#define _ao_lisp_atom_else _atom("else") - -#define AO_LISP_BUILTIN_ATOMS -#include "ao_lisp_builtin.h" - -#else -#include "ao_lisp_const.h" -#ifndef AO_LISP_POOL -#define AO_LISP_POOL 3072 -#endif -extern uint8_t ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA] __attribute__((aligned(4))); -#endif - -/* Primitive types */ -#define AO_LISP_CONS 0 -#define AO_LISP_INT 1 -#define AO_LISP_STRING 2 -#define AO_LISP_OTHER 3 - -#define AO_LISP_TYPE_MASK 0x0003 -#define AO_LISP_TYPE_SHIFT 2 -#define AO_LISP_REF_MASK 0x7ffc -#define AO_LISP_CONST 0x8000 - -/* These have a type value at the start of the struct */ -#define AO_LISP_ATOM 4 -#define AO_LISP_BUILTIN 5 -#define AO_LISP_FRAME 6 -#define AO_LISP_FRAME_VALS 7 -#define AO_LISP_LAMBDA 8 -#define AO_LISP_STACK 9 -#define AO_LISP_BOOL 10 -#define AO_LISP_BIGINT 11 -#define AO_LISP_FLOAT 12 -#define AO_LISP_NUM_TYPE 13 - -/* Leave two bits for types to use as they please */ -#define AO_LISP_OTHER_TYPE_MASK 0x3f - -#define AO_LISP_NIL 0 - -extern uint16_t ao_lisp_top; - -#define AO_LISP_OOM 0x01 -#define AO_LISP_DIVIDE_BY_ZERO 0x02 -#define AO_LISP_INVALID 0x04 -#define AO_LISP_UNDEFINED 0x08 -#define AO_LISP_REDEFINED 0x10 -#define AO_LISP_EOF 0x20 -#define AO_LISP_EXIT 0x40 - -extern uint8_t ao_lisp_exception; - -static inline int -ao_lisp_is_const(ao_poly poly) { - return poly & AO_LISP_CONST; -} - -#define AO_LISP_IS_CONST(a) (ao_lisp_const <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_lisp_const + AO_LISP_POOL_CONST) -#define AO_LISP_IS_POOL(a) (ao_lisp_pool <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_lisp_pool + AO_LISP_POOL) -#define AO_LISP_IS_INT(p) (ao_lisp_poly_base_type(p) == AO_LISP_INT) - -void * -ao_lisp_ref(ao_poly poly); - -ao_poly -ao_lisp_poly(const void *addr, ao_poly type); - -struct ao_lisp_type { - int (*size)(void *addr); - void (*mark)(void *addr); - void (*move)(void *addr); - char name[]; -}; - -struct ao_lisp_cons { - ao_poly car; - ao_poly cdr; -}; - -struct ao_lisp_atom { - uint8_t type; - uint8_t pad[1]; - ao_poly next; - char name[]; -}; - -struct ao_lisp_val { - ao_poly atom; - ao_poly val; -}; - -struct ao_lisp_frame_vals { - uint8_t type; - uint8_t size; - struct ao_lisp_val vals[]; -}; - -struct ao_lisp_frame { - uint8_t type; - uint8_t num; - ao_poly prev; - ao_poly vals; -}; - -struct ao_lisp_bool { - uint8_t type; - uint8_t value; - uint16_t pad; -}; - -struct ao_lisp_bigint { - uint32_t value; -}; - -struct ao_lisp_float { - uint8_t type; - uint8_t pad1; - uint16_t pad2; - float value; -}; - -#if __BYTE_ORDER == __LITTLE_ENDIAN -static inline uint32_t -ao_lisp_int_bigint(int32_t i) { - return AO_LISP_BIGINT | (i << 8); -} -static inline int32_t -ao_lisp_bigint_int(uint32_t bi) { - return (int32_t) bi >> 8; -} -#else -static inline uint32_t -ao_lisp_int_bigint(int32_t i) { - return (uint32_t) (i & 0xffffff) | (AO_LISP_BIGINT << 24); -} -static inlint int32_t -ao_lisp_bigint_int(uint32_t bi) { - return (int32_t) (bi << 8) >> 8; -} -#endif - -#define AO_LISP_MIN_INT (-(1 << (15 - AO_LISP_TYPE_SHIFT))) -#define AO_LISP_MAX_INT ((1 << (15 - AO_LISP_TYPE_SHIFT)) - 1) -#define AO_LISP_MIN_BIGINT (-(1 << 24)) -#define AO_LISP_MAX_BIGINT ((1 << 24) - 1) - -#define AO_LISP_NOT_INTEGER 0x7fffffff - -/* Set on type when the frame escapes the lambda */ -#define AO_LISP_FRAME_MARK 0x80 -#define AO_LISP_FRAME_PRINT 0x40 - -static inline int ao_lisp_frame_marked(struct ao_lisp_frame *f) { - return f->type & AO_LISP_FRAME_MARK; -} - -static inline struct ao_lisp_frame * -ao_lisp_poly_frame(ao_poly poly) { - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_frame_poly(struct ao_lisp_frame *frame) { - return ao_lisp_poly(frame, AO_LISP_OTHER); -} - -static inline struct ao_lisp_frame_vals * -ao_lisp_poly_frame_vals(ao_poly poly) { - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_frame_vals_poly(struct ao_lisp_frame_vals *vals) { - return ao_lisp_poly(vals, AO_LISP_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_lisp_stack { - uint8_t type; /* AO_LISP_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_LISP_STACK_MARK 0x80 /* set on type when a reference has been taken */ -#define AO_LISP_STACK_PRINT 0x40 /* stack is being printed */ - -static inline int ao_lisp_stack_marked(struct ao_lisp_stack *s) { - return s->type & AO_LISP_STACK_MARK; -} - -static inline void ao_lisp_stack_mark(struct ao_lisp_stack *s) { - s->type |= AO_LISP_STACK_MARK; -} - -static inline struct ao_lisp_stack * -ao_lisp_poly_stack(ao_poly p) -{ - return ao_lisp_ref(p); -} - -static inline ao_poly -ao_lisp_stack_poly(struct ao_lisp_stack *stack) -{ - return ao_lisp_poly(stack, AO_LISP_OTHER); -} - -extern ao_poly ao_lisp_v; - -#define AO_LISP_FUNC_LAMBDA 0 -#define AO_LISP_FUNC_NLAMBDA 1 -#define AO_LISP_FUNC_MACRO 2 - -#define AO_LISP_FUNC_FREE_ARGS 0x80 -#define AO_LISP_FUNC_MASK 0x7f - -#define AO_LISP_FUNC_F_LAMBDA (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_LAMBDA) -#define AO_LISP_FUNC_F_NLAMBDA (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_NLAMBDA) -#define AO_LISP_FUNC_F_MACRO (AO_LISP_FUNC_FREE_ARGS | AO_LISP_FUNC_MACRO) - -struct ao_lisp_builtin { - uint8_t type; - uint8_t args; - uint16_t func; -}; - -#define AO_LISP_BUILTIN_ID -#include "ao_lisp_builtin.h" - -typedef ao_poly (*ao_lisp_func_t)(struct ao_lisp_cons *cons); - -extern const ao_lisp_func_t ao_lisp_builtins[]; - -static inline ao_lisp_func_t -ao_lisp_func(struct ao_lisp_builtin *b) -{ - return ao_lisp_builtins[b->func]; -} - -struct ao_lisp_lambda { - uint8_t type; - uint8_t args; - ao_poly code; - ao_poly frame; -}; - -static inline struct ao_lisp_lambda * -ao_lisp_poly_lambda(ao_poly poly) -{ - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_lambda_poly(struct ao_lisp_lambda *lambda) -{ - return ao_lisp_poly(lambda, AO_LISP_OTHER); -} - -static inline void * -ao_lisp_poly_other(ao_poly poly) { - return ao_lisp_ref(poly); -} - -static inline uint8_t -ao_lisp_other_type(void *other) { -#if DBG_MEM - if ((*((uint8_t *) other) & AO_LISP_OTHER_TYPE_MASK) >= AO_LISP_NUM_TYPE) - ao_lisp_abort(); -#endif - return *((uint8_t *) other) & AO_LISP_OTHER_TYPE_MASK; -} - -static inline ao_poly -ao_lisp_other_poly(const void *other) -{ - return ao_lisp_poly(other, AO_LISP_OTHER); -} - -static inline int -ao_lisp_size_round(int size) -{ - return (size + 3) & ~3; -} - -static inline int -ao_lisp_size(const struct ao_lisp_type *type, void *addr) -{ - return ao_lisp_size_round(type->size(addr)); -} - -#define AO_LISP_OTHER_POLY(other) ((ao_poly)(other) + AO_LISP_OTHER) - -static inline int ao_lisp_poly_base_type(ao_poly poly) { - return poly & AO_LISP_TYPE_MASK; -} - -static inline int ao_lisp_poly_type(ao_poly poly) { - int type = poly & AO_LISP_TYPE_MASK; - if (type == AO_LISP_OTHER) - return ao_lisp_other_type(ao_lisp_poly_other(poly)); - return type; -} - -static inline int -ao_lisp_is_cons(ao_poly poly) { - return (ao_lisp_poly_base_type(poly) == AO_LISP_CONS); -} - -static inline int -ao_lisp_is_pair(ao_poly poly) { - return poly != AO_LISP_NIL && (ao_lisp_poly_base_type(poly) == AO_LISP_CONS); -} - -static inline struct ao_lisp_cons * -ao_lisp_poly_cons(ao_poly poly) -{ - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_cons_poly(struct ao_lisp_cons *cons) -{ - return ao_lisp_poly(cons, AO_LISP_CONS); -} - -static inline int32_t -ao_lisp_poly_int(ao_poly poly) -{ - return (int32_t) ((ao_signed_poly) poly >> AO_LISP_TYPE_SHIFT); -} - -static inline ao_poly -ao_lisp_int_poly(int32_t i) -{ - return ((ao_poly) i << 2) | AO_LISP_INT; -} - -static inline struct ao_lisp_bigint * -ao_lisp_poly_bigint(ao_poly poly) -{ - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_bigint_poly(struct ao_lisp_bigint *bi) -{ - return ao_lisp_poly(bi, AO_LISP_OTHER); -} - -static inline char * -ao_lisp_poly_string(ao_poly poly) -{ - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_string_poly(char *s) -{ - return ao_lisp_poly(s, AO_LISP_STRING); -} - -static inline struct ao_lisp_atom * -ao_lisp_poly_atom(ao_poly poly) -{ - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_atom_poly(struct ao_lisp_atom *a) -{ - return ao_lisp_poly(a, AO_LISP_OTHER); -} - -static inline struct ao_lisp_builtin * -ao_lisp_poly_builtin(ao_poly poly) -{ - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_builtin_poly(struct ao_lisp_builtin *b) -{ - return ao_lisp_poly(b, AO_LISP_OTHER); -} - -static inline ao_poly -ao_lisp_bool_poly(struct ao_lisp_bool *b) -{ - return ao_lisp_poly(b, AO_LISP_OTHER); -} - -static inline struct ao_lisp_bool * -ao_lisp_poly_bool(ao_poly poly) -{ - return ao_lisp_ref(poly); -} - -static inline ao_poly -ao_lisp_float_poly(struct ao_lisp_float *f) -{ - return ao_lisp_poly(f, AO_LISP_OTHER); -} - -static inline struct ao_lisp_float * -ao_lisp_poly_float(ao_poly poly) -{ - return ao_lisp_ref(poly); -} - -float -ao_lisp_poly_number(ao_poly p); - -/* memory functions */ - -extern int ao_lisp_collects[2]; -extern int ao_lisp_freed[2]; -extern int ao_lisp_loops[2]; - -/* returns 1 if the object was already marked */ -int -ao_lisp_mark(const struct ao_lisp_type *type, void *addr); - -/* returns 1 if the object was already marked */ -int -ao_lisp_mark_memory(const struct ao_lisp_type *type, void *addr); - -void * -ao_lisp_move_map(void *addr); - -/* returns 1 if the object was already moved */ -int -ao_lisp_move(const struct ao_lisp_type *type, void **ref); - -/* returns 1 if the object was already moved */ -int -ao_lisp_move_memory(const struct ao_lisp_type *type, void **ref); - -void * -ao_lisp_alloc(int size); - -#define AO_LISP_COLLECT_FULL 1 -#define AO_LISP_COLLECT_INCREMENTAL 0 - -int -ao_lisp_collect(uint8_t style); - -#if DBG_FREE_CONS -void -ao_lisp_cons_check(struct ao_lisp_cons *cons); -#endif - -void -ao_lisp_cons_stash(int id, struct ao_lisp_cons *cons); - -struct ao_lisp_cons * -ao_lisp_cons_fetch(int id); - -void -ao_lisp_poly_stash(int id, ao_poly poly); - -ao_poly -ao_lisp_poly_fetch(int id); - -void -ao_lisp_string_stash(int id, char *string); - -char * -ao_lisp_string_fetch(int id); - -static inline void -ao_lisp_stack_stash(int id, struct ao_lisp_stack *stack) { - ao_lisp_poly_stash(id, ao_lisp_stack_poly(stack)); -} - -static inline struct ao_lisp_stack * -ao_lisp_stack_fetch(int id) { - return ao_lisp_poly_stack(ao_lisp_poly_fetch(id)); -} - -void -ao_lisp_frame_stash(int id, struct ao_lisp_frame *frame); - -struct ao_lisp_frame * -ao_lisp_frame_fetch(int id); - -/* bool */ - -extern const struct ao_lisp_type ao_lisp_bool_type; - -void -ao_lisp_bool_write(ao_poly v); - -#ifdef AO_LISP_MAKE_CONST -struct ao_lisp_bool *ao_lisp_true, *ao_lisp_false; - -struct ao_lisp_bool * -ao_lisp_bool_get(uint8_t value); -#endif - -/* cons */ -extern const struct ao_lisp_type ao_lisp_cons_type; - -struct ao_lisp_cons * -ao_lisp_cons_cons(ao_poly car, ao_poly cdr); - -/* Return a cons or NULL for a proper list, else error */ -struct ao_lisp_cons * -ao_lisp_cons_cdr(struct ao_lisp_cons *cons); - -ao_poly -ao_lisp__cons(ao_poly car, ao_poly cdr); - -extern struct ao_lisp_cons *ao_lisp_cons_free_list; - -void -ao_lisp_cons_free(struct ao_lisp_cons *cons); - -void -ao_lisp_cons_write(ao_poly); - -void -ao_lisp_cons_display(ao_poly); - -int -ao_lisp_cons_length(struct ao_lisp_cons *cons); - -/* string */ -extern const struct ao_lisp_type ao_lisp_string_type; - -char * -ao_lisp_string_copy(char *a); - -char * -ao_lisp_string_cat(char *a, char *b); - -ao_poly -ao_lisp_string_pack(struct ao_lisp_cons *cons); - -ao_poly -ao_lisp_string_unpack(char *a); - -void -ao_lisp_string_write(ao_poly s); - -void -ao_lisp_string_display(ao_poly s); - -/* atom */ -extern const struct ao_lisp_type ao_lisp_atom_type; - -extern struct ao_lisp_atom *ao_lisp_atoms; -extern struct ao_lisp_frame *ao_lisp_frame_global; -extern struct ao_lisp_frame *ao_lisp_frame_current; - -void -ao_lisp_atom_write(ao_poly a); - -struct ao_lisp_atom * -ao_lisp_atom_intern(char *name); - -ao_poly * -ao_lisp_atom_ref(ao_poly atom); - -ao_poly -ao_lisp_atom_get(ao_poly atom); - -ao_poly -ao_lisp_atom_set(ao_poly atom, ao_poly val); - -ao_poly -ao_lisp_atom_def(ao_poly atom, ao_poly val); - -/* int */ -void -ao_lisp_int_write(ao_poly i); - -int32_t -ao_lisp_poly_integer(ao_poly p); - -ao_poly -ao_lisp_integer_poly(int32_t i); - -static inline int -ao_lisp_integer_typep(uint8_t t) -{ - return (t == AO_LISP_INT) || (t == AO_LISP_BIGINT); -} - -void -ao_lisp_bigint_write(ao_poly i); - -extern const struct ao_lisp_type ao_lisp_bigint_type; -/* prim */ -void -ao_lisp_poly_write(ao_poly p); - -void -ao_lisp_poly_display(ao_poly p); - -int -ao_lisp_poly_mark(ao_poly p, uint8_t note_cons); - -/* returns 1 if the object has already been moved */ -int -ao_lisp_poly_move(ao_poly *p, uint8_t note_cons); - -/* eval */ - -void -ao_lisp_eval_clear_globals(void); - -int -ao_lisp_eval_restart(void); - -ao_poly -ao_lisp_eval(ao_poly p); - -ao_poly -ao_lisp_set_cond(struct ao_lisp_cons *cons); - -/* float */ -extern const struct ao_lisp_type ao_lisp_float_type; - -void -ao_lisp_float_write(ao_poly p); - -ao_poly -ao_lisp_float_get(float value); - -static inline uint8_t -ao_lisp_number_typep(uint8_t t) -{ - return ao_lisp_integer_typep(t) || (t == AO_LISP_FLOAT); -} - -float -ao_lisp_poly_number(ao_poly p); - -/* builtin */ -void -ao_lisp_builtin_write(ao_poly b); - -extern const struct ao_lisp_type ao_lisp_builtin_type; - -/* Check argument count */ -ao_poly -ao_lisp_check_argc(ao_poly name, struct ao_lisp_cons *cons, int min, int max); - -/* Check argument type */ -ao_poly -ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type, int nil_ok); - -/* Fetch an arg (nil if off the end) */ -ao_poly -ao_lisp_arg(struct ao_lisp_cons *cons, int argc); - -char * -ao_lisp_args_name(uint8_t args); - -/* read */ -extern struct ao_lisp_cons *ao_lisp_read_cons; -extern struct ao_lisp_cons *ao_lisp_read_cons_tail; -extern struct ao_lisp_cons *ao_lisp_read_stack; - -ao_poly -ao_lisp_read(void); - -/* rep */ -ao_poly -ao_lisp_read_eval_print(void); - -/* frame */ -extern const struct ao_lisp_type ao_lisp_frame_type; -extern const struct ao_lisp_type ao_lisp_frame_vals_type; - -#define AO_LISP_FRAME_FREE 6 - -extern struct ao_lisp_frame *ao_lisp_frame_free_list[AO_LISP_FRAME_FREE]; - -ao_poly -ao_lisp_frame_mark(struct ao_lisp_frame *frame); - -ao_poly * -ao_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom); - -struct ao_lisp_frame * -ao_lisp_frame_new(int num); - -void -ao_lisp_frame_free(struct ao_lisp_frame *frame); - -void -ao_lisp_frame_bind(struct ao_lisp_frame *frame, int num, ao_poly atom, ao_poly val); - -ao_poly -ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val); - -void -ao_lisp_frame_write(ao_poly p); - -void -ao_lisp_frame_init(void); - -/* lambda */ -extern const struct ao_lisp_type ao_lisp_lambda_type; - -extern const char *ao_lisp_state_names[]; - -struct ao_lisp_lambda * -ao_lisp_lambda_new(ao_poly cons); - -void -ao_lisp_lambda_write(ao_poly lambda); - -ao_poly -ao_lisp_lambda_eval(void); - -/* stack */ - -extern const struct ao_lisp_type ao_lisp_stack_type; -extern struct ao_lisp_stack *ao_lisp_stack; -extern struct ao_lisp_stack *ao_lisp_stack_free_list; - -void -ao_lisp_stack_reset(struct ao_lisp_stack *stack); - -int -ao_lisp_stack_push(void); - -void -ao_lisp_stack_pop(void); - -void -ao_lisp_stack_clear(void); - -void -ao_lisp_stack_write(ao_poly stack); - -ao_poly -ao_lisp_stack_eval(void); - -/* error */ - -void -ao_lisp_vprintf(char *format, va_list args); - -void -ao_lisp_printf(char *format, ...); - -void -ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last); - -void -ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame); - -ao_poly -ao_lisp_error(int error, char *format, ...); - -/* builtins */ - -#define AO_LISP_BUILTIN_DECLS -#include "ao_lisp_builtin.h" - -/* debugging macros */ - -#if DBG_EVAL || DBG_READ || DBG_MEM -#define DBG_CODE 1 -int ao_lisp_stack_depth; -#define DBG_DO(a) a -#define DBG_INDENT() do { int _s; for(_s = 0; _s < ao_lisp_stack_depth; _s++) printf(" "); } while(0) -#define DBG_IN() (++ao_lisp_stack_depth) -#define DBG_OUT() (--ao_lisp_stack_depth) -#define DBG_RESET() (ao_lisp_stack_depth = 0) -#define DBG(...) ao_lisp_printf(__VA_ARGS__) -#define DBGI(...) do { printf("%4d: ", __LINE__); DBG_INDENT(); DBG(__VA_ARGS__); } while (0) -#define DBG_CONS(a) ao_lisp_cons_write(ao_lisp_cons_poly(a)) -#define DBG_POLY(a) ao_lisp_poly_write(a) -#define OFFSET(a) ((a) ? (int) ((uint8_t *) a - ao_lisp_pool) : -1) -#define DBG_STACK() ao_lisp_stack_write(ao_lisp_stack_poly(ao_lisp_stack)) -static inline void -ao_lisp_frames_dump(void) -{ - struct ao_lisp_stack *s; - DBGI(".. current frame: "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - for (s = ao_lisp_stack; s; s = ao_lisp_poly_stack(s->prev)) { - DBGI(".. stack frame: "); DBG_POLY(s->frame); DBG("\n"); - } -} -#define DBG_FRAMES() ao_lisp_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(...) DBGI(__VA_ARGS__) -#define RDBG_IN() DBG_IN() -#define RDBG_OUT() DBG_OUT() -#else -#define RDBGI(...) -#define RDBG_IN() -#define RDBG_OUT() -#endif - -#define DBG_MEM_START 1 - -#if DBG_MEM - -#include -extern int dbg_move_depth; -#define MDBG_DUMP 1 -#define MDBG_OFFSET(a) ((a) ? (int) ((uint8_t *) (a) - ao_lisp_pool) : -1) - -extern int dbg_mem; - -#define MDBG_DO(a) DBG_DO(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_LISP_H_ */ diff --git a/src/lisp/ao_lisp_atom.c b/src/lisp/ao_lisp_atom.c deleted file mode 100644 index a633c223..00000000 --- a/src/lisp/ao_lisp_atom.c +++ /dev/null @@ -1,159 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. - */ - -#include "ao_lisp.h" - -static int name_size(char *name) -{ - return sizeof(struct ao_lisp_atom) + strlen(name) + 1; -} - -static int atom_size(void *addr) -{ - struct ao_lisp_atom *atom = addr; - if (!atom) - return 0; - return name_size(atom->name); -} - -static void atom_mark(void *addr) -{ - struct ao_lisp_atom *atom = addr; - - for (;;) { - atom = ao_lisp_poly_atom(atom->next); - if (!atom) - break; - if (ao_lisp_mark_memory(&ao_lisp_atom_type, atom)) - break; - } -} - -static void atom_move(void *addr) -{ - struct ao_lisp_atom *atom = addr; - int ret; - - for (;;) { - struct ao_lisp_atom *next = ao_lisp_poly_atom(atom->next); - - if (!next) - break; - ret = ao_lisp_move_memory(&ao_lisp_atom_type, (void **) &next); - if (next != ao_lisp_poly_atom(atom->next)) - atom->next = ao_lisp_atom_poly(next); - if (ret) - break; - atom = next; - } -} - -const struct ao_lisp_type ao_lisp_atom_type = { - .mark = atom_mark, - .size = atom_size, - .move = atom_move, - .name = "atom" -}; - -struct ao_lisp_atom *ao_lisp_atoms; - -struct ao_lisp_atom * -ao_lisp_atom_intern(char *name) -{ - struct ao_lisp_atom *atom; - - for (atom = ao_lisp_atoms; atom; atom = ao_lisp_poly_atom(atom->next)) { - if (!strcmp(atom->name, name)) - return atom; - } -#ifdef ao_builtin_atoms - for (atom = ao_lisp_poly_atom(ao_builtin_atoms); atom; atom = ao_lisp_poly_atom(atom->next)) { - if (!strcmp(atom->name, name)) - return atom; - } -#endif - ao_lisp_string_stash(0, name); - atom = ao_lisp_alloc(name_size(name)); - name = ao_lisp_string_fetch(0); - if (atom) { - atom->type = AO_LISP_ATOM; - atom->next = ao_lisp_atom_poly(ao_lisp_atoms); - ao_lisp_atoms = atom; - strcpy(atom->name, name); - } - return atom; -} - -ao_poly * -ao_lisp_atom_ref(ao_poly atom) -{ - ao_poly *ref; - struct ao_lisp_frame *frame; - - for (frame = ao_lisp_frame_current; frame; frame = ao_lisp_poly_frame(frame->prev)) { - ref = ao_lisp_frame_ref(frame, atom); - if (ref) - return ref; - } - return ao_lisp_frame_ref(ao_lisp_frame_global, atom); -} - -ao_poly -ao_lisp_atom_get(ao_poly atom) -{ - ao_poly *ref = ao_lisp_atom_ref(atom); - -#ifdef ao_builtin_frame - if (!ref) - ref = ao_lisp_frame_ref(ao_lisp_poly_frame(ao_builtin_frame), atom); -#endif - if (ref) - return *ref; - return ao_lisp_error(AO_LISP_UNDEFINED, "undefined atom %s", ao_lisp_poly_atom(atom)->name); -} - -ao_poly -ao_lisp_atom_set(ao_poly atom, ao_poly val) -{ - ao_poly *ref = ao_lisp_atom_ref(atom); - - if (!ref) - return ao_lisp_error(AO_LISP_UNDEFINED, "undefined atom %s", ao_lisp_poly_atom(atom)->name); - *ref = val; - return val; -} - -ao_poly -ao_lisp_atom_def(ao_poly atom, ao_poly val) -{ - ao_poly *ref = ao_lisp_atom_ref(atom); - - if (ref) { - if (ao_lisp_frame_current) - return ao_lisp_error(AO_LISP_REDEFINED, "attempt to redefine atom %s", ao_lisp_poly_atom(atom)->name); - *ref = val; - return val; - } - return ao_lisp_frame_add(ao_lisp_frame_current ? ao_lisp_frame_current : ao_lisp_frame_global, atom, val); -} - -void -ao_lisp_atom_write(ao_poly a) -{ - struct ao_lisp_atom *atom = ao_lisp_poly_atom(a); - printf("%s", atom->name); -} diff --git a/src/lisp/ao_lisp_bool.c b/src/lisp/ao_lisp_bool.c deleted file mode 100644 index 391a7f78..00000000 --- a/src/lisp/ao_lisp_bool.c +++ /dev/null @@ -1,73 +0,0 @@ -/* - * Copyright © 2017 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -static void bool_mark(void *addr) -{ - (void) addr; -} - -static int bool_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_lisp_bool); -} - -static void bool_move(void *addr) -{ - (void) addr; -} - -const struct ao_lisp_type ao_lisp_bool_type = { - .mark = bool_mark, - .size = bool_size, - .move = bool_move, - .name = "bool" -}; - -void -ao_lisp_bool_write(ao_poly v) -{ - struct ao_lisp_bool *b = ao_lisp_poly_bool(v); - - if (b->value) - printf("#t"); - else - printf("#f"); -} - -#ifdef AO_LISP_MAKE_CONST - -struct ao_lisp_bool *ao_lisp_true, *ao_lisp_false; - -struct ao_lisp_bool * -ao_lisp_bool_get(uint8_t value) -{ - struct ao_lisp_bool **b; - - if (value) - b = &ao_lisp_true; - else - b = &ao_lisp_false; - - if (!*b) { - *b = ao_lisp_alloc(sizeof (struct ao_lisp_bool)); - (*b)->type = AO_LISP_BOOL; - (*b)->value = value; - } - return *b; -} - -#endif diff --git a/src/lisp/ao_lisp_builtin.c b/src/lisp/ao_lisp_builtin.c deleted file mode 100644 index 6af2a6ea..00000000 --- a/src/lisp/ao_lisp_builtin.c +++ /dev/null @@ -1,868 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include -#include - -static int -builtin_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_lisp_builtin); -} - -static void -builtin_mark(void *addr) -{ - (void) addr; -} - -static void -builtin_move(void *addr) -{ - (void) addr; -} - -const struct ao_lisp_type ao_lisp_builtin_type = { - .size = builtin_size, - .mark = builtin_mark, - .move = builtin_move -}; - -#ifdef AO_LISP_MAKE_CONST - -#define AO_LISP_BUILTIN_CASENAME -#include "ao_lisp_builtin.h" - -char *ao_lisp_args_name(uint8_t args) { - args &= AO_LISP_FUNC_MASK; - switch (args) { - case AO_LISP_FUNC_LAMBDA: return ao_lisp_poly_atom(_ao_lisp_atom_lambda)->name; - case AO_LISP_FUNC_NLAMBDA: return ao_lisp_poly_atom(_ao_lisp_atom_nlambda)->name; - case AO_LISP_FUNC_MACRO: return ao_lisp_poly_atom(_ao_lisp_atom_macro)->name; - default: return "???"; - } -} -#else - -#define AO_LISP_BUILTIN_ARRAYNAME -#include "ao_lisp_builtin.h" - -static char * -ao_lisp_builtin_name(enum ao_lisp_builtin_id b) { - if (b < _builtin_last) - return ao_lisp_poly_atom(builtin_names[b])->name; - return "???"; -} - -static const ao_poly ao_lisp_args_atoms[] = { - [AO_LISP_FUNC_LAMBDA] = _ao_lisp_atom_lambda, - [AO_LISP_FUNC_NLAMBDA] = _ao_lisp_atom_nlambda, - [AO_LISP_FUNC_MACRO] = _ao_lisp_atom_macro, -}; - -char * -ao_lisp_args_name(uint8_t args) -{ - args &= AO_LISP_FUNC_MASK; - if (args < sizeof ao_lisp_args_atoms / sizeof ao_lisp_args_atoms[0]) - return ao_lisp_poly_atom(ao_lisp_args_atoms[args])->name; - return "(unknown)"; -} -#endif - -void -ao_lisp_builtin_write(ao_poly b) -{ - struct ao_lisp_builtin *builtin = ao_lisp_poly_builtin(b); - printf("%s", ao_lisp_builtin_name(builtin->func)); -} - -ao_poly -ao_lisp_check_argc(ao_poly name, struct ao_lisp_cons *cons, int min, int max) -{ - int argc = 0; - - while (cons && argc <= max) { - argc++; - cons = ao_lisp_cons_cdr(cons); - } - if (argc < min || argc > max) - return ao_lisp_error(AO_LISP_INVALID, "%s: invalid arg count", ao_lisp_poly_atom(name)->name); - return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_arg(struct ao_lisp_cons *cons, int argc) -{ - if (!cons) - return AO_LISP_NIL; - while (argc--) { - if (!cons) - return AO_LISP_NIL; - cons = ao_lisp_cons_cdr(cons); - } - return cons->car; -} - -ao_poly -ao_lisp_check_argt(ao_poly name, struct ao_lisp_cons *cons, int argc, int type, int nil_ok) -{ - ao_poly car = ao_lisp_arg(cons, argc); - - if ((!car && !nil_ok) || ao_lisp_poly_type(car) != type) - return ao_lisp_error(AO_LISP_INVALID, "%s: arg %d invalid type %v", ao_lisp_poly_atom(name)->name, argc, car); - return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_do_car(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_car, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_car, cons, 0, AO_LISP_CONS, 0)) - return AO_LISP_NIL; - return ao_lisp_poly_cons(cons->car)->car; -} - -ao_poly -ao_lisp_do_cdr(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_cdr, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_cdr, cons, 0, AO_LISP_CONS, 0)) - return AO_LISP_NIL; - return ao_lisp_poly_cons(cons->car)->cdr; -} - -ao_poly -ao_lisp_do_cons(struct ao_lisp_cons *cons) -{ - ao_poly car, cdr; - if(!ao_lisp_check_argc(_ao_lisp_atom_cons, cons, 2, 2)) - return AO_LISP_NIL; - car = ao_lisp_arg(cons, 0); - cdr = ao_lisp_arg(cons, 1); - return ao_lisp__cons(car, cdr); -} - -ao_poly -ao_lisp_do_last(struct ao_lisp_cons *cons) -{ - struct ao_lisp_cons *list; - if (!ao_lisp_check_argc(_ao_lisp_atom_last, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_last, cons, 0, AO_LISP_CONS, 1)) - return AO_LISP_NIL; - for (list = ao_lisp_poly_cons(ao_lisp_arg(cons, 0)); - list; - list = ao_lisp_cons_cdr(list)) - { - if (!list->cdr) - return list->car; - } - return AO_LISP_NIL; -} - -ao_poly -ao_lisp_do_length(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_length, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_length, cons, 0, AO_LISP_CONS, 1)) - return AO_LISP_NIL; - return ao_lisp_int_poly(ao_lisp_cons_length(ao_lisp_poly_cons(ao_lisp_arg(cons, 0)))); -} - -ao_poly -ao_lisp_do_quote(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_quote, cons, 1, 1)) - return AO_LISP_NIL; - return ao_lisp_arg(cons, 0); -} - -ao_poly -ao_lisp_do_set(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_set, cons, 2, 2)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_set, cons, 0, AO_LISP_ATOM, 0)) - return AO_LISP_NIL; - - return ao_lisp_atom_set(ao_lisp_arg(cons, 0), ao_lisp_arg(cons, 1)); -} - -ao_poly -ao_lisp_do_def(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_def, cons, 2, 2)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_def, cons, 0, AO_LISP_ATOM, 0)) - return AO_LISP_NIL; - - return ao_lisp_atom_def(ao_lisp_arg(cons, 0), ao_lisp_arg(cons, 1)); -} - -ao_poly -ao_lisp_do_setq(struct ao_lisp_cons *cons) -{ - ao_poly name; - if (!ao_lisp_check_argc(_ao_lisp_atom_set21, cons, 2, 2)) - return AO_LISP_NIL; - name = cons->car; - if (ao_lisp_poly_type(name) != AO_LISP_ATOM) - return ao_lisp_error(AO_LISP_INVALID, "set! of non-atom %v", name); - if (!ao_lisp_atom_ref(name)) - return ao_lisp_error(AO_LISP_INVALID, "atom %v not defined", name); - return ao_lisp__cons(_ao_lisp_atom_set, - ao_lisp__cons(ao_lisp__cons(_ao_lisp_atom_quote, - ao_lisp__cons(name, AO_LISP_NIL)), - cons->cdr)); -} - -ao_poly -ao_lisp_do_cond(struct ao_lisp_cons *cons) -{ - ao_lisp_set_cond(cons); - return AO_LISP_NIL; -} - -ao_poly -ao_lisp_do_begin(struct ao_lisp_cons *cons) -{ - ao_lisp_stack->state = eval_begin; - ao_lisp_stack->sexprs = ao_lisp_cons_poly(cons); - return AO_LISP_NIL; -} - -ao_poly -ao_lisp_do_while(struct ao_lisp_cons *cons) -{ - ao_lisp_stack->state = eval_while; - ao_lisp_stack->sexprs = ao_lisp_cons_poly(cons); - return AO_LISP_NIL; -} - -ao_poly -ao_lisp_do_write(struct ao_lisp_cons *cons) -{ - ao_poly val = AO_LISP_NIL; - while (cons) { - val = cons->car; - ao_lisp_poly_write(val); - cons = ao_lisp_cons_cdr(cons); - if (cons) - printf(" "); - } - printf("\n"); - return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_do_display(struct ao_lisp_cons *cons) -{ - ao_poly val = AO_LISP_NIL; - while (cons) { - val = cons->car; - ao_lisp_poly_display(val); - cons = ao_lisp_cons_cdr(cons); - } - return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_math(struct ao_lisp_cons *orig_cons, enum ao_lisp_builtin_id op) -{ - struct ao_lisp_cons *cons = cons; - ao_poly ret = AO_LISP_NIL; - - for (cons = orig_cons; cons; cons = ao_lisp_cons_cdr(cons)) { - ao_poly car = cons->car; - uint8_t rt = ao_lisp_poly_type(ret); - uint8_t ct = ao_lisp_poly_type(car); - - if (cons == orig_cons) { - ret = car; - if (cons->cdr == AO_LISP_NIL) { - switch (op) { - case builtin_minus: - if (ao_lisp_integer_typep(ct)) - ret = ao_lisp_integer_poly(-ao_lisp_poly_integer(ret)); - else if (ct == AO_LISP_FLOAT) - ret = ao_lisp_float_get(-ao_lisp_poly_number(ret)); - break; - case builtin_divide: - if (ao_lisp_integer_typep(ct) && ao_lisp_poly_integer(ret) == 1) - ; - else if (ao_lisp_number_typep(ct)) { - float v = ao_lisp_poly_number(ret); - ret = ao_lisp_float_get(1/v); - } - break; - default: - break; - } - } - } else if (ao_lisp_integer_typep(rt) && ao_lisp_integer_typep(ct)) { - int32_t r = ao_lisp_poly_integer(ret); - int32_t c = ao_lisp_poly_integer(car); - int64_t t; - - switch(op) { - case builtin_plus: - r += c; - check_overflow: - if (r < AO_LISP_MIN_BIGINT || AO_LISP_MAX_BIGINT < r) - goto inexact; - break; - case builtin_minus: - r -= c; - goto check_overflow; - break; - case builtin_times: - t = (int64_t) r * (int64_t) c; - if (t < AO_LISP_MIN_BIGINT || AO_LISP_MAX_BIGINT < t) - goto inexact; - r = (int32_t) t; - break; - case builtin_divide: - if (c != 0 && (r % c) == 0) - r /= c; - else - goto inexact; - break; - case builtin_quotient: - if (c == 0) - return ao_lisp_error(AO_LISP_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_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "remainder by zero"); - r %= c; - break; - case builtin_modulo: - if (c == 0) - return ao_lisp_error(AO_LISP_DIVIDE_BY_ZERO, "modulo by zero"); - r %= c; - if ((r < 0) != (c < 0)) - r += c; - break; - default: - break; - } - ret = ao_lisp_integer_poly(r); - } else if (ao_lisp_number_typep(rt) && ao_lisp_number_typep(ct)) { - float r, c; - inexact: - r = ao_lisp_poly_number(ret); - c = ao_lisp_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_lisp_error(AO_LISP_INVALID, "non-integer value in integer divide"); - default: - break; - } - ret = ao_lisp_float_get(r); - } - - else if (rt == AO_LISP_STRING && ct == AO_LISP_STRING && op == builtin_plus) - ret = ao_lisp_string_poly(ao_lisp_string_cat(ao_lisp_poly_string(ret), - ao_lisp_poly_string(car))); - else - return ao_lisp_error(AO_LISP_INVALID, "invalid args"); - } - return ret; -} - -ao_poly -ao_lisp_do_plus(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_plus); -} - -ao_poly -ao_lisp_do_minus(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_minus); -} - -ao_poly -ao_lisp_do_times(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_times); -} - -ao_poly -ao_lisp_do_divide(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_divide); -} - -ao_poly -ao_lisp_do_quotient(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_quotient); -} - -ao_poly -ao_lisp_do_modulo(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_modulo); -} - -ao_poly -ao_lisp_do_remainder(struct ao_lisp_cons *cons) -{ - return ao_lisp_math(cons, builtin_remainder); -} - -ao_poly -ao_lisp_compare(struct ao_lisp_cons *cons, enum ao_lisp_builtin_id op) -{ - ao_poly left; - - if (!cons) - return _ao_lisp_bool_true; - - left = cons->car; - for (cons = ao_lisp_cons_cdr(cons); cons; cons = ao_lisp_cons_cdr(cons)) { - ao_poly right = cons->car; - - if (op == builtin_equal) { - if (left != right) - return _ao_lisp_bool_false; - } else { - uint8_t lt = ao_lisp_poly_type(left); - uint8_t rt = ao_lisp_poly_type(right); - if (ao_lisp_integer_typep(lt) && ao_lisp_integer_typep(rt)) { - int32_t l = ao_lisp_poly_integer(left); - int32_t r = ao_lisp_poly_integer(right); - - switch (op) { - case builtin_less: - if (!(l < r)) - return _ao_lisp_bool_false; - break; - case builtin_greater: - if (!(l > r)) - return _ao_lisp_bool_false; - break; - case builtin_less_equal: - if (!(l <= r)) - return _ao_lisp_bool_false; - break; - case builtin_greater_equal: - if (!(l >= r)) - return _ao_lisp_bool_false; - break; - default: - break; - } - } else if (lt == AO_LISP_STRING && rt == AO_LISP_STRING) { - int c = strcmp(ao_lisp_poly_string(left), - ao_lisp_poly_string(right)); - switch (op) { - case builtin_less: - if (!(c < 0)) - return _ao_lisp_bool_false; - break; - case builtin_greater: - if (!(c > 0)) - return _ao_lisp_bool_false; - break; - case builtin_less_equal: - if (!(c <= 0)) - return _ao_lisp_bool_false; - break; - case builtin_greater_equal: - if (!(c >= 0)) - return _ao_lisp_bool_false; - break; - default: - break; - } - } - } - left = right; - } - return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_do_equal(struct ao_lisp_cons *cons) -{ - return ao_lisp_compare(cons, builtin_equal); -} - -ao_poly -ao_lisp_do_less(struct ao_lisp_cons *cons) -{ - return ao_lisp_compare(cons, builtin_less); -} - -ao_poly -ao_lisp_do_greater(struct ao_lisp_cons *cons) -{ - return ao_lisp_compare(cons, builtin_greater); -} - -ao_poly -ao_lisp_do_less_equal(struct ao_lisp_cons *cons) -{ - return ao_lisp_compare(cons, builtin_less_equal); -} - -ao_poly -ao_lisp_do_greater_equal(struct ao_lisp_cons *cons) -{ - return ao_lisp_compare(cons, builtin_greater_equal); -} - -ao_poly -ao_lisp_do_list_to_string(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_list2d3estring, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_list2d3estring, cons, 0, AO_LISP_CONS, 1)) - return AO_LISP_NIL; - return ao_lisp_string_pack(ao_lisp_poly_cons(ao_lisp_arg(cons, 0))); -} - -ao_poly -ao_lisp_do_string_to_list(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_string2d3elist, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_string2d3elist, cons, 0, AO_LISP_STRING, 0)) - return AO_LISP_NIL; - return ao_lisp_string_unpack(ao_lisp_poly_string(ao_lisp_arg(cons, 0))); -} - -ao_poly -ao_lisp_do_flush_output(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_flush2doutput, cons, 0, 0)) - return AO_LISP_NIL; - ao_lisp_os_flush(); - return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_do_led(struct ao_lisp_cons *cons) -{ - ao_poly led; - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_INT, 0)) - return AO_LISP_NIL; - led = ao_lisp_arg(cons, 0); - ao_lisp_os_led(ao_lisp_poly_int(led)); - return led; -} - -ao_poly -ao_lisp_do_delay(struct ao_lisp_cons *cons) -{ - ao_poly delay; - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_INT, 0)) - return AO_LISP_NIL; - delay = ao_lisp_arg(cons, 0); - ao_lisp_os_delay(ao_lisp_poly_int(delay)); - return delay; -} - -ao_poly -ao_lisp_do_eval(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_eval, cons, 1, 1)) - return AO_LISP_NIL; - ao_lisp_stack->state = eval_sexpr; - return cons->car; -} - -ao_poly -ao_lisp_do_apply(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_apply, cons, 2, INT_MAX)) - return AO_LISP_NIL; - ao_lisp_stack->state = eval_apply; - return ao_lisp_cons_poly(cons); -} - -ao_poly -ao_lisp_do_read(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_read, cons, 0, 0)) - return AO_LISP_NIL; - return ao_lisp_read(); -} - -ao_poly -ao_lisp_do_collect(struct ao_lisp_cons *cons) -{ - int free; - (void) cons; - free = ao_lisp_collect(AO_LISP_COLLECT_FULL); - return ao_lisp_int_poly(free); -} - -ao_poly -ao_lisp_do_nullp(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - if (ao_lisp_arg(cons, 0) == AO_LISP_NIL) - return _ao_lisp_bool_true; - else - return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_not(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - if (ao_lisp_arg(cons, 0) == _ao_lisp_bool_false) - return _ao_lisp_bool_true; - else - return _ao_lisp_bool_false; -} - -static ao_poly -ao_lisp_do_typep(int type, struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - if (ao_lisp_poly_type(ao_lisp_arg(cons, 0)) == type) - return _ao_lisp_bool_true; - return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_pairp(struct ao_lisp_cons *cons) -{ - ao_poly v; - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - v = ao_lisp_arg(cons, 0); - if (v != AO_LISP_NIL && ao_lisp_poly_type(v) == AO_LISP_CONS) - return _ao_lisp_bool_true; - return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_integerp(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) { - case AO_LISP_INT: - case AO_LISP_BIGINT: - return _ao_lisp_bool_true; - default: - return _ao_lisp_bool_false; - } -} - -ao_poly -ao_lisp_do_numberp(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) { - case AO_LISP_INT: - case AO_LISP_BIGINT: - case AO_LISP_FLOAT: - return _ao_lisp_bool_true; - default: - return _ao_lisp_bool_false; - } -} - -ao_poly -ao_lisp_do_stringp(struct ao_lisp_cons *cons) -{ - return ao_lisp_do_typep(AO_LISP_STRING, cons); -} - -ao_poly -ao_lisp_do_symbolp(struct ao_lisp_cons *cons) -{ - return ao_lisp_do_typep(AO_LISP_ATOM, cons); -} - -ao_poly -ao_lisp_do_booleanp(struct ao_lisp_cons *cons) -{ - return ao_lisp_do_typep(AO_LISP_BOOL, cons); -} - -ao_poly -ao_lisp_do_procedurep(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - switch (ao_lisp_poly_type(ao_lisp_arg(cons, 0))) { - case AO_LISP_BUILTIN: - case AO_LISP_LAMBDA: - return _ao_lisp_bool_true; - default: - return _ao_lisp_bool_false; - } -} - -/* This one is special -- a list is either nil or - * a 'proper' list with only cons cells - */ -ao_poly -ao_lisp_do_listp(struct ao_lisp_cons *cons) -{ - ao_poly v; - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - v = ao_lisp_arg(cons, 0); - for (;;) { - if (v == AO_LISP_NIL) - return _ao_lisp_bool_true; - if (ao_lisp_poly_type(v) != AO_LISP_CONS) - return _ao_lisp_bool_false; - v = ao_lisp_poly_cons(v)->cdr; - } -} - -ao_poly -ao_lisp_do_set_car(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 2, 2)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_CONS, 0)) - return AO_LISP_NIL; - return ao_lisp_poly_cons(ao_lisp_arg(cons, 0))->car = ao_lisp_arg(cons, 1); -} - -ao_poly -ao_lisp_do_set_cdr(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 2, 2)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_CONS, 0)) - return AO_LISP_NIL; - return ao_lisp_poly_cons(ao_lisp_arg(cons, 0))->cdr = ao_lisp_arg(cons, 1); -} - -ao_poly -ao_lisp_do_symbol_to_string(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_ATOM, 0)) - return AO_LISP_NIL; - return ao_lisp_string_poly(ao_lisp_string_copy(ao_lisp_poly_atom(ao_lisp_arg(cons, 0))->name)); -} - -ao_poly -ao_lisp_do_string_to_symbol(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_STRING, 0)) - return AO_LISP_NIL; - - return ao_lisp_atom_poly(ao_lisp_atom_intern(ao_lisp_poly_string(ao_lisp_arg(cons, 0)))); -} - -ao_poly -ao_lisp_do_read_char(struct ao_lisp_cons *cons) -{ - int c; - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) - return AO_LISP_NIL; - c = getchar(); - return ao_lisp_int_poly(c); -} - -ao_poly -ao_lisp_do_write_char(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_led, cons, 0, AO_LISP_INT, 0)) - return AO_LISP_NIL; - putchar(ao_lisp_poly_integer(ao_lisp_arg(cons, 0))); - return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_do_exit(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) - return AO_LISP_NIL; - ao_lisp_exception |= AO_LISP_EXIT; - return _ao_lisp_bool_true; -} - -ao_poly -ao_lisp_do_current_jiffy(struct ao_lisp_cons *cons) -{ - int jiffy; - - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) - return AO_LISP_NIL; - jiffy = ao_lisp_os_jiffy(); - return (ao_lisp_int_poly(jiffy)); -} - -ao_poly -ao_lisp_do_current_second(struct ao_lisp_cons *cons) -{ - int second; - - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) - return AO_LISP_NIL; - second = ao_lisp_os_jiffy() / AO_LISP_JIFFIES_PER_SECOND; - return (ao_lisp_int_poly(second)); -} - -ao_poly -ao_lisp_do_jiffies_per_second(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 0, 0)) - return AO_LISP_NIL; - return (ao_lisp_int_poly(AO_LISP_JIFFIES_PER_SECOND)); -} - -#define AO_LISP_BUILTIN_FUNCS -#include "ao_lisp_builtin.h" diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt deleted file mode 100644 index cb65e252..00000000 --- a/src/lisp/ao_lisp_builtin.txt +++ /dev/null @@ -1,68 +0,0 @@ -f_lambda eval -f_lambda read -nlambda lambda -nlambda nlambda -nlambda macro -f_lambda car -f_lambda cdr -f_lambda cons -f_lambda last -f_lambda length -nlambda quote -atom quasiquote -atom unquote -atom unquote_splicing unquote-splicing -f_lambda set -macro setq set! -f_lambda def -nlambda cond -nlambda begin -nlambda while -f_lambda write -f_lambda display -f_lambda plus + -f_lambda minus - -f_lambda times * -f_lambda divide / -f_lambda modulo modulo % -f_lambda remainder -f_lambda quotient -f_lambda equal = eq? eqv? -f_lambda less < -f_lambda greater > -f_lambda less_equal <= -f_lambda greater_equal >= -f_lambda list_to_string list->string -f_lambda string_to_list string->list -f_lambda flush_output flush-output -f_lambda delay -f_lambda led -f_lambda save -f_lambda restore -f_lambda call_cc call-with-current-continuation call/cc -f_lambda collect -f_lambda nullp null? -f_lambda not -f_lambda listp list? -f_lambda pairp pair? -f_lambda integerp integer? exact? exact-integer? -f_lambda numberp number? real? -f_lambda booleanp boolean? -f_lambda set_car set-car! -f_lambda set_cdr set-cdr! -f_lambda symbolp symbol? -f_lambda symbol_to_string symbol->string -f_lambda string_to_symbol string->symbol -f_lambda stringp string? -f_lambda procedurep procedure? -lambda apply -f_lambda read_char read-char -f_lambda write_char write-char -f_lambda exit -f_lambda current_jiffy current-jiffy -f_lambda current_second current-second -f_lambda jiffies_per_second jiffies-per-second -f_lambda finitep finite? -f_lambda infinitep infinite? -f_lambda inexactp inexact? -f_lambda sqrt diff --git a/src/lisp/ao_lisp_cons.c b/src/lisp/ao_lisp_cons.c deleted file mode 100644 index d3b97383..00000000 --- a/src/lisp/ao_lisp_cons.c +++ /dev/null @@ -1,184 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -static void cons_mark(void *addr) -{ - struct ao_lisp_cons *cons = addr; - - for (;;) { - ao_poly cdr = cons->cdr; - - ao_lisp_poly_mark(cons->car, 1); - if (!cdr) - break; - if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) { - ao_lisp_poly_mark(cdr, 1); - break; - } - cons = ao_lisp_poly_cons(cdr); - if (ao_lisp_mark_memory(&ao_lisp_cons_type, cons)) - break; - } -} - -static int cons_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_lisp_cons); -} - -static void cons_move(void *addr) -{ - struct ao_lisp_cons *cons = addr; - - if (!cons) - return; - - for (;;) { - ao_poly cdr; - struct ao_lisp_cons *c; - int ret; - - MDBG_MOVE("cons_move start %d (%d, %d)\n", - MDBG_OFFSET(cons), MDBG_OFFSET(ao_lisp_ref(cons->car)), MDBG_OFFSET(ao_lisp_ref(cons->cdr))); - (void) ao_lisp_poly_move(&cons->car, 1); - cdr = cons->cdr; - if (!cdr) - break; - if (ao_lisp_poly_base_type(cdr) != AO_LISP_CONS) { - (void) ao_lisp_poly_move(&cons->cdr, 0); - break; - } - c = ao_lisp_poly_cons(cdr); - ret = ao_lisp_move_memory(&ao_lisp_cons_type, (void **) &c); - if (c != ao_lisp_poly_cons(cons->cdr)) - cons->cdr = ao_lisp_cons_poly(c); - MDBG_MOVE("cons_move end %d (%d, %d)\n", - MDBG_OFFSET(cons), MDBG_OFFSET(ao_lisp_ref(cons->car)), MDBG_OFFSET(ao_lisp_ref(cons->cdr))); - if (ret) - break; - cons = c; - } -} - -const struct ao_lisp_type ao_lisp_cons_type = { - .mark = cons_mark, - .size = cons_size, - .move = cons_move, - .name = "cons", -}; - -struct ao_lisp_cons *ao_lisp_cons_free_list; - -struct ao_lisp_cons * -ao_lisp_cons_cons(ao_poly car, ao_poly cdr) -{ - struct ao_lisp_cons *cons; - - if (ao_lisp_cons_free_list) { - cons = ao_lisp_cons_free_list; - ao_lisp_cons_free_list = ao_lisp_poly_cons(cons->cdr); - } else { - ao_lisp_poly_stash(0, car); - ao_lisp_poly_stash(1, cdr); - cons = ao_lisp_alloc(sizeof (struct ao_lisp_cons)); - cdr = ao_lisp_poly_fetch(1); - car = ao_lisp_poly_fetch(0); - if (!cons) - return NULL; - } - cons->car = car; - cons->cdr = cdr; - return cons; -} - -struct ao_lisp_cons * -ao_lisp_cons_cdr(struct ao_lisp_cons *cons) -{ - ao_poly cdr = cons->cdr; - if (cdr == AO_LISP_NIL) - return NULL; - if (ao_lisp_poly_type(cdr) != AO_LISP_CONS) { - (void) ao_lisp_error(AO_LISP_INVALID, "improper list"); - return NULL; - } - return ao_lisp_poly_cons(cdr); -} - -ao_poly -ao_lisp__cons(ao_poly car, ao_poly cdr) -{ - return ao_lisp_cons_poly(ao_lisp_cons_cons(car, cdr)); -} - -void -ao_lisp_cons_free(struct ao_lisp_cons *cons) -{ -#if DBG_FREE_CONS - ao_lisp_cons_check(cons); -#endif - while (cons) { - ao_poly cdr = cons->cdr; - cons->cdr = ao_lisp_cons_poly(ao_lisp_cons_free_list); - ao_lisp_cons_free_list = cons; - cons = ao_lisp_poly_cons(cdr); - } -} - -void -ao_lisp_cons_write(ao_poly c) -{ - struct ao_lisp_cons *cons = ao_lisp_poly_cons(c); - int first = 1; - printf("("); - while (cons) { - if (!first) - printf(" "); - ao_lisp_poly_write(cons->car); - c = cons->cdr; - if (ao_lisp_poly_type(c) == AO_LISP_CONS) { - cons = ao_lisp_poly_cons(c); - first = 0; - } else { - printf(" . "); - ao_lisp_poly_write(c); - cons = NULL; - } - } - printf(")"); -} - -void -ao_lisp_cons_display(ao_poly c) -{ - struct ao_lisp_cons *cons = ao_lisp_poly_cons(c); - - while (cons) { - ao_lisp_poly_display(cons->car); - cons = ao_lisp_poly_cons(cons->cdr); - } -} - -int -ao_lisp_cons_length(struct ao_lisp_cons *cons) -{ - int len = 0; - while (cons) { - len++; - cons = ao_lisp_poly_cons(cons->cdr); - } - return len; -} diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp deleted file mode 100644 index 422bdd63..00000000 --- a/src/lisp/ao_lisp_const.lisp +++ /dev/null @@ -1,813 +0,0 @@ -; -; Copyright © 2016 Keith Packard -; -; This program is free software; you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation, either version 2 of the License, or -; (at your option) any later version. -; -; This program is distributed in the hope that it will be useful, but -; WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -; General Public License for more details. -; -; Lisp code placed in ROM - - ; return a list containing all of the arguments -(def (quote list) (lambda l l)) - -(def (quote def!) - (macro (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 ((list? 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 ) - ; (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 c) c) -(define (integer->char c) 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")) - -;(define number->string (lambda (arg . opt) -; (let ((base (if (null? opt) 10 (car opt))) - ; -; - diff --git a/src/lisp/ao_lisp_error.c b/src/lisp/ao_lisp_error.c deleted file mode 100644 index 7f909487..00000000 --- a/src/lisp/ao_lisp_error.c +++ /dev/null @@ -1,139 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include - -void -ao_lisp_error_poly(char *name, ao_poly poly, ao_poly last) -{ - int first = 1; - printf("\t\t%s(", name); - if (ao_lisp_poly_type(poly) == AO_LISP_CONS) { - if (poly) { - while (poly) { - struct ao_lisp_cons *cons = ao_lisp_poly_cons(poly); - if (!first) - printf("\t\t "); - else - first = 0; - ao_lisp_poly_write(cons->car); - printf("\n"); - if (poly == last) - break; - poly = cons->cdr; - } - printf("\t\t )\n"); - } else - printf(")\n"); - } else { - ao_lisp_poly_write(poly); - printf("\n"); - } -} - -static void tabs(int indent) -{ - while (indent--) - printf("\t"); -} - -void -ao_lisp_error_frame(int indent, char *name, struct ao_lisp_frame *frame) -{ - int f; - - tabs(indent); - printf ("%s{", name); - if (frame) { - struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); - if (frame->type & AO_LISP_FRAME_PRINT) - printf("recurse..."); - else { - frame->type |= AO_LISP_FRAME_PRINT; - for (f = 0; f < frame->num; f++) { - if (f != 0) { - tabs(indent); - printf(" "); - } - ao_lisp_poly_write(vals->vals[f].atom); - printf(" = "); - ao_lisp_poly_write(vals->vals[f].val); - printf("\n"); - } - if (frame->prev) - ao_lisp_error_frame(indent + 1, "prev: ", ao_lisp_poly_frame(frame->prev)); - frame->type &= ~AO_LISP_FRAME_PRINT; - } - tabs(indent); - printf(" }\n"); - } else - printf ("}\n"); -} - -void -ao_lisp_vprintf(char *format, va_list args) -{ - char c; - - while ((c = *format++) != '\0') { - if (c == '%') { - switch (c = *format++) { - case 'v': - ao_lisp_poly_write((ao_poly) va_arg(args, unsigned int)); - 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_lisp_printf(char *format, ...) -{ - va_list args; - va_start(args, format); - ao_lisp_vprintf(format, args); - va_end(args); -} - -ao_poly -ao_lisp_error(int error, char *format, ...) -{ - va_list args; - - ao_lisp_exception |= error; - va_start(args, format); - ao_lisp_vprintf(format, args); - putchar('\n'); - va_end(args); - ao_lisp_printf("Value: %v\n", ao_lisp_v); - ao_lisp_printf("Frame: %v\n", ao_lisp_frame_poly(ao_lisp_frame_current)); - printf("Stack:\n"); - ao_lisp_stack_write(ao_lisp_stack_poly(ao_lisp_stack)); - ao_lisp_printf("Globals: %v\n", ao_lisp_frame_poly(ao_lisp_frame_global)); - return AO_LISP_NIL; -} diff --git a/src/lisp/ao_lisp_eval.c b/src/lisp/ao_lisp_eval.c deleted file mode 100644 index c3dd2ed2..00000000 --- a/src/lisp/ao_lisp_eval.c +++ /dev/null @@ -1,578 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include - -struct ao_lisp_stack *ao_lisp_stack; -ao_poly ao_lisp_v; -uint8_t ao_lisp_skip_cons_free; - -ao_poly -ao_lisp_set_cond(struct ao_lisp_cons *c) -{ - ao_lisp_stack->state = eval_cond; - ao_lisp_stack->sexprs = ao_lisp_cons_poly(c); - return AO_LISP_NIL; -} - -static int -func_type(ao_poly func) -{ - if (func == AO_LISP_NIL) - return ao_lisp_error(AO_LISP_INVALID, "func is nil"); - switch (ao_lisp_poly_type(func)) { - case AO_LISP_BUILTIN: - return ao_lisp_poly_builtin(func)->args & AO_LISP_FUNC_MASK; - case AO_LISP_LAMBDA: - return ao_lisp_poly_lambda(func)->args; - case AO_LISP_STACK: - return AO_LISP_FUNC_LAMBDA; - default: - ao_lisp_error(AO_LISP_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_lisp_eval_sexpr(void) -{ - DBGI("sexpr: %v\n", ao_lisp_v); - switch (ao_lisp_poly_type(ao_lisp_v)) { - case AO_LISP_CONS: - if (ao_lisp_v == AO_LISP_NIL) { - if (!ao_lisp_stack->values) { - /* - * empty list evaluates to empty list - */ - ao_lisp_v = AO_LISP_NIL; - ao_lisp_stack->state = eval_val; - } else { - /* - * done with arguments, go execute it - */ - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->values)->car; - ao_lisp_stack->state = eval_exec; - } - } else { - if (!ao_lisp_stack->values) - ao_lisp_stack->list = ao_lisp_v; - /* - * Evaluate another argument and then switch - * to 'formal' to add the value to the values - * list - */ - ao_lisp_stack->sexprs = ao_lisp_v; - ao_lisp_stack->state = eval_formal; - if (!ao_lisp_stack_push()) - return 0; - /* - * push will reset the state to 'sexpr', which - * will evaluate the expression - */ - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; - } - break; - case AO_LISP_ATOM: - DBGI("..frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - ao_lisp_v = ao_lisp_atom_get(ao_lisp_v); - /* fall through */ - case AO_LISP_BOOL: - case AO_LISP_INT: - case AO_LISP_BIGINT: - case AO_LISP_FLOAT: - case AO_LISP_STRING: - case AO_LISP_BUILTIN: - case AO_LISP_LAMBDA: - ao_lisp_stack->state = eval_val; - break; - } - DBGI(".. result "); DBG_POLY(ao_lisp_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_lisp_eval_val(void) -{ - DBGI("val: "); DBG_POLY(ao_lisp_v); DBG("\n"); - /* - * Value computed, pop the stack - * to figure out what to do with the value - */ - ao_lisp_stack_pop(); - DBGI("..state %d\n", ao_lisp_stack ? ao_lisp_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_lisp_eval_formal(void) -{ - ao_poly formal; - struct ao_lisp_stack *prev; - - DBGI("formal: "); DBG_POLY(ao_lisp_v); DBG("\n"); - - /* Check what kind of function we've got */ - if (!ao_lisp_stack->values) { - switch (func_type(ao_lisp_v)) { - case AO_LISP_FUNC_LAMBDA: - DBGI(".. lambda\n"); - break; - case AO_LISP_FUNC_MACRO: - /* Evaluate the result once more */ - ao_lisp_stack->state = eval_macro; - if (!ao_lisp_stack_push()) - return 0; - - /* After the function returns, take that - * value and re-evaluate it - */ - prev = ao_lisp_poly_stack(ao_lisp_stack->prev); - ao_lisp_stack->sexprs = prev->sexprs; - - DBGI(".. start macro\n"); - DBGI("\t.. sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI("\t.. values "); DBG_POLY(ao_lisp_stack->values); DBG("\n"); - DBG_FRAMES(); - - /* fall through ... */ - case AO_LISP_FUNC_NLAMBDA: - DBGI(".. nlambda or macro\n"); - - /* use the raw sexprs as values */ - ao_lisp_stack->values = ao_lisp_stack->sexprs; - ao_lisp_stack->values_tail = AO_LISP_NIL; - ao_lisp_stack->state = eval_exec; - - /* ready to execute now */ - return 1; - case -1: - return 0; - } - } - - /* Append formal to list of values */ - formal = ao_lisp__cons(ao_lisp_v, AO_LISP_NIL); - if (!formal) - return 0; - - if (ao_lisp_stack->values_tail) - ao_lisp_poly_cons(ao_lisp_stack->values_tail)->cdr = formal; - else - ao_lisp_stack->values = formal; - ao_lisp_stack->values_tail = formal; - - DBGI(".. values "); DBG_POLY(ao_lisp_stack->values); DBG("\n"); - - /* - * Step to the next argument, if this is last, then - * 'sexpr' will end up switching to 'exec' - */ - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; - - ao_lisp_stack->state = eval_sexpr; - - DBGI(".. "); DBG_POLY(ao_lisp_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_lisp_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_lisp_eval_exec(void) -{ - ao_poly v; - struct ao_lisp_builtin *builtin; - - DBGI("exec: "); DBG_POLY(ao_lisp_v); DBG(" values "); DBG_POLY(ao_lisp_stack->values); DBG ("\n"); - ao_lisp_stack->sexprs = AO_LISP_NIL; - switch (ao_lisp_poly_type(ao_lisp_v)) { - case AO_LISP_BUILTIN: - ao_lisp_stack->state = eval_val; - builtin = ao_lisp_poly_builtin(ao_lisp_v); - v = ao_lisp_func(builtin) ( - ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->values)->cdr)); - DBG_DO(if (!ao_lisp_exception && ao_lisp_poly_builtin(ao_lisp_v)->func == builtin_set) { - struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); - ao_poly atom = ao_lisp_arg(cons, 1); - ao_poly val = ao_lisp_arg(cons, 2); - DBGI("set "); DBG_POLY(atom); DBG(" = "); DBG_POLY(val); DBG("\n"); - }); - builtin = ao_lisp_poly_builtin(ao_lisp_v); - if (builtin && (builtin->args & AO_LISP_FUNC_FREE_ARGS) && !ao_lisp_stack_marked(ao_lisp_stack) && !ao_lisp_skip_cons_free) { - struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); - ao_lisp_stack->values = AO_LISP_NIL; - ao_lisp_cons_free(cons); - } - - ao_lisp_v = v; - ao_lisp_stack->values = AO_LISP_NIL; - ao_lisp_stack->values_tail = AO_LISP_NIL; - DBGI(".. result "); DBG_POLY(ao_lisp_v); DBG ("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - break; - case AO_LISP_LAMBDA: - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - ao_lisp_stack->state = eval_begin; - v = ao_lisp_lambda_eval(); - ao_lisp_stack->sexprs = v; - ao_lisp_stack->values = AO_LISP_NIL; - ao_lisp_stack->values_tail = AO_LISP_NIL; - DBGI(".. sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - break; - case AO_LISP_STACK: - DBGI(".. stack "); DBG_POLY(ao_lisp_v); DBG("\n"); - ao_lisp_v = ao_lisp_stack_eval(); - DBGI(".. value "); DBG_POLY(ao_lisp_v); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - break; - } - ao_lisp_skip_cons_free = 0; - return 1; -} - -/* - * Finish setting up the apply evaluation - * - * The value is the list to execute - */ -static int -ao_lisp_eval_apply(void) -{ - struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_v); - struct ao_lisp_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_lisp_poly_cons(prev->cdr); - if (cdr->cdr == AO_LISP_NIL) - break; - } - DBGI("before mangling: "); DBG_POLY(ao_lisp_v); DBG("\n"); - prev->cdr = cdr->car; - ao_lisp_stack->values = ao_lisp_v; - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->values)->car; - DBGI("apply: "); DBG_POLY(ao_lisp_stack->values); DBG ("\n"); - ao_lisp_stack->state = eval_exec; - ao_lisp_skip_cons_free = 1; - 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_lisp_eval_cond(void) -{ - DBGI("cond: "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); - if (!ao_lisp_stack->sexprs) { - ao_lisp_v = _ao_lisp_bool_false; - ao_lisp_stack->state = eval_val; - } else { - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car; - if (!ao_lisp_v || ao_lisp_poly_type(ao_lisp_v) != AO_LISP_CONS) { - ao_lisp_error(AO_LISP_INVALID, "invalid cond clause"); - return 0; - } - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_v)->car; - if (ao_lisp_v == _ao_lisp_atom_else) - ao_lisp_v = _ao_lisp_bool_true; - ao_lisp_stack->state = eval_cond_test; - if (!ao_lisp_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_lisp_eval_cond_test(void) -{ - DBGI("cond_test: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); - if (ao_lisp_v != _ao_lisp_bool_false) { - struct ao_lisp_cons *car = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car); - ao_poly c = car->cdr; - - if (c) { - ao_lisp_stack->state = eval_begin; - ao_lisp_stack->sexprs = c; - } else - ao_lisp_stack->state = eval_val; - } else { - ao_lisp_stack->sexprs = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; - DBGI("next cond: "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - ao_lisp_stack->state = eval_cond; - } - return 1; -} - -/* - * Evaluate a list of sexprs, returning the value from the last one. - * - * ao_lisp_begin records the list in stack->sexprs, so we just need to - * walk that list. Set ao_lisp_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_lisp_eval_begin(void) -{ - DBGI("begin: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); - - if (!ao_lisp_stack->sexprs) { - ao_lisp_v = AO_LISP_NIL; - ao_lisp_stack->state = eval_val; - } else { - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car; - ao_lisp_stack->sexprs = ao_lisp_poly_cons(ao_lisp_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_lisp_stack->sexprs) { - ao_lisp_stack->state = eval_begin; - if (!ao_lisp_stack_push()) - return 0; - } - ao_lisp_stack->state = eval_sexpr; - } - return 1; -} - -/* - * Conditionally execute a list of sexprs while the first is true - */ -static int -ao_lisp_eval_while(void) -{ - DBGI("while: "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); - - ao_lisp_stack->values = ao_lisp_v; - if (!ao_lisp_stack->sexprs) { - ao_lisp_v = AO_LISP_NIL; - ao_lisp_stack->state = eval_val; - } else { - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->car; - ao_lisp_stack->state = eval_while_test; - if (!ao_lisp_stack_push()) - return 0; - } - return 1; -} - -/* - * Check the while condition, terminate the loop if nil. Otherwise keep going - */ -static int -ao_lisp_eval_while_test(void) -{ - DBGI("while_test: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - DBGI(".. frame "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n"); - DBGI(".. saved frame "); DBG_POLY(ao_lisp_stack->frame); DBG("\n"); - - if (ao_lisp_v != _ao_lisp_bool_false) { - ao_lisp_stack->values = ao_lisp_v; - ao_lisp_v = ao_lisp_poly_cons(ao_lisp_stack->sexprs)->cdr; - ao_lisp_stack->state = eval_while; - if (!ao_lisp_stack_push()) - return 0; - ao_lisp_stack->state = eval_begin; - ao_lisp_stack->sexprs = ao_lisp_v; - } - else - { - ao_lisp_stack->state = eval_val; - ao_lisp_v = ao_lisp_stack->values; - } - return 1; -} - -/* - * Replace the original sexpr with the macro expansion, then - * execute that - */ -static int -ao_lisp_eval_macro(void) -{ - DBGI("macro: "); DBG_POLY(ao_lisp_v); DBG(" sexprs "); DBG_POLY(ao_lisp_stack->sexprs); DBG("\n"); - - if (ao_lisp_v == AO_LISP_NIL) - ao_lisp_abort(); - if (ao_lisp_poly_type(ao_lisp_v) == AO_LISP_CONS) { - *ao_lisp_poly_cons(ao_lisp_stack->sexprs) = *ao_lisp_poly_cons(ao_lisp_v); - ao_lisp_v = ao_lisp_stack->sexprs; - DBGI("sexprs rewritten to: "); DBG_POLY(ao_lisp_v); DBG("\n"); - } - ao_lisp_stack->sexprs = AO_LISP_NIL; - ao_lisp_stack->state = eval_sexpr; - return 1; -} - -static int (*const evals[])(void) = { - [eval_sexpr] = ao_lisp_eval_sexpr, - [eval_val] = ao_lisp_eval_val, - [eval_formal] = ao_lisp_eval_formal, - [eval_exec] = ao_lisp_eval_exec, - [eval_apply] = ao_lisp_eval_apply, - [eval_cond] = ao_lisp_eval_cond, - [eval_cond_test] = ao_lisp_eval_cond_test, - [eval_begin] = ao_lisp_eval_begin, - [eval_while] = ao_lisp_eval_while, - [eval_while_test] = ao_lisp_eval_while_test, - [eval_macro] = ao_lisp_eval_macro, -}; - -const char *ao_lisp_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_lisp_eval_clear_globals(void) -{ - ao_lisp_stack = NULL; - ao_lisp_frame_current = NULL; - ao_lisp_v = AO_LISP_NIL; -} - -int -ao_lisp_eval_restart(void) -{ - return ao_lisp_stack_push(); -} - -ao_poly -ao_lisp_eval(ao_poly _v) -{ - ao_lisp_v = _v; - - ao_lisp_frame_init(); - - if (!ao_lisp_stack_push()) - return AO_LISP_NIL; - - while (ao_lisp_stack) { - if (!(*evals[ao_lisp_stack->state])() || ao_lisp_exception) { - ao_lisp_stack_clear(); - return AO_LISP_NIL; - } - } - DBG_DO(if (ao_lisp_frame_current) {DBGI("frame left as "); DBG_POLY(ao_lisp_frame_poly(ao_lisp_frame_current)); DBG("\n");}); - ao_lisp_frame_current = NULL; - return ao_lisp_v; -} diff --git a/src/lisp/ao_lisp_float.c b/src/lisp/ao_lisp_float.c deleted file mode 100644 index 0aa6f2ea..00000000 --- a/src/lisp/ao_lisp_float.c +++ /dev/null @@ -1,148 +0,0 @@ -/* - * Copyright © 2017 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include - -static void float_mark(void *addr) -{ - (void) addr; -} - -static int float_size(void *addr) -{ - if (!addr) - return 0; - return sizeof (struct ao_lisp_float); -} - -static void float_move(void *addr) -{ - (void) addr; -} - -const struct ao_lisp_type ao_lisp_float_type = { - .mark = float_mark, - .size = float_size, - .move = float_move, - .name = "float", -}; - -void -ao_lisp_float_write(ao_poly p) -{ - struct ao_lisp_float *f = ao_lisp_poly_float(p); - float v = f->value; - - if (isnanf(v)) - printf("+nan.0"); - else if (isinff(v)) { - if (v < 0) - printf("-"); - else - printf("+"); - printf("inf.0"); - } else - printf ("%g", f->value); -} - -float -ao_lisp_poly_number(ao_poly p) -{ - switch (ao_lisp_poly_base_type(p)) { - case AO_LISP_INT: - return ao_lisp_poly_int(p); - case AO_LISP_OTHER: - switch (ao_lisp_other_type(ao_lisp_poly_other(p))) { - case AO_LISP_BIGINT: - return ao_lisp_bigint_int(ao_lisp_poly_bigint(p)->value); - case AO_LISP_FLOAT: - return ao_lisp_poly_float(p)->value; - } - } - return NAN; -} - -ao_poly -ao_lisp_float_get(float value) -{ - struct ao_lisp_float *f; - - f = ao_lisp_alloc(sizeof (struct ao_lisp_float)); - f->type = AO_LISP_FLOAT; - f->value = value; - return ao_lisp_float_poly(f); -} - -ao_poly -ao_lisp_do_inexactp(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - if (ao_lisp_poly_type(ao_lisp_arg(cons, 0)) == AO_LISP_FLOAT) - return _ao_lisp_bool_true; - return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_finitep(struct ao_lisp_cons *cons) -{ - ao_poly value; - float f; - - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - value = ao_lisp_arg(cons, 0); - switch (ao_lisp_poly_type(value)) { - case AO_LISP_INT: - case AO_LISP_BIGINT: - return _ao_lisp_bool_true; - case AO_LISP_FLOAT: - f = ao_lisp_poly_float(value)->value; - if (!isnan(f) && !isinf(f)) - return _ao_lisp_bool_true; - } - return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_infinitep(struct ao_lisp_cons *cons) -{ - ao_poly value; - float f; - - if (!ao_lisp_check_argc(_ao_lisp_atom_led, cons, 1, 1)) - return AO_LISP_NIL; - value = ao_lisp_arg(cons, 0); - switch (ao_lisp_poly_type(value)) { - case AO_LISP_FLOAT: - f = ao_lisp_poly_float(value)->value; - if (isinf(f)) - return _ao_lisp_bool_true; - } - return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_sqrt(struct ao_lisp_cons *cons) -{ - ao_poly value; - - if (!ao_lisp_check_argc(_ao_lisp_atom_sqrt, cons, 1, 1)) - return AO_LISP_NIL; - value = ao_lisp_arg(cons, 0); - if (!ao_lisp_number_typep(ao_lisp_poly_type(value))) - return ao_lisp_error(AO_LISP_INVALID, "%s: non-numeric", ao_lisp_poly_atom(_ao_lisp_atom_sqrt)->name); - return ao_lisp_float_get(sqrtf(ao_lisp_poly_number(value))); -} diff --git a/src/lisp/ao_lisp_frame.c b/src/lisp/ao_lisp_frame.c deleted file mode 100644 index c285527e..00000000 --- a/src/lisp/ao_lisp_frame.c +++ /dev/null @@ -1,330 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -static inline int -frame_vals_num_size(int num) -{ - return sizeof (struct ao_lisp_frame_vals) + num * sizeof (struct ao_lisp_val); -} - -static int -frame_vals_size(void *addr) -{ - struct ao_lisp_frame_vals *vals = addr; - return frame_vals_num_size(vals->size); -} - -static void -frame_vals_mark(void *addr) -{ - struct ao_lisp_frame_vals *vals = addr; - int f; - - for (f = 0; f < vals->size; f++) { - struct ao_lisp_val *v = &vals->vals[f]; - - ao_lisp_poly_mark(v->val, 0); - MDBG_MOVE("frame mark atom %s %d val %d at %d ", - ao_lisp_poly_atom(v->atom)->name, - MDBG_OFFSET(ao_lisp_ref(v->atom)), - MDBG_OFFSET(ao_lisp_ref(v->val)), f); - MDBG_DO(ao_lisp_poly_write(v->val)); - MDBG_DO(printf("\n")); - } -} - -static void -frame_vals_move(void *addr) -{ - struct ao_lisp_frame_vals *vals = addr; - int f; - - for (f = 0; f < vals->size; f++) { - struct ao_lisp_val *v = &vals->vals[f]; - - ao_lisp_poly_move(&v->atom, 0); - ao_lisp_poly_move(&v->val, 0); - MDBG_MOVE("frame move atom %s %d val %d at %d\n", - ao_lisp_poly_atom(v->atom)->name, - MDBG_OFFSET(ao_lisp_ref(v->atom)), - MDBG_OFFSET(ao_lisp_ref(v->val)), f); - } -} - -const struct ao_lisp_type ao_lisp_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_lisp_frame); -} - -static void -frame_mark(void *addr) -{ - struct ao_lisp_frame *frame = addr; - - for (;;) { - MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); - if (!AO_LISP_IS_POOL(frame)) - break; - ao_lisp_poly_mark(frame->vals, 0); - frame = ao_lisp_poly_frame(frame->prev); - MDBG_MOVE("frame next %d\n", MDBG_OFFSET(frame)); - if (!frame) - break; - if (ao_lisp_mark_memory(&ao_lisp_frame_type, frame)) - break; - } -} - -static void -frame_move(void *addr) -{ - struct ao_lisp_frame *frame = addr; - - for (;;) { - struct ao_lisp_frame *prev; - int ret; - - MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); - if (!AO_LISP_IS_POOL(frame)) - break; - ao_lisp_poly_move(&frame->vals, 0); - prev = ao_lisp_poly_frame(frame->prev); - if (!prev) - break; - ret = ao_lisp_move_memory(&ao_lisp_frame_type, (void **) &prev); - if (prev != ao_lisp_poly_frame(frame->prev)) { - MDBG_MOVE("frame prev moved from %d to %d\n", - MDBG_OFFSET(ao_lisp_poly_frame(frame->prev)), - MDBG_OFFSET(prev)); - frame->prev = ao_lisp_frame_poly(prev); - } - if (ret) - break; - frame = prev; - } -} - -const struct ao_lisp_type ao_lisp_frame_type = { - .mark = frame_mark, - .size = frame_size, - .move = frame_move, - .name = "frame", -}; - -void -ao_lisp_frame_write(ao_poly p) -{ - struct ao_lisp_frame *frame = ao_lisp_poly_frame(p); - struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); - int f; - - printf ("{"); - if (frame) { - if (frame->type & AO_LISP_FRAME_PRINT) - printf("recurse..."); - else { - frame->type |= AO_LISP_FRAME_PRINT; - for (f = 0; f < frame->num; f++) { - if (f != 0) - printf(", "); - ao_lisp_poly_write(vals->vals[f].atom); - printf(" = "); - ao_lisp_poly_write(vals->vals[f].val); - } - if (frame->prev) - ao_lisp_poly_write(frame->prev); - frame->type &= ~AO_LISP_FRAME_PRINT; - } - } - printf("}"); -} - -static int -ao_lisp_frame_find(struct ao_lisp_frame *frame, int top, ao_poly atom) -{ - struct ao_lisp_frame_vals *vals = ao_lisp_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_lisp_frame_ref(struct ao_lisp_frame *frame, ao_poly atom) -{ - struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); - int l = ao_lisp_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_lisp_frame *ao_lisp_frame_free_list[AO_LISP_FRAME_FREE]; - -static struct ao_lisp_frame_vals * -ao_lisp_frame_vals_new(int num) -{ - struct ao_lisp_frame_vals *vals; - - vals = ao_lisp_alloc(frame_vals_num_size(num)); - if (!vals) - return NULL; - vals->type = AO_LISP_FRAME_VALS; - vals->size = num; - memset(vals->vals, '\0', num * sizeof (struct ao_lisp_val)); - return vals; -} - -struct ao_lisp_frame * -ao_lisp_frame_new(int num) -{ - struct ao_lisp_frame *frame; - struct ao_lisp_frame_vals *vals; - - if (num < AO_LISP_FRAME_FREE && (frame = ao_lisp_frame_free_list[num])) { - ao_lisp_frame_free_list[num] = ao_lisp_poly_frame(frame->prev); - vals = ao_lisp_poly_frame_vals(frame->vals); - } else { - frame = ao_lisp_alloc(sizeof (struct ao_lisp_frame)); - if (!frame) - return NULL; - frame->type = AO_LISP_FRAME; - frame->num = 0; - frame->prev = AO_LISP_NIL; - frame->vals = AO_LISP_NIL; - ao_lisp_frame_stash(0, frame); - vals = ao_lisp_frame_vals_new(num); - frame = ao_lisp_frame_fetch(0); - if (!vals) - return NULL; - frame->vals = ao_lisp_frame_vals_poly(vals); - frame->num = num; - } - frame->prev = AO_LISP_NIL; - return frame; -} - -ao_poly -ao_lisp_frame_mark(struct ao_lisp_frame *frame) -{ - if (!frame) - return AO_LISP_NIL; - frame->type |= AO_LISP_FRAME_MARK; - return ao_lisp_frame_poly(frame); -} - -void -ao_lisp_frame_free(struct ao_lisp_frame *frame) -{ - if (frame && !ao_lisp_frame_marked(frame)) { - int num = frame->num; - if (num < AO_LISP_FRAME_FREE) { - struct ao_lisp_frame_vals *vals; - - vals = ao_lisp_poly_frame_vals(frame->vals); - memset(vals->vals, '\0', vals->size * sizeof (struct ao_lisp_val)); - frame->prev = ao_lisp_frame_poly(ao_lisp_frame_free_list[num]); - ao_lisp_frame_free_list[num] = frame; - } - } -} - -static struct ao_lisp_frame * -ao_lisp_frame_realloc(struct ao_lisp_frame *frame, int new_num) -{ - struct ao_lisp_frame_vals *vals; - struct ao_lisp_frame_vals *new_vals; - int copy; - - if (new_num == frame->num) - return frame; - ao_lisp_frame_stash(0, frame); - new_vals = ao_lisp_frame_vals_new(new_num); - frame = ao_lisp_frame_fetch(0); - if (!new_vals) - return NULL; - vals = ao_lisp_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_lisp_val)); - frame->vals = ao_lisp_frame_vals_poly(new_vals); - frame->num = new_num; - return frame; -} - -void -ao_lisp_frame_bind(struct ao_lisp_frame *frame, int num, ao_poly atom, ao_poly val) -{ - struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(frame->vals); - int l = ao_lisp_frame_find(frame, num, atom); - - memmove(&vals->vals[l+1], - &vals->vals[l], - (num - l) * sizeof (struct ao_lisp_val)); - vals->vals[l].atom = atom; - vals->vals[l].val = val; -} - -ao_poly -ao_lisp_frame_add(struct ao_lisp_frame *frame, ao_poly atom, ao_poly val) -{ - ao_poly *ref = frame ? ao_lisp_frame_ref(frame, atom) : NULL; - - if (!ref) { - int f = frame->num; - ao_lisp_poly_stash(0, atom); - ao_lisp_poly_stash(1, val); - frame = ao_lisp_frame_realloc(frame, f + 1); - val = ao_lisp_poly_fetch(1); - atom = ao_lisp_poly_fetch(0); - if (!frame) - return AO_LISP_NIL; - ao_lisp_frame_bind(frame, frame->num - 1, atom, val); - } else - *ref = val; - return val; -} - -struct ao_lisp_frame *ao_lisp_frame_global; -struct ao_lisp_frame *ao_lisp_frame_current; - -void -ao_lisp_frame_init(void) -{ - if (!ao_lisp_frame_global) - ao_lisp_frame_global = ao_lisp_frame_new(0); -} diff --git a/src/lisp/ao_lisp_int.c b/src/lisp/ao_lisp_int.c deleted file mode 100644 index 8e467755..00000000 --- a/src/lisp/ao_lisp_int.c +++ /dev/null @@ -1,79 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -void -ao_lisp_int_write(ao_poly p) -{ - int i = ao_lisp_poly_int(p); - printf("%d", i); -} - -int32_t -ao_lisp_poly_integer(ao_poly p) -{ - switch (ao_lisp_poly_base_type(p)) { - case AO_LISP_INT: - return ao_lisp_poly_int(p); - case AO_LISP_OTHER: - if (ao_lisp_other_type(ao_lisp_poly_other(p)) == AO_LISP_BIGINT) - return ao_lisp_bigint_int(ao_lisp_poly_bigint(p)->value); - } - return AO_LISP_NOT_INTEGER; -} - -ao_poly -ao_lisp_integer_poly(int32_t p) -{ - struct ao_lisp_bigint *bi; - - if (AO_LISP_MIN_INT <= p && p <= AO_LISP_MAX_INT) - return ao_lisp_int_poly(p); - bi = ao_lisp_alloc(sizeof (struct ao_lisp_bigint)); - bi->value = ao_lisp_int_bigint(p); - return ao_lisp_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_lisp_bigint); -} - -static void bigint_move(void *addr) -{ - (void) addr; -} - -const struct ao_lisp_type ao_lisp_bigint_type = { - .mark = bigint_mark, - .size = bigint_size, - .move = bigint_move, - .name = "bigint", -}; - -void -ao_lisp_bigint_write(ao_poly p) -{ - struct ao_lisp_bigint *bi = ao_lisp_poly_bigint(p); - - printf("%d", ao_lisp_bigint_int(bi->value)); -} diff --git a/src/lisp/ao_lisp_lambda.c b/src/lisp/ao_lisp_lambda.c deleted file mode 100644 index e72281db..00000000 --- a/src/lisp/ao_lisp_lambda.c +++ /dev/null @@ -1,208 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. - */ - -#include "ao_lisp.h" - -int -lambda_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_lisp_lambda); -} - -void -lambda_mark(void *addr) -{ - struct ao_lisp_lambda *lambda = addr; - - ao_lisp_poly_mark(lambda->code, 0); - ao_lisp_poly_mark(lambda->frame, 0); -} - -void -lambda_move(void *addr) -{ - struct ao_lisp_lambda *lambda = addr; - - ao_lisp_poly_move(&lambda->code, 0); - ao_lisp_poly_move(&lambda->frame, 0); -} - -const struct ao_lisp_type ao_lisp_lambda_type = { - .size = lambda_size, - .mark = lambda_mark, - .move = lambda_move, - .name = "lambda", -}; - -void -ao_lisp_lambda_write(ao_poly poly) -{ - struct ao_lisp_lambda *lambda = ao_lisp_poly_lambda(poly); - struct ao_lisp_cons *cons = ao_lisp_poly_cons(lambda->code); - - printf("("); - printf("%s", ao_lisp_args_name(lambda->args)); - while (cons) { - printf(" "); - ao_lisp_poly_write(cons->car); - cons = ao_lisp_poly_cons(cons->cdr); - } - printf(")"); -} - -ao_poly -ao_lisp_lambda_alloc(struct ao_lisp_cons *code, int args) -{ - struct ao_lisp_lambda *lambda; - ao_poly formal; - struct ao_lisp_cons *cons; - - formal = ao_lisp_arg(code, 0); - while (formal != AO_LISP_NIL) { - switch (ao_lisp_poly_type(formal)) { - case AO_LISP_CONS: - cons = ao_lisp_poly_cons(formal); - if (ao_lisp_poly_type(cons->car) != AO_LISP_ATOM) - return ao_lisp_error(AO_LISP_INVALID, "formal %p is not atom", cons->car); - formal = cons->cdr; - break; - case AO_LISP_ATOM: - formal = AO_LISP_NIL; - break; - default: - return ao_lisp_error(AO_LISP_INVALID, "formal %p is not atom", formal); - } - } - - ao_lisp_cons_stash(0, code); - lambda = ao_lisp_alloc(sizeof (struct ao_lisp_lambda)); - code = ao_lisp_cons_fetch(0); - if (!lambda) - return AO_LISP_NIL; - - lambda->type = AO_LISP_LAMBDA; - lambda->args = args; - lambda->code = ao_lisp_cons_poly(code); - lambda->frame = ao_lisp_frame_mark(ao_lisp_frame_current); - DBGI("build frame: "); DBG_POLY(lambda->frame); DBG("\n"); - DBG_STACK(); - return ao_lisp_lambda_poly(lambda); -} - -ao_poly -ao_lisp_do_lambda(struct ao_lisp_cons *cons) -{ - return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_LAMBDA); -} - -ao_poly -ao_lisp_do_nlambda(struct ao_lisp_cons *cons) -{ - return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_NLAMBDA); -} - -ao_poly -ao_lisp_do_macro(struct ao_lisp_cons *cons) -{ - return ao_lisp_lambda_alloc(cons, AO_LISP_FUNC_MACRO); -} - -ao_poly -ao_lisp_lambda_eval(void) -{ - struct ao_lisp_lambda *lambda = ao_lisp_poly_lambda(ao_lisp_v); - struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); - struct ao_lisp_cons *code = ao_lisp_poly_cons(lambda->code); - ao_poly formals; - struct ao_lisp_frame *next_frame; - int args_wanted; - ao_poly varargs = AO_LISP_NIL; - int args_provided; - int f; - struct ao_lisp_cons *vals; - - DBGI("lambda "); DBG_POLY(ao_lisp_lambda_poly(lambda)); DBG("\n"); - - args_wanted = 0; - for (formals = ao_lisp_arg(code, 0); - ao_lisp_is_pair(formals); - formals = ao_lisp_poly_cons(formals)->cdr) - ++args_wanted; - if (formals != AO_LISP_NIL) { - if (ao_lisp_poly_type(formals) != AO_LISP_ATOM) - return ao_lisp_error(AO_LISP_INVALID, "bad lambda form"); - varargs = formals; - } - - /* Create a frame to hold the variables - */ - args_provided = ao_lisp_cons_length(cons) - 1; - if (varargs == AO_LISP_NIL) { - if (args_wanted != args_provided) - return ao_lisp_error(AO_LISP_INVALID, "need %d args, got %d", args_wanted, args_provided); - } else { - if (args_provided < args_wanted) - return ao_lisp_error(AO_LISP_INVALID, "need at least %d args, got %d", args_wanted, args_provided); - } - - ao_lisp_poly_stash(1, varargs); - next_frame = ao_lisp_frame_new(args_wanted + (varargs != AO_LISP_NIL)); - varargs = ao_lisp_poly_fetch(1); - if (!next_frame) - return AO_LISP_NIL; - - /* Re-fetch all of the values in case something moved */ - lambda = ao_lisp_poly_lambda(ao_lisp_v); - cons = ao_lisp_poly_cons(ao_lisp_stack->values); - code = ao_lisp_poly_cons(lambda->code); - formals = ao_lisp_arg(code, 0); - vals = ao_lisp_poly_cons(cons->cdr); - - next_frame->prev = lambda->frame; - ao_lisp_frame_current = next_frame; - ao_lisp_stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); - - for (f = 0; f < args_wanted; f++) { - struct ao_lisp_cons *arg = ao_lisp_poly_cons(formals); - DBGI("bind "); DBG_POLY(arg->car); DBG(" = "); DBG_POLY(vals->car); DBG("\n"); - ao_lisp_frame_bind(next_frame, f, arg->car, vals->car); - formals = arg->cdr; - vals = ao_lisp_poly_cons(vals->cdr); - } - if (varargs) { - DBGI("bind "); DBG_POLY(varargs); DBG(" = "); DBG_POLY(ao_lisp_cons_poly(vals)); DBG("\n"); - /* - * Bind the rest of the arguments to the final parameter - */ - ao_lisp_frame_bind(next_frame, f, varargs, ao_lisp_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_LISP_FUNC_LAMBDA && !ao_lisp_stack_marked(ao_lisp_stack)) { - ao_lisp_stack->values = AO_LISP_NIL; - ao_lisp_cons_free(cons); - } - } - DBGI("eval frame: "); DBG_POLY(ao_lisp_frame_poly(next_frame)); DBG("\n"); - DBG_STACK(); - DBGI("eval code: "); DBG_POLY(code->cdr); DBG("\n"); - return code->cdr; -} diff --git a/src/lisp/ao_lisp_lex.c b/src/lisp/ao_lisp_lex.c deleted file mode 100644 index fe7c47f4..00000000 --- a/src/lisp/ao_lisp_lex.c +++ /dev/null @@ -1,16 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - diff --git a/src/lisp/ao_lisp_make_builtin b/src/lisp/ao_lisp_make_builtin deleted file mode 100644 index 783ab378..00000000 --- a/src/lisp/ao_lisp_make_builtin +++ /dev/null @@ -1,190 +0,0 @@ -#!/usr/bin/nickle - -typedef struct { - 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", -}; - -string[*] -make_lisp(string[*] tokens) -{ - string[...] lisp = {}; - - if (dim(tokens) < 3) - return (string[1]) { tokens[dim(tokens) - 1] }; - return (string[dim(tokens)-2]) { [i] = tokens[i+2] }; -} - -builtin_t -read_builtin(file f) { - string line = File::fgets(f); - string[*] tokens = String::wordsplit(line, " \t"); - - return (builtin_t) { - .type = dim(tokens) > 0 ? type_map[tokens[0]] : "#", - .c_name = dim(tokens) > 1 ? tokens[1] : "#", - .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; -} - -bool is_atom(builtin_t b) = b.type == "atom"; - -void -dump_ids(builtin_t[*] builtins) { - printf("#ifdef AO_LISP_BUILTIN_ID\n"); - printf("#undef AO_LISP_BUILTIN_ID\n"); - printf("enum ao_lisp_builtin_id {\n"); - for (int i = 0; i < dim(builtins); i++) - if (!is_atom(builtins[i])) - printf("\tbuiltin_%s,\n", builtins[i].c_name); - printf("\t_builtin_last\n"); - printf("};\n"); - printf("#endif /* AO_LISP_BUILTIN_ID */\n"); -} - -void -dump_casename(builtin_t[*] builtins) { - printf("#ifdef AO_LISP_BUILTIN_CASENAME\n"); - printf("#undef AO_LISP_BUILTIN_CASENAME\n"); - printf("static char *ao_lisp_builtin_name(enum ao_lisp_builtin_id b) {\n"); - printf("\tswitch(b) {\n"); - for (int i = 0; i < dim(builtins); i++) - if (!is_atom(builtins[i])) - printf("\tcase builtin_%s: return ao_lisp_poly_atom(_atom(\"%s\"))->name;\n", - builtins[i].c_name, builtins[i].lisp_names[0]); - printf("\tdefault: return \"???\";\n"); - printf("\t}\n"); - printf("}\n"); - printf("#endif /* AO_LISP_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_LISP_BUILTIN_ARRAYNAME\n"); - printf("#undef AO_LISP_BUILTIN_ARRAYNAME\n"); - printf("static const ao_poly builtin_names[] = {\n"); - for (int i = 0; i < dim(builtins); i++) { - if (!is_atom(builtins[i])) { - printf("\t[builtin_%s] = _ao_lisp_atom_", - builtins[i].c_name); - cify_lisp(builtins[i].lisp_names[0]); - printf(",\n"); - } - } - printf("};\n"); - printf("#endif /* AO_LISP_BUILTIN_ARRAYNAME */\n"); -} - -void -dump_funcs(builtin_t[*] builtins) { - printf("#ifdef AO_LISP_BUILTIN_FUNCS\n"); - printf("#undef AO_LISP_BUILTIN_FUNCS\n"); - printf("const ao_lisp_func_t ao_lisp_builtins[] = {\n"); - for (int i = 0; i < dim(builtins); i++) { - if (!is_atom(builtins[i])) - printf("\t[builtin_%s] = ao_lisp_do_%s,\n", - builtins[i].c_name, - builtins[i].c_name); - } - printf("};\n"); - printf("#endif /* AO_LISP_BUILTIN_FUNCS */\n"); -} - -void -dump_decls(builtin_t[*] builtins) { - printf("#ifdef AO_LISP_BUILTIN_DECLS\n"); - printf("#undef AO_LISP_BUILTIN_DECLS\n"); - for (int i = 0; i < dim(builtins); i++) { - if (!is_atom(builtins[i])) { - printf("ao_poly\n"); - printf("ao_lisp_do_%s(struct ao_lisp_cons *cons);\n", - builtins[i].c_name); - } - } - printf("#endif /* AO_LISP_BUILTIN_DECLS */\n"); -} - -void -dump_consts(builtin_t[*] builtins) { - printf("#ifdef AO_LISP_BUILTIN_CONSTS\n"); - printf("#undef AO_LISP_BUILTIN_CONSTS\n"); - printf("struct builtin_func funcs[] = {\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{ .name = \"%s\", .args = AO_LISP_FUNC_%s, .func = builtin_%s },\n", - builtins[i].lisp_names[j], - builtins[i].type, - builtins[i].c_name); - } - } - } - printf("};\n"); - printf("#endif /* AO_LISP_BUILTIN_CONSTS */\n"); -} - -void -dump_atoms(builtin_t[*] builtins) { - printf("#ifdef AO_LISP_BUILTIN_ATOMS\n"); - printf("#undef AO_LISP_BUILTIN_ATOMS\n"); - for (int i = 0; i < dim(builtins); i++) { - for (int j = 0; j < dim(builtins[i].lisp_names); j++) { - printf("#define _ao_lisp_atom_"); - cify_lisp(builtins[i].lisp_names[j]); - printf(" _atom(\"%s\")\n", builtins[i].lisp_names[j]); - } - } - printf("#endif /* AO_LISP_BUILTIN_ATOMS */\n"); -} - -void main() { - if (dim(argv) < 2) { - File::fprintf(stderr, "usage: %s \n", argv[0]); - exit(1); - } - twixt(file f = File::open(argv[1], "r"); File::close(f)) { - builtin_t[*] builtins = read_builtins(f); - dump_ids(builtins); - dump_casename(builtins); - dump_arrayname(builtins); - dump_funcs(builtins); - dump_decls(builtins); - dump_consts(builtins); - dump_atoms(builtins); - } -} - -main(); diff --git a/src/lisp/ao_lisp_make_const.c b/src/lisp/ao_lisp_make_const.c deleted file mode 100644 index 6e4b411e..00000000 --- a/src/lisp/ao_lisp_make_const.c +++ /dev/null @@ -1,395 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include -#include -#include -#include - -static struct ao_lisp_builtin * -ao_lisp_make_builtin(enum ao_lisp_builtin_id func, int args) { - struct ao_lisp_builtin *b = ao_lisp_alloc(sizeof (struct ao_lisp_builtin)); - - b->type = AO_LISP_BUILTIN; - b->func = func; - b->args = args; - return b; -} - -struct builtin_func { - char *name; - int args; - enum ao_lisp_builtin_id func; -}; - -#define AO_LISP_BUILTIN_CONSTS -#include "ao_lisp_builtin.h" - -#define N_FUNC (sizeof funcs / sizeof funcs[0]) - -struct ao_lisp_frame *globals; - -static int -is_atom(int offset) -{ - struct ao_lisp_atom *a; - - for (a = ao_lisp_atoms; a; a = ao_lisp_poly_atom(a->next)) - if (((uint8_t *) a->name - ao_lisp_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; -} - -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_lisp_macro_stack { - struct ao_lisp_macro_stack *next; - ao_poly p; -}; - -struct ao_lisp_macro_stack *macro_stack; - -int -ao_lisp_macro_push(ao_poly p) -{ - struct ao_lisp_macro_stack *m = macro_stack; - - while (m) { - if (m->p == p) - return 1; - m = m->next; - } - m = malloc (sizeof (struct ao_lisp_macro_stack)); - m->p = p; - m->next = macro_stack; - macro_stack = m; - return 0; -} - -void -ao_lisp_macro_pop(void) -{ - struct ao_lisp_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); - -ao_poly -ao_macro_test_get(ao_poly atom) -{ - ao_poly *ref = ao_lisp_atom_ref(atom); - if (ref) - return *ref; - return AO_LISP_NIL; -} - -ao_poly -ao_is_macro(ao_poly p) -{ - struct ao_lisp_builtin *builtin; - struct ao_lisp_lambda *lambda; - ao_poly ret; - - MACRO_DEBUG(indent(); printf ("is macro "); ao_lisp_poly_write(p); printf("\n"); ++macro_scan_depth); - switch (ao_lisp_poly_type(p)) { - case AO_LISP_ATOM: - if (ao_lisp_macro_push(p)) - ret = AO_LISP_NIL; - else { - if (ao_is_macro(ao_macro_test_get(p))) - ret = p; - else - ret = AO_LISP_NIL; - ao_lisp_macro_pop(); - } - break; - case AO_LISP_CONS: - ret = ao_has_macro(p); - break; - case AO_LISP_BUILTIN: - builtin = ao_lisp_poly_builtin(p); - if ((builtin->args & AO_LISP_FUNC_MASK) == AO_LISP_FUNC_MACRO) - ret = p; - else - ret = 0; - break; - - case AO_LISP_LAMBDA: - lambda = ao_lisp_poly_lambda(p); - if (lambda->args == AO_LISP_FUNC_MACRO) - ret = p; - else - ret = ao_has_macro(lambda->code); - break; - default: - ret = AO_LISP_NIL; - break; - } - MACRO_DEBUG(--macro_scan_depth; indent(); printf ("... "); ao_lisp_poly_write(ret); printf("\n")); - return ret; -} - -ao_poly -ao_has_macro(ao_poly p) -{ - struct ao_lisp_cons *cons; - struct ao_lisp_lambda *lambda; - ao_poly m; - ao_poly list; - - if (p == AO_LISP_NIL) - return AO_LISP_NIL; - - MACRO_DEBUG(indent(); printf("has macro "); ao_lisp_poly_write(p); printf("\n"); ++macro_scan_depth); - switch (ao_lisp_poly_type(p)) { - case AO_LISP_LAMBDA: - lambda = ao_lisp_poly_lambda(p); - p = ao_has_macro(lambda->code); - break; - case AO_LISP_CONS: - cons = ao_lisp_poly_cons(p); - if ((p = ao_is_macro(cons->car))) - break; - - list = cons->cdr; - p = AO_LISP_NIL; - while (list != AO_LISP_NIL && ao_lisp_poly_type(list) == AO_LISP_CONS) { - cons = ao_lisp_poly_cons(list); - m = ao_has_macro(cons->car); - if (m) { - p = m; - break; - } - list = cons->cdr; - } - break; - - default: - p = AO_LISP_NIL; - break; - } - MACRO_DEBUG(--macro_scan_depth; indent(); printf("... "); ao_lisp_poly_write(p); printf("\n")); - return p; -} - -int -ao_lisp_read_eval_abort(void) -{ - ao_poly in, out = AO_LISP_NIL; - for(;;) { - in = ao_lisp_read(); - if (in == _ao_lisp_atom_eof) - break; - out = ao_lisp_eval(in); - if (ao_lisp_exception) - return 0; - ao_lisp_poly_write(out); - putchar ('\n'); - } - return 1; -} - -static FILE *in; -static FILE *out; - -int -ao_lisp_getc(void) -{ - return getc(in); -} - -static const struct option options[] = { - { .name = "out", .has_arg = 1, .val = 'o' }, - { 0, 0, 0, 0 } -}; - -static void usage(char *program) -{ - fprintf(stderr, "usage: %s [--out=] [input]\n", program); - exit(1); -} - -int -main(int argc, char **argv) -{ - int f, o; - ao_poly val; - struct ao_lisp_atom *a; - struct ao_lisp_builtin *b; - int in_atom = 0; - char *out_name = NULL; - int c; - enum ao_lisp_builtin_id prev_func; - - in = stdin; - out = stdout; - - while ((c = getopt_long(argc, argv, "o:", options, NULL)) != -1) { - switch (c) { - case 'o': - out_name = optarg; - break; - default: - usage(argv[0]); - break; - } - } - - ao_lisp_frame_init(); - - /* Boolean values #f and #t */ - ao_lisp_bool_get(0); - ao_lisp_bool_get(1); - - prev_func = _builtin_last; - for (f = 0; f < (int) N_FUNC; f++) { - if (funcs[f].func != prev_func) - b = ao_lisp_make_builtin(funcs[f].func, funcs[f].args); - a = ao_lisp_atom_intern(funcs[f].name); - ao_lisp_atom_def(ao_lisp_atom_poly(a), - ao_lisp_builtin_poly(b)); - } - - /* end of file value */ - a = ao_lisp_atom_intern("eof"); - ao_lisp_atom_def(ao_lisp_atom_poly(a), - ao_lisp_atom_poly(a)); - - /* 'else' */ - a = ao_lisp_atom_intern("else"); - - if (argv[optind]){ - in = fopen(argv[optind], "r"); - if (!in) { - perror(argv[optind]); - exit(1); - } - } - if (!ao_lisp_read_eval_abort()) { - fprintf(stderr, "eval failed\n"); - exit(1); - } - - /* Reduce to referenced values */ - ao_lisp_collect(AO_LISP_COLLECT_FULL); - - for (f = 0; f < ao_lisp_frame_global->num; f++) { - struct ao_lisp_frame_vals *vals = ao_lisp_poly_frame_vals(ao_lisp_frame_global->vals); - val = ao_has_macro(vals->vals[f].val); - if (val != AO_LISP_NIL) { - printf("error: function %s contains unresolved macro: ", - ao_lisp_poly_atom(vals->vals[f].atom)->name); - ao_lisp_poly_write(val); - printf("\n"); - exit(1); - } - } - - if (out_name) { - out = fopen(out_name, "w"); - if (!out) { - perror(out_name); - exit(1); - } - } - - fprintf(out, "/* Generated file, do not edit */\n\n"); - - fprintf(out, "#define AO_LISP_POOL_CONST %d\n", ao_lisp_top); - fprintf(out, "extern const uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4)));\n"); - fprintf(out, "#define ao_builtin_atoms 0x%04x\n", ao_lisp_atom_poly(ao_lisp_atoms)); - fprintf(out, "#define ao_builtin_frame 0x%04x\n", ao_lisp_frame_poly(ao_lisp_frame_global)); - fprintf(out, "#define ao_lisp_const_checksum ((uint16_t) 0x%04x)\n", ao_fec_crc(ao_lisp_const, ao_lisp_top)); - - fprintf(out, "#define _ao_lisp_bool_false 0x%04x\n", ao_lisp_bool_poly(ao_lisp_false)); - fprintf(out, "#define _ao_lisp_bool_true 0x%04x\n", ao_lisp_bool_poly(ao_lisp_true)); - - for (a = ao_lisp_atoms; a; a = ao_lisp_poly_atom(a->next)) { - char *n = a->name, c; - fprintf(out, "#define _ao_lisp_atom_"); - while ((c = *n++)) { - if (isalnum(c)) - fprintf(out, "%c", c); - else - fprintf(out, "%02x", c); - } - fprintf(out, " 0x%04x\n", ao_lisp_atom_poly(a)); - } - fprintf(out, "#ifdef AO_LISP_CONST_BITS\n"); - fprintf(out, "const uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute((aligned(4))) = {"); - for (o = 0; o < ao_lisp_top; o++) { - uint8_t c; - if ((o & 0xf) == 0) - fprintf(out, "\n\t"); - else - fprintf(out, " "); - c = ao_lisp_const[o]; - if (!in_atom) - in_atom = is_atom(o); - if (in_atom) { - fprintf(out, " '%c',", c); - in_atom--; - } else { - fprintf(out, "0x%02x,", c); - } - } - fprintf(out, "\n};\n"); - fprintf(out, "#endif /* AO_LISP_CONST_BITS */\n"); - exit(0); -} diff --git a/src/lisp/ao_lisp_mem.c b/src/lisp/ao_lisp_mem.c deleted file mode 100644 index 5471b137..00000000 --- a/src/lisp/ao_lisp_mem.c +++ /dev/null @@ -1,968 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#define AO_LISP_CONST_BITS - -#include "ao_lisp.h" -#include -#include - -#ifdef AO_LISP_MAKE_CONST - -/* - * When building the constant table, it is the - * pool for allocations. - */ - -#include -uint8_t ao_lisp_const[AO_LISP_POOL_CONST] __attribute__((aligned(4))); -#define ao_lisp_pool ao_lisp_const -#undef AO_LISP_POOL -#define AO_LISP_POOL AO_LISP_POOL_CONST - -#else - -uint8_t ao_lisp_pool[AO_LISP_POOL + AO_LISP_POOL_EXTRA] __attribute__((aligned(4))); - -#endif - -#ifndef DBG_MEM_STATS -#define DBG_MEM_STATS DBG_MEM -#endif - -#if DBG_MEM -int dbg_move_depth; -int dbg_mem = DBG_MEM_START; -int dbg_validate = 0; - -struct ao_lisp_record { - struct ao_lisp_record *next; - const struct ao_lisp_type *type; - void *addr; - int size; -}; - -static struct ao_lisp_record *record_head, **record_tail; - -static void -ao_lisp_record_free(struct ao_lisp_record *record) -{ - while (record) { - struct ao_lisp_record *next = record->next; - free(record); - record = next; - } -} - -static void -ao_lisp_record_reset(void) -{ - ao_lisp_record_free(record_head); - record_head = NULL; - record_tail = &record_head; -} - -static void -ao_lisp_record(const struct ao_lisp_type *type, - void *addr, - int size) -{ - struct ao_lisp_record *r = malloc(sizeof (struct ao_lisp_record)); - - r->next = NULL; - r->type = type; - r->addr = addr; - r->size = size; - *record_tail = r; - record_tail = &r->next; -} - -static struct ao_lisp_record * -ao_lisp_record_save(void) -{ - struct ao_lisp_record *r = record_head; - - record_head = NULL; - record_tail = &record_head; - return r; -} - -static void -ao_lisp_record_compare(char *where, - struct ao_lisp_record *a, - struct ao_lisp_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_lisp_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_lisp_abort(); - } - if (b) { - printf("%s record differs NULL -> %d %s %d\n", - where, - MDBG_OFFSET(b->addr), - b->type->name, - b->size); - ao_lisp_abort(); - } -} - -#else -#define ao_lisp_record_reset() -#endif - -uint8_t ao_lisp_exception; - -struct ao_lisp_root { - const struct ao_lisp_type *type; - void **addr; -}; - -static struct ao_lisp_cons *save_cons[2]; -static char *save_string[2]; -static struct ao_lisp_frame *save_frame[1]; -static ao_poly save_poly[3]; - -static const struct ao_lisp_root ao_lisp_root[] = { - { - .type = &ao_lisp_cons_type, - .addr = (void **) &save_cons[0], - }, - { - .type = &ao_lisp_cons_type, - .addr = (void **) &save_cons[1], - }, - { - .type = &ao_lisp_string_type, - .addr = (void **) &save_string[0], - }, - { - .type = &ao_lisp_string_type, - .addr = (void **) &save_string[1], - }, - { - .type = &ao_lisp_frame_type, - .addr = (void **) &save_frame[0], - }, - { - .type = NULL, - .addr = (void **) (void *) &save_poly[0] - }, - { - .type = NULL, - .addr = (void **) (void *) &save_poly[1] - }, - { - .type = NULL, - .addr = (void **) (void *) &save_poly[2] - }, - { - .type = &ao_lisp_atom_type, - .addr = (void **) &ao_lisp_atoms - }, - { - .type = &ao_lisp_frame_type, - .addr = (void **) &ao_lisp_frame_global, - }, - { - .type = &ao_lisp_frame_type, - .addr = (void **) &ao_lisp_frame_current, - }, - { - .type = &ao_lisp_stack_type, - .addr = (void **) &ao_lisp_stack, - }, - { - .type = NULL, - .addr = (void **) (void *) &ao_lisp_v, - }, - { - .type = &ao_lisp_cons_type, - .addr = (void **) &ao_lisp_read_cons, - }, - { - .type = &ao_lisp_cons_type, - .addr = (void **) &ao_lisp_read_cons_tail, - }, - { - .type = &ao_lisp_cons_type, - .addr = (void **) &ao_lisp_read_stack, - }, -#ifdef AO_LISP_MAKE_CONST - { - .type = &ao_lisp_bool_type, - .addr = (void **) &ao_lisp_false, - }, - { - .type = &ao_lisp_bool_type, - .addr = (void **) &ao_lisp_true, - }, -#endif -}; - -#define AO_LISP_ROOT (sizeof (ao_lisp_root) / sizeof (ao_lisp_root[0])) - -static const void ** const ao_lisp_cache[] = { - (const void **) &ao_lisp_cons_free_list, - (const void **) &ao_lisp_stack_free_list, - (const void **) &ao_lisp_frame_free_list[0], - (const void **) &ao_lisp_frame_free_list[1], - (const void **) &ao_lisp_frame_free_list[2], - (const void **) &ao_lisp_frame_free_list[3], - (const void **) &ao_lisp_frame_free_list[4], - (const void **) &ao_lisp_frame_free_list[5], -}; - -#if AO_LISP_FRAME_FREE != 6 -#error Unexpected AO_LISP_FRAME_FREE value -#endif - -#define AO_LISP_CACHE (sizeof (ao_lisp_cache) / sizeof (ao_lisp_cache[0])) - -#define AO_LISP_BUSY_SIZE ((AO_LISP_POOL + 31) / 32) - -static uint8_t ao_lisp_busy[AO_LISP_BUSY_SIZE]; -static uint8_t ao_lisp_cons_note[AO_LISP_BUSY_SIZE]; -static uint8_t ao_lisp_cons_last[AO_LISP_BUSY_SIZE]; -static uint8_t ao_lisp_cons_noted; - -uint16_t ao_lisp_top; - -struct ao_lisp_chunk { - uint16_t old_offset; - union { - uint16_t size; - uint16_t new_offset; - }; -}; - -#define AO_LISP_NCHUNK 64 - -static struct ao_lisp_chunk ao_lisp_chunk[AO_LISP_NCHUNK]; - -/* Offset of an address within the pool. */ -static inline uint16_t pool_offset(void *addr) { -#if DBG_MEM - if (!AO_LISP_IS_POOL(addr)) - ao_lisp_abort(); -#endif - return ((uint8_t *) addr) - ao_lisp_pool; -} - -static inline void mark(uint8_t *tag, int offset) { - int byte = offset >> 5; - int bit = (offset >> 2) & 7; - 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_LISP_POOL, max(offset, 0)); -} - -static void -note_cons(uint16_t offset) -{ - MDBG_MOVE("note cons %d\n", offset); - ao_lisp_cons_noted = 1; - mark(ao_lisp_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_lisp_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; - - 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_LISP_NCHUNK) - ao_lisp_abort(); - - /* Off the left side */ - if (l == 0 && chunk_last && offset > ao_lisp_chunk[0].old_offset) - ao_lisp_abort(); -#endif - - /* Shuffle existing entries right */ - int end = min(AO_LISP_NCHUNK, chunk_last + 1); - - memmove(&ao_lisp_chunk[l+1], - &ao_lisp_chunk[l], - (end - (l+1)) * sizeof (struct ao_lisp_chunk)); - - /* Add new entry */ - ao_lisp_chunk[l].old_offset = offset; - ao_lisp_chunk[l].size = size; - - /* Increment the number of elements up to the size of the array */ - if (chunk_last < AO_LISP_NCHUNK) - chunk_last++; - - /* Set the top address if the array is full */ - if (chunk_last == AO_LISP_NCHUNK) - chunk_high = ao_lisp_chunk[AO_LISP_NCHUNK-1].old_offset + - ao_lisp_chunk[AO_LISP_NCHUNK-1].size; -} - -static void -reset_chunks(void) -{ - chunk_high = ao_lisp_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_lisp_type *type, void **addr), - int (*visit_poly)(ao_poly *p, uint8_t do_note_cons)) -{ - int i; - - ao_lisp_record_reset(); - memset(ao_lisp_busy, '\0', sizeof (ao_lisp_busy)); - memset(ao_lisp_cons_note, '\0', sizeof (ao_lisp_cons_note)); - ao_lisp_cons_noted = 0; - for (i = 0; i < (int) AO_LISP_ROOT; i++) { - if (ao_lisp_root[i].type) { - void **a = ao_lisp_root[i].addr, *v; - if (a && (v = *a)) { - MDBG_MOVE("root ptr %d\n", MDBG_OFFSET(v)); - visit_addr(ao_lisp_root[i].type, a); - } - } else { - ao_poly *a = (ao_poly *) ao_lisp_root[i].addr, p; - if (a && (p = *a)) { - MDBG_MOVE("root poly %d\n", MDBG_OFFSET(ao_lisp_ref(p))); - visit_poly(a, 0); - } - } - } - while (ao_lisp_cons_noted) { - memcpy(ao_lisp_cons_last, ao_lisp_cons_note, sizeof (ao_lisp_cons_note)); - memset(ao_lisp_cons_note, '\0', sizeof (ao_lisp_cons_note)); - ao_lisp_cons_noted = 0; - for (i = 0; i < AO_LISP_POOL; i += 4) { - if (busy(ao_lisp_cons_last, i)) { - void *v = ao_lisp_pool + i; - MDBG_MOVE("root cons %d\n", MDBG_OFFSET(v)); - visit_addr(&ao_lisp_cons_type, &v); - } - } - } -} - -#if MDBG_DUMP -static void -dump_busy(void) -{ - int i; - MDBG_MOVE("busy:"); - for (i = 0; i < ao_lisp_top; i += 4) { - if ((i & 0xff) == 0) { - MDBG_MORE("\n"); - MDBG_MOVE("%s", ""); - } - else if ((i & 0x1f) == 0) - MDBG_MORE(" "); - if (busy(ao_lisp_busy, i)) - MDBG_MORE("*"); - else - MDBG_MORE("-"); - } - MDBG_MORE ("\n"); -} -#define DUMP_BUSY() dump_busy() -#else -#define DUMP_BUSY() -#endif - -static const struct ao_lisp_type *ao_lisp_types[AO_LISP_NUM_TYPE] = { - [AO_LISP_CONS] = &ao_lisp_cons_type, - [AO_LISP_INT] = NULL, - [AO_LISP_STRING] = &ao_lisp_string_type, - [AO_LISP_OTHER] = (void *) 0x1, - [AO_LISP_ATOM] = &ao_lisp_atom_type, - [AO_LISP_BUILTIN] = &ao_lisp_builtin_type, - [AO_LISP_FRAME] = &ao_lisp_frame_type, - [AO_LISP_FRAME_VALS] = &ao_lisp_frame_vals_type, - [AO_LISP_LAMBDA] = &ao_lisp_lambda_type, - [AO_LISP_STACK] = &ao_lisp_stack_type, - [AO_LISP_BOOL] = &ao_lisp_bool_type, - [AO_LISP_BIGINT] = &ao_lisp_bigint_type, - [AO_LISP_FLOAT] = &ao_lisp_float_type, -}; - -static int -ao_lisp_mark_ref(const struct ao_lisp_type *type, void **ref) -{ - return ao_lisp_mark(type, *ref); -} - -static int -ao_lisp_poly_mark_ref(ao_poly *p, uint8_t do_note_cons) -{ - return ao_lisp_poly_mark(*p, do_note_cons); -} - -#if DBG_MEM_STATS -int ao_lisp_collects[2]; -int ao_lisp_freed[2]; -int ao_lisp_loops[2]; -#endif - -int ao_lisp_last_top; - -int -ao_lisp_collect(uint8_t style) -{ - int i; - int top; -#if DBG_MEM_STATS - int loops = 0; -#endif -#if DBG_MEM - struct ao_lisp_record *mark_record = NULL, *move_record = NULL; - - MDBG_MOVE("collect %d\n", ao_lisp_collects[style]); -#endif - MDBG_DO(ao_lisp_frame_write(ao_lisp_frame_poly(ao_lisp_frame_global))); - - /* The first time through, we're doing a full collect */ - if (ao_lisp_last_top == 0) - style = AO_LISP_COLLECT_FULL; - - /* Clear references to all caches */ - for (i = 0; i < (int) AO_LISP_CACHE; i++) - *ao_lisp_cache[i] = NULL; - if (style == AO_LISP_COLLECT_FULL) { - chunk_low = top = 0; - } else { - chunk_low = top = ao_lisp_last_top; - } - for (;;) { -#if DBG_MEM_STATS - loops++; -#endif - MDBG_MOVE("move chunks from %d to %d\n", chunk_low, top); - /* Find the sizes of the first chunk of objects to move */ - reset_chunks(); - walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref); -#if DBG_MEM - - ao_lisp_record_free(mark_record); - mark_record = ao_lisp_record_save(); - if (mark_record && move_record) - ao_lisp_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_lisp_chunk[i].size; - -#if DBG_MEM - if (!size) - ao_lisp_abort(); -#endif - - if (ao_lisp_chunk[i].old_offset > top) - break; - - MDBG_MOVE("chunk %d %d not moving\n", - ao_lisp_chunk[i].old_offset, - ao_lisp_chunk[i].size); -#if DBG_MEM - if (ao_lisp_chunk[i].old_offset != top) - ao_lisp_abort(); -#endif - top += size; - } - - /* - * Limit amount of chunk array used in mapping moves - * to the active region - */ - chunk_first = i; - chunk_low = ao_lisp_chunk[i].old_offset; - - /* Copy all of the objects */ - for (; i < chunk_last; i++) { - uint16_t size = ao_lisp_chunk[i].size; - -#if DBG_MEM - if (!size) - ao_lisp_abort(); -#endif - - MDBG_MOVE("chunk %d %d -> %d\n", - ao_lisp_chunk[i].old_offset, - size, - top); - ao_lisp_chunk[i].new_offset = top; - - memmove(&ao_lisp_pool[top], - &ao_lisp_pool[ao_lisp_chunk[i].old_offset], - size); - - top += size; - } - - if (chunk_first < chunk_last) { - /* Relocate all references to the objects */ - walk(ao_lisp_move, ao_lisp_poly_move); - -#if DBG_MEM - ao_lisp_record_free(move_record); - move_record = ao_lisp_record_save(); - if (mark_record && move_record) - ao_lisp_record_compare("move", mark_record, move_record); -#endif - } - - /* If we ran into the end of the heap, then - * there's no need to keep walking - */ - if (chunk_last != AO_LISP_NCHUNK) - break; - - /* Next loop starts right above this loop */ - chunk_low = chunk_high; - } - -#if DBG_MEM_STATS - /* Collect stats */ - ++ao_lisp_collects[style]; - ao_lisp_freed[style] += ao_lisp_top - top; - ao_lisp_loops[style] += loops; -#endif - - ao_lisp_top = top; - if (style == AO_LISP_COLLECT_FULL) - ao_lisp_last_top = top; - - MDBG_DO(memset(ao_lisp_chunk, '\0', sizeof (ao_lisp_chunk)); - walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref)); - - return AO_LISP_POOL - ao_lisp_top; -} - -#if DBG_FREE_CONS -void -ao_lisp_cons_check(struct ao_lisp_cons *cons) -{ - ao_poly cdr; - int offset; - - chunk_low = 0; - reset_chunks(); - walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref); - while (cons) { - if (!AO_LISP_IS_POOL(cons)) - break; - offset = pool_offset(cons); - if (busy(ao_lisp_busy, offset)) { - ao_lisp_printf("cons at %p offset %d poly %d is busy\n\t%v\n", cons, offset, ao_lisp_cons_poly(cons), ao_lisp_cons_poly(cons)); - abort(); - } - cdr = cons->cdr; - if (!ao_lisp_is_pair(cdr)) - break; - cons = ao_lisp_poly_cons(cdr); - } -} -#endif - -/* - * Mark interfaces for objects - */ - - -/* - * Mark a block of memory with an explicit size - */ - -int -ao_lisp_mark_block(void *addr, int size) -{ - int offset; - if (!AO_LISP_IS_POOL(addr)) - return 1; - - offset = pool_offset(addr); - MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); - if (busy(ao_lisp_busy, offset)) { - MDBG_MOVE("already marked\n"); - return 1; - } - mark(ao_lisp_busy, offset); - note_chunk(offset, size); - return 0; -} - -/* - * Note a reference to memory and collect information about a few - * object sizes at a time - */ - -int -ao_lisp_mark_memory(const struct ao_lisp_type *type, void *addr) -{ - int offset; - if (!AO_LISP_IS_POOL(addr)) - return 1; - - offset = pool_offset(addr); - MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); - if (busy(ao_lisp_busy, offset)) { - MDBG_MOVE("already marked\n"); - return 1; - } - mark(ao_lisp_busy, offset); - note_chunk(offset, ao_lisp_size(type, addr)); - return 0; -} - -/* - * Mark an object and all that it refereces - */ -int -ao_lisp_mark(const struct ao_lisp_type *type, void *addr) -{ - int ret; - MDBG_MOVE("mark %d\n", MDBG_OFFSET(addr)); - MDBG_MOVE_IN(); - ret = ao_lisp_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_lisp_poly_mark(ao_poly p, uint8_t do_note_cons) -{ - uint8_t type; - void *addr; - - type = ao_lisp_poly_base_type(p); - - if (type == AO_LISP_INT) - return 1; - - addr = ao_lisp_ref(p); - if (!AO_LISP_IS_POOL(addr)) - return 1; - - if (type == AO_LISP_CONS && do_note_cons) { - note_cons(pool_offset(addr)); - return 1; - } else { - if (type == AO_LISP_OTHER) - type = ao_lisp_other_type(addr); - - const struct ao_lisp_type *lisp_type = ao_lisp_types[type]; -#if DBG_MEM - if (!lisp_type) - ao_lisp_abort(); -#endif - - return ao_lisp_mark(lisp_type, addr); - } -} - -/* - * 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_lisp_chunk[l].old_offset != offset) - ao_lisp_abort(); -#endif - return ao_lisp_chunk[l].new_offset; -} - -int -ao_lisp_move_memory(const struct ao_lisp_type *type, void **ref) -{ - void *addr = *ref; - uint16_t offset, orig_offset; - - if (!AO_LISP_IS_POOL(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_LISP_IS_POOL(ref) ? MDBG_OFFSET(ref) : -1, - orig_offset, offset); - *ref = ao_lisp_pool + offset; - } - if (busy(ao_lisp_busy, offset)) { - MDBG_MOVE("already moved\n"); - return 1; - } - mark(ao_lisp_busy, offset); - MDBG_DO(ao_lisp_record(type, addr, ao_lisp_size(type, addr))); - return 0; -} - -int -ao_lisp_move(const struct ao_lisp_type *type, void **ref) -{ - int ret; - MDBG_MOVE("move object %d\n", MDBG_OFFSET(*ref)); - MDBG_MOVE_IN(); - ret = ao_lisp_move_memory(type, ref); - if (!ret) { - MDBG_MOVE("move recurse\n"); - type->move(*ref); - } - MDBG_MOVE_OUT(); - return ret; -} - -int -ao_lisp_poly_move(ao_poly *ref, uint8_t do_note_cons) -{ - uint8_t type; - ao_poly p = *ref; - int ret; - void *addr; - uint16_t offset, orig_offset; - uint8_t base_type; - - base_type = type = ao_lisp_poly_base_type(p); - - if (type == AO_LISP_INT) - return 1; - - addr = ao_lisp_ref(p); - if (!AO_LISP_IS_POOL(addr)) - return 1; - - orig_offset = pool_offset(addr); - offset = move_map(orig_offset); - - if (type == AO_LISP_CONS && do_note_cons) { - note_cons(orig_offset); - ret = 1; - } else { - if (type == AO_LISP_OTHER) - type = ao_lisp_other_type(ao_lisp_pool + offset); - - const struct ao_lisp_type *lisp_type = ao_lisp_types[type]; -#if DBG_MEM - if (!lisp_type) - ao_lisp_abort(); -#endif - - ret = ao_lisp_move(lisp_type, &addr); - } - - /* Re-write the poly value */ - if (offset != orig_offset) { - ao_poly np = ao_lisp_poly(ao_lisp_pool + offset, base_type); - MDBG_MOVE("poly %d moved %d -> %d\n", - type, orig_offset, offset); - *ref = np; - } - return ret; -} - -#if DBG_MEM -void -ao_lisp_validate(void) -{ - chunk_low = 0; - memset(ao_lisp_chunk, '\0', sizeof (ao_lisp_chunk)); - walk(ao_lisp_mark_ref, ao_lisp_poly_mark_ref); -} - -int dbg_allocs; - -#endif - -void * -ao_lisp_alloc(int size) -{ - void *addr; - - MDBG_DO(++dbg_allocs); - MDBG_DO(if (dbg_validate) ao_lisp_validate()); - size = ao_lisp_size_round(size); - if (AO_LISP_POOL - ao_lisp_top < size && - ao_lisp_collect(AO_LISP_COLLECT_INCREMENTAL) < size && - ao_lisp_collect(AO_LISP_COLLECT_FULL) < size) - { - ao_lisp_error(AO_LISP_OOM, "out of memory"); - return NULL; - } - addr = ao_lisp_pool + ao_lisp_top; - ao_lisp_top += size; - MDBG_MOVE("alloc %d size %d\n", MDBG_OFFSET(addr), size); - return addr; -} - -void -ao_lisp_cons_stash(int id, struct ao_lisp_cons *cons) -{ - assert(save_cons[id] == 0); - save_cons[id] = cons; -} - -struct ao_lisp_cons * -ao_lisp_cons_fetch(int id) -{ - struct ao_lisp_cons *cons = save_cons[id]; - save_cons[id] = NULL; - return cons; -} - -void -ao_lisp_poly_stash(int id, ao_poly poly) -{ - assert(save_poly[id] == AO_LISP_NIL); - save_poly[id] = poly; -} - -ao_poly -ao_lisp_poly_fetch(int id) -{ - ao_poly poly = save_poly[id]; - save_poly[id] = AO_LISP_NIL; - return poly; -} - -void -ao_lisp_string_stash(int id, char *string) -{ - assert(save_string[id] == NULL); - save_string[id] = string; -} - -char * -ao_lisp_string_fetch(int id) -{ - char *string = save_string[id]; - save_string[id] = NULL; - return string; -} - -void -ao_lisp_frame_stash(int id, struct ao_lisp_frame *frame) -{ - assert(save_frame[id] == NULL); - save_frame[id] = frame; -} - -struct ao_lisp_frame * -ao_lisp_frame_fetch(int id) -{ - struct ao_lisp_frame *frame = save_frame[id]; - save_frame[id] = NULL; - return frame; -} diff --git a/src/lisp/ao_lisp_os.h b/src/lisp/ao_lisp_os.h deleted file mode 100644 index 4285cb8c..00000000 --- a/src/lisp/ao_lisp_os.h +++ /dev/null @@ -1,63 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. - */ - -#ifndef _AO_LISP_OS_H_ -#define _AO_LISP_OS_H_ - -#include -#include -#include - -extern int ao_lisp_getc(void); - -static inline void -ao_lisp_os_flush(void) { - fflush(stdout); -} - -static inline void -ao_lisp_abort(void) -{ - abort(); -} - -static inline void -ao_lisp_os_led(int led) -{ - printf("leds set to 0x%x\n", led); -} - -#define AO_LISP_JIFFIES_PER_SECOND 100 - -static inline void -ao_lisp_os_delay(int jiffies) -{ - struct timespec ts = { - .tv_sec = jiffies / AO_LISP_JIFFIES_PER_SECOND, - .tv_nsec = (jiffies % AO_LISP_JIFFIES_PER_SECOND) * (1000000000L / AO_LISP_JIFFIES_PER_SECOND) - }; - nanosleep(&ts, NULL); -} - -static inline int -ao_lisp_os_jiffy(void) -{ - struct timespec tp; - clock_gettime(CLOCK_MONOTONIC, &tp); - return tp.tv_sec * AO_LISP_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_LISP_JIFFIES_PER_SECOND)); -} -#endif diff --git a/src/lisp/ao_lisp_poly.c b/src/lisp/ao_lisp_poly.c deleted file mode 100644 index d14f4151..00000000 --- a/src/lisp/ao_lisp_poly.c +++ /dev/null @@ -1,118 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -struct ao_lisp_funcs { - void (*write)(ao_poly); - void (*display)(ao_poly); -}; - -static const struct ao_lisp_funcs ao_lisp_funcs[AO_LISP_NUM_TYPE] = { - [AO_LISP_CONS] = { - .write = ao_lisp_cons_write, - .display = ao_lisp_cons_display, - }, - [AO_LISP_STRING] = { - .write = ao_lisp_string_write, - .display = ao_lisp_string_display, - }, - [AO_LISP_INT] = { - .write = ao_lisp_int_write, - .display = ao_lisp_int_write, - }, - [AO_LISP_ATOM] = { - .write = ao_lisp_atom_write, - .display = ao_lisp_atom_write, - }, - [AO_LISP_BUILTIN] = { - .write = ao_lisp_builtin_write, - .display = ao_lisp_builtin_write, - }, - [AO_LISP_FRAME] = { - .write = ao_lisp_frame_write, - .display = ao_lisp_frame_write, - }, - [AO_LISP_FRAME_VALS] = { - .write = NULL, - .display = NULL, - }, - [AO_LISP_LAMBDA] = { - .write = ao_lisp_lambda_write, - .display = ao_lisp_lambda_write, - }, - [AO_LISP_STACK] = { - .write = ao_lisp_stack_write, - .display = ao_lisp_stack_write, - }, - [AO_LISP_BOOL] = { - .write = ao_lisp_bool_write, - .display = ao_lisp_bool_write, - }, - [AO_LISP_BIGINT] = { - .write = ao_lisp_bigint_write, - .display = ao_lisp_bigint_write, - }, - [AO_LISP_FLOAT] = { - .write = ao_lisp_float_write, - .display = ao_lisp_float_write, - }, -}; - -static const struct ao_lisp_funcs * -funcs(ao_poly p) -{ - uint8_t type = ao_lisp_poly_type(p); - - if (type < AO_LISP_NUM_TYPE) - return &ao_lisp_funcs[type]; - return NULL; -} - -void -ao_lisp_poly_write(ao_poly p) -{ - const struct ao_lisp_funcs *f = funcs(p); - - if (f && f->write) - f->write(p); -} - -void -ao_lisp_poly_display(ao_poly p) -{ - const struct ao_lisp_funcs *f = funcs(p); - - if (f && f->display) - f->display(p); -} - -void * -ao_lisp_ref(ao_poly poly) { - if (poly == AO_LISP_NIL) - return NULL; - if (poly & AO_LISP_CONST) - return (void *) (ao_lisp_const + (poly & AO_LISP_REF_MASK) - 4); - return (void *) (ao_lisp_pool + (poly & AO_LISP_REF_MASK) - 4); -} - -ao_poly -ao_lisp_poly(const void *addr, ao_poly type) { - const uint8_t *a = addr; - if (a == NULL) - return AO_LISP_NIL; - if (AO_LISP_IS_CONST(a)) - return AO_LISP_CONST | (a - ao_lisp_const + 4) | type; - return (a - ao_lisp_pool + 4) | type; -} diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c deleted file mode 100644 index 0ca12a81..00000000 --- a/src/lisp/ao_lisp_read.c +++ /dev/null @@ -1,655 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include "ao_lisp_read.h" -#include -#include - -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, /* , */ - 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, /* ` */ - 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() -{ - int c; - if (lex_unget_c) { - c = lex_unget_c; - lex_unget_c = 0; - } else { - c = ao_lisp_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; - } -} - -#define AO_LISP_TOKEN_MAX 32 - -static char token_string[AO_LISP_TOKEN_MAX]; -static int32_t token_int; -static int token_len; -static float token_float; - -static inline void add_token(int c) { - if (c && token_len < AO_LISP_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'; -} - -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]) - -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; - case '`': - return QUASIQUOTE; - case ',': - c = lexc(); - if (c == '@') { - add_token(c); - end_token(); - return UNQUOTE_SPLICING; - } else { - lex_unget(c); - return UNQUOTE; - } - } - } - 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; - 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_lisp_error(AO_LISP_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) { - int isfloat; - int hasdigit; - int isneg; - int isint; - int epos; - - isfloat = 1; - isint = 1; - hasdigit = 0; - token_int = 0; - isneg = 0; - epos = 0; - for (;;) { - if (!(lex_class & NUMBER)) { - isint = 0; - isfloat = 0; - } else { - if (!(lex_class & INTEGER)) - isint = 0; - if (token_len != epos && - (lex_class & SIGN)) - { - isint = 0; - isfloat = 0; - } - if (c == '-') - isneg = 1; - if (c == '.' && epos != 0) - isfloat = 0; - if (c == 'e' || c == 'E') { - if (token_len == 0) - isfloat = 0; - else - epos = token_len + 1; - } - if (lex_class & DIGIT) { - hasdigit = 1; - if (isint) - token_int = token_int * 10 + c - '0'; - } - } - add_token (c); - c = lexc (); - if ((lex_class & (NOTNAME)) && (c != '.' || !isfloat)) { - unsigned int u; -// if (lex_class & ENDOFFILE) -// clearerr (f); - lex_unget(c); - end_token (); - if (isint && hasdigit) { - if (isneg) - token_int = -token_int; - return NUM; - } - 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; - } - 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; - -struct ao_lisp_cons *ao_lisp_read_cons; -struct ao_lisp_cons *ao_lisp_read_cons_tail; -struct ao_lisp_cons *ao_lisp_read_stack; - -#define READ_IN_QUOTE 0x01 -#define READ_SAW_DOT 0x02 -#define READ_DONE_DOT 0x04 - -static int -push_read_stack(int cons, int read_state) -{ - RDBGI("push read stack %p 0x%x\n", ao_lisp_read_cons, read_state); - RDBG_IN(); - if (cons) { - ao_lisp_read_stack = ao_lisp_cons_cons(ao_lisp_cons_poly(ao_lisp_read_cons), - ao_lisp__cons(ao_lisp_int_poly(read_state), - ao_lisp_cons_poly(ao_lisp_read_stack))); - if (!ao_lisp_read_stack) - return 0; - } - ao_lisp_read_cons = NULL; - ao_lisp_read_cons_tail = NULL; - return 1; -} - -static int -pop_read_stack(int cons) -{ - int read_state = 0; - if (cons) { - ao_lisp_read_cons = ao_lisp_poly_cons(ao_lisp_read_stack->car); - ao_lisp_read_stack = ao_lisp_poly_cons(ao_lisp_read_stack->cdr); - read_state = ao_lisp_poly_int(ao_lisp_read_stack->car); - ao_lisp_read_stack = ao_lisp_poly_cons(ao_lisp_read_stack->cdr); - for (ao_lisp_read_cons_tail = ao_lisp_read_cons; - ao_lisp_read_cons_tail && ao_lisp_read_cons_tail->cdr; - ao_lisp_read_cons_tail = ao_lisp_poly_cons(ao_lisp_read_cons_tail->cdr)) - ; - } else { - ao_lisp_read_cons = 0; - ao_lisp_read_cons_tail = 0; - ao_lisp_read_stack = 0; - } - RDBG_OUT(); - RDBGI("pop read stack %p %d\n", ao_lisp_read_cons, read_state); - return read_state; -} - -ao_poly -ao_lisp_read(void) -{ - struct ao_lisp_atom *atom; - char *string; - int cons; - int read_state; - ao_poly v = AO_LISP_NIL; - - cons = 0; - read_state = 0; - ao_lisp_read_cons = ao_lisp_read_cons_tail = ao_lisp_read_stack = 0; - for (;;) { - parse_token = lex(); - while (parse_token == OPEN) { - if (!push_read_stack(cons, read_state)) - return AO_LISP_NIL; - cons++; - read_state = 0; - parse_token = lex(); - } - - switch (parse_token) { - case END: - default: - if (cons) - ao_lisp_error(AO_LISP_EOF, "unexpected end of file"); - return _ao_lisp_atom_eof; - break; - case NAME: - atom = ao_lisp_atom_intern(token_string); - if (atom) - v = ao_lisp_atom_poly(atom); - else - v = AO_LISP_NIL; - break; - case NUM: - v = ao_lisp_integer_poly(token_int); - break; - case FLOAT: - v = ao_lisp_float_get(token_float); - break; - case BOOL: - if (token_string[0] == 't') - v = _ao_lisp_bool_true; - else - v = _ao_lisp_bool_false; - break; - case STRING: - string = ao_lisp_string_copy(token_string); - if (string) - v = ao_lisp_string_poly(string); - else - v = AO_LISP_NIL; - break; - case QUOTE: - case QUASIQUOTE: - case UNQUOTE: - case UNQUOTE_SPLICING: - if (!push_read_stack(cons, read_state)) - return AO_LISP_NIL; - cons++; - read_state = READ_IN_QUOTE; - switch (parse_token) { - case QUOTE: - v = _ao_lisp_atom_quote; - break; - case QUASIQUOTE: - v = _ao_lisp_atom_quasiquote; - break; - case UNQUOTE: - v = _ao_lisp_atom_unquote; - break; - case UNQUOTE_SPLICING: - v = _ao_lisp_atom_unquote2dsplicing; - break; - } - break; - case CLOSE: - if (!cons) { - v = AO_LISP_NIL; - break; - } - v = ao_lisp_cons_poly(ao_lisp_read_cons); - --cons; - read_state = pop_read_stack(cons); - break; - case DOT: - if (!cons) { - ao_lisp_error(AO_LISP_INVALID, ". outside of cons"); - return AO_LISP_NIL; - } - if (!ao_lisp_read_cons) { - ao_lisp_error(AO_LISP_INVALID, ". first in cons"); - return AO_LISP_NIL; - } - read_state |= READ_SAW_DOT; - continue; - } - - /* loop over QUOTE ends */ - for (;;) { - if (!cons) - return v; - - if (read_state & READ_DONE_DOT) { - ao_lisp_error(AO_LISP_INVALID, ". not last in cons"); - return AO_LISP_NIL; - } - - if (read_state & READ_SAW_DOT) { - read_state |= READ_DONE_DOT; - ao_lisp_read_cons_tail->cdr = v; - } else { - struct ao_lisp_cons *read = ao_lisp_cons_cons(v, AO_LISP_NIL); - if (!read) - return AO_LISP_NIL; - - if (ao_lisp_read_cons_tail) - ao_lisp_read_cons_tail->cdr = ao_lisp_cons_poly(read); - else - ao_lisp_read_cons = read; - ao_lisp_read_cons_tail = read; - } - - if (!(read_state & READ_IN_QUOTE) || !ao_lisp_read_cons->cdr) - break; - - v = ao_lisp_cons_poly(ao_lisp_read_cons); - --cons; - read_state = pop_read_stack(cons); - } - } - return v; -} diff --git a/src/lisp/ao_lisp_read.h b/src/lisp/ao_lisp_read.h deleted file mode 100644 index 8f6bf130..00000000 --- a/src/lisp/ao_lisp_read.h +++ /dev/null @@ -1,58 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#ifndef _AO_LISP_READ_H_ -#define _AO_LISP_READ_H_ - -/* - * token classes - */ - -# define END 0 -# define NAME 1 -# define OPEN 2 -# define CLOSE 3 -# define QUOTE 4 -# define QUASIQUOTE 5 -# define UNQUOTE 6 -# define UNQUOTE_SPLICING 7 -# define STRING 8 -# define NUM 9 -# define FLOAT 10 -# define DOT 11 -# define BOOL 12 - -/* - * character classes - */ - -# define PRINTABLE 0x0001 /* \t \n ' ' - ~ */ -# define SPECIAL 0x0002 /* ( [ { ) ] } ' ` , */ -# define DOTC 0x0004 /* . */ -# define WHITE 0x0008 /* ' ' \t \n */ -# define DIGIT 0x0010 /* [0-9] */ -# define SIGN 0x0020 /* +- */ -# define FLOATC 0x0040 /* . e E */ -# 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_LISP_READ_H_ */ diff --git a/src/lisp/ao_lisp_rep.c b/src/lisp/ao_lisp_rep.c deleted file mode 100644 index 43cc387f..00000000 --- a/src/lisp/ao_lisp_rep.c +++ /dev/null @@ -1,36 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -ao_poly -ao_lisp_read_eval_print(void) -{ - ao_poly in, out = AO_LISP_NIL; - for(;;) { - in = ao_lisp_read(); - if (in == _ao_lisp_atom_eof) - break; - out = ao_lisp_eval(in); - if (ao_lisp_exception) { - if (ao_lisp_exception & AO_LISP_EXIT) - break; - ao_lisp_exception = 0; - } else { - ao_lisp_poly_write(out); - putchar ('\n'); - } - } - return out; -} diff --git a/src/lisp/ao_lisp_save.c b/src/lisp/ao_lisp_save.c deleted file mode 100644 index c990e9c6..00000000 --- a/src/lisp/ao_lisp_save.c +++ /dev/null @@ -1,77 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include - -ao_poly -ao_lisp_do_save(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_save, cons, 0, 0)) - return AO_LISP_NIL; - -#ifdef AO_LISP_SAVE - struct ao_lisp_os_save *os = (struct ao_lisp_os_save *) (void *) &ao_lisp_pool[AO_LISP_POOL]; - - ao_lisp_collect(AO_LISP_COLLECT_FULL); - os->atoms = ao_lisp_atom_poly(ao_lisp_atoms); - os->globals = ao_lisp_frame_poly(ao_lisp_frame_global); - os->const_checksum = ao_lisp_const_checksum; - os->const_checksum_inv = (uint16_t) ~ao_lisp_const_checksum; - - if (ao_lisp_os_save()) - return _ao_lisp_bool_true; -#endif - return _ao_lisp_bool_false; -} - -ao_poly -ao_lisp_do_restore(struct ao_lisp_cons *cons) -{ - if (!ao_lisp_check_argc(_ao_lisp_atom_save, cons, 0, 0)) - return AO_LISP_NIL; - -#ifdef AO_LISP_SAVE - struct ao_lisp_os_save save; - struct ao_lisp_os_save *os = (struct ao_lisp_os_save *) (void *) &ao_lisp_pool[AO_LISP_POOL]; - - if (!ao_lisp_os_restore_save(&save, AO_LISP_POOL)) - return ao_lisp_error(AO_LISP_INVALID, "header restore failed"); - - if (save.const_checksum != ao_lisp_const_checksum || - save.const_checksum_inv != (uint16_t) ~ao_lisp_const_checksum) - { - return ao_lisp_error(AO_LISP_INVALID, "image is corrupted or stale"); - } - - if (ao_lisp_os_restore()) { - - ao_lisp_atoms = ao_lisp_poly_atom(os->atoms); - ao_lisp_frame_global = ao_lisp_poly_frame(os->globals); - - /* Clear the eval global variabls */ - ao_lisp_eval_clear_globals(); - - /* Reset the allocator */ - ao_lisp_top = AO_LISP_POOL; - ao_lisp_collect(AO_LISP_COLLECT_FULL); - - /* Re-create the evaluator stack */ - if (!ao_lisp_eval_restart()) - return _ao_lisp_bool_false; - - return _ao_lisp_bool_true; - } -#endif - return _ao_lisp_bool_false; -} diff --git a/src/lisp/ao_lisp_stack.c b/src/lisp/ao_lisp_stack.c deleted file mode 100644 index e7c89801..00000000 --- a/src/lisp/ao_lisp_stack.c +++ /dev/null @@ -1,280 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" - -const struct ao_lisp_type ao_lisp_stack_type; - -static int -stack_size(void *addr) -{ - (void) addr; - return sizeof (struct ao_lisp_stack); -} - -static void -stack_mark(void *addr) -{ - struct ao_lisp_stack *stack = addr; - for (;;) { - ao_lisp_poly_mark(stack->sexprs, 0); - ao_lisp_poly_mark(stack->values, 0); - /* no need to mark values_tail */ - ao_lisp_poly_mark(stack->frame, 0); - ao_lisp_poly_mark(stack->list, 0); - stack = ao_lisp_poly_stack(stack->prev); - if (ao_lisp_mark_memory(&ao_lisp_stack_type, stack)) - break; - } -} - -static void -stack_move(void *addr) -{ - struct ao_lisp_stack *stack = addr; - - while (stack) { - struct ao_lisp_stack *prev; - int ret; - (void) ao_lisp_poly_move(&stack->sexprs, 0); - (void) ao_lisp_poly_move(&stack->values, 0); - (void) ao_lisp_poly_move(&stack->values_tail, 0); - (void) ao_lisp_poly_move(&stack->frame, 0); - (void) ao_lisp_poly_move(&stack->list, 0); - prev = ao_lisp_poly_stack(stack->prev); - if (!prev) - break; - ret = ao_lisp_move_memory(&ao_lisp_stack_type, (void **) &prev); - if (prev != ao_lisp_poly_stack(stack->prev)) - stack->prev = ao_lisp_stack_poly(prev); - if (ret) - break; - stack = prev; - } -} - -const struct ao_lisp_type ao_lisp_stack_type = { - .size = stack_size, - .mark = stack_mark, - .move = stack_move, - .name = "stack" -}; - -struct ao_lisp_stack *ao_lisp_stack_free_list; - -void -ao_lisp_stack_reset(struct ao_lisp_stack *stack) -{ - stack->state = eval_sexpr; - stack->sexprs = AO_LISP_NIL; - stack->values = AO_LISP_NIL; - stack->values_tail = AO_LISP_NIL; -} - -static struct ao_lisp_stack * -ao_lisp_stack_new(void) -{ - struct ao_lisp_stack *stack; - - if (ao_lisp_stack_free_list) { - stack = ao_lisp_stack_free_list; - ao_lisp_stack_free_list = ao_lisp_poly_stack(stack->prev); - } else { - stack = ao_lisp_alloc(sizeof (struct ao_lisp_stack)); - if (!stack) - return 0; - stack->type = AO_LISP_STACK; - } - ao_lisp_stack_reset(stack); - return stack; -} - -int -ao_lisp_stack_push(void) -{ - struct ao_lisp_stack *stack; - - stack = ao_lisp_stack_new(); - - if (!stack) - return 0; - - stack->prev = ao_lisp_stack_poly(ao_lisp_stack); - stack->frame = ao_lisp_frame_poly(ao_lisp_frame_current); - stack->list = AO_LISP_NIL; - - ao_lisp_stack = stack; - - DBGI("stack push\n"); - DBG_FRAMES(); - DBG_IN(); - return 1; -} - -void -ao_lisp_stack_pop(void) -{ - ao_poly prev; - struct ao_lisp_frame *prev_frame; - - if (!ao_lisp_stack) - return; - prev = ao_lisp_stack->prev; - if (!ao_lisp_stack_marked(ao_lisp_stack)) { - ao_lisp_stack->prev = ao_lisp_stack_poly(ao_lisp_stack_free_list); - ao_lisp_stack_free_list = ao_lisp_stack; - } - - ao_lisp_stack = ao_lisp_poly_stack(prev); - prev_frame = ao_lisp_frame_current; - if (ao_lisp_stack) - ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); - else - ao_lisp_frame_current = NULL; - if (ao_lisp_frame_current != prev_frame) - ao_lisp_frame_free(prev_frame); - DBG_OUT(); - DBGI("stack pop\n"); - DBG_FRAMES(); -} - -void -ao_lisp_stack_clear(void) -{ - ao_lisp_stack = NULL; - ao_lisp_frame_current = NULL; - ao_lisp_v = AO_LISP_NIL; -} - -void -ao_lisp_stack_write(ao_poly poly) -{ - struct ao_lisp_stack *s = ao_lisp_poly_stack(poly); - - while (s) { - if (s->type & AO_LISP_STACK_PRINT) { - printf("[recurse...]"); - return; - } - s->type |= AO_LISP_STACK_PRINT; - printf("\t[\n"); - printf("\t\texpr: "); ao_lisp_poly_write(s->list); printf("\n"); - printf("\t\tstate: %s\n", ao_lisp_state_names[s->state]); - ao_lisp_error_poly ("values: ", s->values, s->values_tail); - ao_lisp_error_poly ("sexprs: ", s->sexprs, AO_LISP_NIL); - ao_lisp_error_frame(2, "frame: ", ao_lisp_poly_frame(s->frame)); - printf("\t]\n"); - s->type &= ~AO_LISP_STACK_PRINT; - s = ao_lisp_poly_stack(s->prev); - } -} - -/* - * Copy a stack, being careful to keep everybody referenced - */ -static struct ao_lisp_stack * -ao_lisp_stack_copy(struct ao_lisp_stack *old) -{ - struct ao_lisp_stack *new = NULL; - struct ao_lisp_stack *n, *prev = NULL; - - while (old) { - ao_lisp_stack_stash(0, old); - ao_lisp_stack_stash(1, new); - ao_lisp_stack_stash(2, prev); - n = ao_lisp_stack_new(); - prev = ao_lisp_stack_fetch(2); - new = ao_lisp_stack_fetch(1); - old = ao_lisp_stack_fetch(0); - if (!n) - return NULL; - - ao_lisp_stack_mark(old); - ao_lisp_frame_mark(ao_lisp_poly_frame(old->frame)); - *n = *old; - - if (prev) - prev->prev = ao_lisp_stack_poly(n); - else - new = n; - prev = n; - - old = ao_lisp_poly_stack(old->prev); - } - return new; -} - -/* - * Evaluate a continuation invocation - */ -ao_poly -ao_lisp_stack_eval(void) -{ - struct ao_lisp_stack *new = ao_lisp_stack_copy(ao_lisp_poly_stack(ao_lisp_v)); - if (!new) - return AO_LISP_NIL; - - struct ao_lisp_cons *cons = ao_lisp_poly_cons(ao_lisp_stack->values); - - if (!cons || !cons->cdr) - return ao_lisp_error(AO_LISP_INVALID, "continuation requires a value"); - - new->state = eval_val; - - ao_lisp_stack = new; - ao_lisp_frame_current = ao_lisp_poly_frame(ao_lisp_stack->frame); - - return ao_lisp_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_lisp_do_call_cc(struct ao_lisp_cons *cons) -{ - struct ao_lisp_stack *new; - ao_poly v; - - /* Make sure the single parameter is a lambda */ - if (!ao_lisp_check_argc(_ao_lisp_atom_call2fcc, cons, 1, 1)) - return AO_LISP_NIL; - if (!ao_lisp_check_argt(_ao_lisp_atom_call2fcc, cons, 0, AO_LISP_LAMBDA, 0)) - return AO_LISP_NIL; - - /* go get the lambda */ - ao_lisp_v = ao_lisp_arg(cons, 0); - - /* Note that the whole call chain now has - * a reference to it which may escape - */ - new = ao_lisp_stack_copy(ao_lisp_stack); - if (!new) - return AO_LISP_NIL; - - /* re-fetch cons after the allocation */ - cons = ao_lisp_poly_cons(ao_lisp_poly_cons(ao_lisp_stack->values)->cdr); - - /* Reset the arg list to the current stack, - * and call the lambda - */ - - cons->car = ao_lisp_stack_poly(new); - cons->cdr = AO_LISP_NIL; - v = ao_lisp_lambda_eval(); - ao_lisp_stack->sexprs = v; - ao_lisp_stack->state = eval_begin; - return AO_LISP_NIL; -} diff --git a/src/lisp/ao_lisp_string.c b/src/lisp/ao_lisp_string.c deleted file mode 100644 index 1daa50ea..00000000 --- a/src/lisp/ao_lisp_string.c +++ /dev/null @@ -1,161 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. - */ - -#include "ao_lisp.h" - -static void string_mark(void *addr) -{ - (void) addr; -} - -static int string_size(void *addr) -{ - if (!addr) - return 0; - return strlen(addr) + 1; -} - -static void string_move(void *addr) -{ - (void) addr; -} - -const struct ao_lisp_type ao_lisp_string_type = { - .mark = string_mark, - .size = string_size, - .move = string_move, - .name = "string", -}; - -char * -ao_lisp_string_copy(char *a) -{ - int alen = strlen(a); - - ao_lisp_string_stash(0, a); - char *r = ao_lisp_alloc(alen + 1); - a = ao_lisp_string_fetch(0); - if (!r) - return NULL; - strcpy(r, a); - return r; -} - -char * -ao_lisp_string_cat(char *a, char *b) -{ - int alen = strlen(a); - int blen = strlen(b); - - ao_lisp_string_stash(0, a); - ao_lisp_string_stash(1, b); - char *r = ao_lisp_alloc(alen + blen + 1); - a = ao_lisp_string_fetch(0); - b = ao_lisp_string_fetch(1); - if (!r) - return NULL; - strcpy(r, a); - strcpy(r+alen, b); - return r; -} - -ao_poly -ao_lisp_string_pack(struct ao_lisp_cons *cons) -{ - int len = ao_lisp_cons_length(cons); - ao_lisp_cons_stash(0, cons); - char *r = ao_lisp_alloc(len + 1); - cons = ao_lisp_cons_fetch(0); - char *s = r; - - while (cons) { - if (!ao_lisp_integer_typep(ao_lisp_poly_type(cons->car))) - return ao_lisp_error(AO_LISP_INVALID, "non-int passed to pack"); - *s++ = ao_lisp_poly_integer(cons->car); - cons = ao_lisp_poly_cons(cons->cdr); - } - *s++ = 0; - return ao_lisp_string_poly(r); -} - -ao_poly -ao_lisp_string_unpack(char *a) -{ - struct ao_lisp_cons *cons = NULL, *tail = NULL; - int c; - int i; - - for (i = 0; (c = a[i]); i++) { - ao_lisp_cons_stash(0, cons); - ao_lisp_cons_stash(1, tail); - ao_lisp_string_stash(0, a); - struct ao_lisp_cons *n = ao_lisp_cons_cons(ao_lisp_int_poly(c), AO_LISP_NIL); - a = ao_lisp_string_fetch(0); - cons = ao_lisp_cons_fetch(0); - tail = ao_lisp_cons_fetch(1); - - if (!n) { - cons = NULL; - break; - } - if (tail) - tail->cdr = ao_lisp_cons_poly(n); - else - cons = n; - tail = n; - } - return ao_lisp_cons_poly(cons); -} - -void -ao_lisp_string_write(ao_poly p) -{ - char *s = ao_lisp_poly_string(p); - char c; - - putchar('"'); - while ((c = *s++)) { - 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('"'); -} - -void -ao_lisp_string_display(ao_poly p) -{ - char *s = ao_lisp_poly_string(p); - char c; - - while ((c = *s++)) - putchar(c); -} diff --git a/src/scheme/.gitignore b/src/scheme/.gitignore new file mode 100644 index 00000000..ee72cb9d --- /dev/null +++ b/src/scheme/.gitignore @@ -0,0 +1,2 @@ +ao_scheme_const.h +ao_scheme_builtin.h diff --git a/src/scheme/Makefile b/src/scheme/Makefile new file mode 100644 index 00000000..d8e4b553 --- /dev/null +++ b/src/scheme/Makefile @@ -0,0 +1,16 @@ +all: ao_scheme_builtin.h ao_scheme_const.h + +clean: + +cd make-const && make clean + rm -f ao_scheme_const.h ao_scheme_builtin.h + +ao_scheme_const.h: ao_scheme_const.lisp make-const/ao_scheme_make_const + make-const/ao_scheme_make_const -o $@ ao_scheme_const.lisp + +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 + +cd make-const && make ao_scheme_make_const + +FRC: diff --git a/src/scheme/Makefile-inc b/src/scheme/Makefile-inc new file mode 100644 index 00000000..d23ee3d7 --- /dev/null +++ b/src/scheme/Makefile-inc @@ -0,0 +1,24 @@ +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 + +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 new file mode 100644 index 00000000..2427cffa --- /dev/null +++ b/src/scheme/Makefile-scheme @@ -0,0 +1,4 @@ +include ../lisp/Makefile-inc + +ao_scheme_const.h: $(LISP_SRCS) $(LISP_HDRS) + +cd ../lisp && make $@ diff --git a/src/scheme/README b/src/scheme/README new file mode 100644 index 00000000..98932b44 --- /dev/null +++ b/src/scheme/README @@ -0,0 +1,10 @@ +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; (have classic macros) +* No record types +* No libraries diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h new file mode 100644 index 00000000..4589f8a5 --- /dev/null +++ b/src/scheme/ao_scheme.h @@ -0,0 +1,928 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#ifndef _AO_SCHEME_H_ +#define _AO_SCHEME_H_ + +#define DBG_MEM 0 +#define DBG_EVAL 0 +#define DBG_READ 0 +#define DBG_FREE_CONS 0 +#define NDEBUG 1 + +#include +#include +#include +#ifndef __BYTE_ORDER +#include +#endif + +typedef uint16_t ao_poly; +typedef int16_t ao_signed_poly; + +#ifdef AO_SCHEME_SAVE + +struct ao_scheme_os_save { + ao_poly atoms; + ao_poly globals; + uint16_t const_checksum; + uint16_t const_checksum_inv; +}; + +#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(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 +#define AO_SCHEME_POOL 3072 +#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_STRING 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_BIGINT 11 +#define AO_SCHEME_FLOAT 12 +#define AO_SCHEME_NUM_TYPE 13 + +/* 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; +} + +#define AO_SCHEME_IS_CONST(a) (ao_scheme_const <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_scheme_const + AO_SCHEME_POOL_CONST) +#define AO_SCHEME_IS_POOL(a) (ao_scheme_pool <= ((uint8_t *) (a)) && ((uint8_t *) (a)) < ao_scheme_pool + AO_SCHEME_POOL) +#define AO_SCHEME_IS_INT(p) (ao_scheme_poly_base_type(p) == AO_SCHEME_INT) + +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_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; +}; + +struct ao_scheme_bigint { + uint32_t value; +}; + +struct ao_scheme_float { + uint8_t type; + uint8_t pad1; + uint16_t pad2; + float value; +}; + +#if __BYTE_ORDER == __LITTLE_ENDIAN +static inline uint32_t +ao_scheme_int_bigint(int32_t i) { + return AO_SCHEME_BIGINT | (i << 8); +} +static inline int32_t +ao_scheme_bigint_int(uint32_t bi) { + return (int32_t) bi >> 8; +} +#else +static inline uint32_t +ao_scheme_int_bigint(int32_t i) { + return (uint32_t) (i & 0xffffff) | (AO_SCHEME_BIGINT << 24); +} +static inlint int32_t +ao_scheme_bigint_int(uint32_t bi) { + return (int32_t) (bi << 8) >> 8; +} +#endif + +#define AO_SCHEME_MIN_INT (-(1 << (15 - AO_SCHEME_TYPE_SHIFT))) +#define AO_SCHEME_MAX_INT ((1 << (15 - AO_SCHEME_TYPE_SHIFT)) - 1) +#define AO_SCHEME_MIN_BIGINT (-(1 << 24)) +#define AO_SCHEME_MAX_BIGINT ((1 << 24) - 1) + +#define AO_SCHEME_NOT_INTEGER 0x7fffffff + +/* Set on type when the frame escapes the lambda */ +#define AO_SCHEME_FRAME_MARK 0x80 +#define AO_SCHEME_FRAME_PRINT 0x40 + +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 */ +#define AO_SCHEME_STACK_PRINT 0x40 /* stack is being printed */ + +static inline int ao_scheme_stack_marked(struct ao_scheme_stack *s) { + return s->type & AO_SCHEME_STACK_MARK; +} + +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; +} + +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_OTHER); +} + +static inline char * +ao_scheme_poly_string(ao_poly poly) +{ + return ao_scheme_ref(poly); +} + +static inline ao_poly +ao_scheme_string_poly(char *s) +{ + return ao_scheme_poly(s, AO_SCHEME_STRING); +} + +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); +} + +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); + +/* memory functions */ + +extern int ao_scheme_collects[2]; +extern int ao_scheme_freed[2]; +extern int ao_scheme_loops[2]; + +/* returns 1 if the object was already marked */ +int +ao_scheme_mark(const struct ao_scheme_type *type, void *addr); + +/* returns 1 if the object was already marked */ +int +ao_scheme_mark_memory(const struct ao_scheme_type *type, void *addr); + +void * +ao_scheme_move_map(void *addr); + +/* returns 1 if the object was already moved */ +int +ao_scheme_move(const struct ao_scheme_type *type, void **ref); + +/* returns 1 if the object was already moved */ +int +ao_scheme_move_memory(const struct ao_scheme_type *type, void **ref); + +void * +ao_scheme_alloc(int size); + +#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_cons_stash(int id, struct ao_scheme_cons *cons); + +struct ao_scheme_cons * +ao_scheme_cons_fetch(int id); + +void +ao_scheme_poly_stash(int id, ao_poly poly); + +ao_poly +ao_scheme_poly_fetch(int id); + +void +ao_scheme_string_stash(int id, char *string); + +char * +ao_scheme_string_fetch(int id); + +static inline void +ao_scheme_stack_stash(int id, struct ao_scheme_stack *stack) { + ao_scheme_poly_stash(id, ao_scheme_stack_poly(stack)); +} + +static inline struct ao_scheme_stack * +ao_scheme_stack_fetch(int id) { + return ao_scheme_poly_stack(ao_scheme_poly_fetch(id)); +} + +void +ao_scheme_frame_stash(int id, struct ao_scheme_frame *frame); + +struct ao_scheme_frame * +ao_scheme_frame_fetch(int id); + +/* bool */ + +extern const struct ao_scheme_type ao_scheme_bool_type; + +void +ao_scheme_bool_write(ao_poly v); + +#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); +#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); + +void +ao_scheme_cons_display(ao_poly); + +int +ao_scheme_cons_length(struct ao_scheme_cons *cons); + +/* string */ +extern const struct ao_scheme_type ao_scheme_string_type; + +char * +ao_scheme_string_copy(char *a); + +char * +ao_scheme_string_cat(char *a, char *b); + +ao_poly +ao_scheme_string_pack(struct ao_scheme_cons *cons); + +ao_poly +ao_scheme_string_unpack(char *a); + +void +ao_scheme_string_write(ao_poly s); + +void +ao_scheme_string_display(ao_poly s); + +/* 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); + +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); + +int32_t +ao_scheme_poly_integer(ao_poly p); + +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); + +extern const struct ao_scheme_type ao_scheme_bigint_type; +/* prim */ +void +ao_scheme_poly_write(ao_poly p); + +void +ao_scheme_poly_display(ao_poly p); + +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 */ +extern const struct ao_scheme_type ao_scheme_float_type; + +void +ao_scheme_float_write(ao_poly p); + +ao_poly +ao_scheme_float_get(float value); + +static inline uint8_t +ao_scheme_number_typep(uint8_t t) +{ + return ao_scheme_integer_typep(t) || (t == AO_SCHEME_FLOAT); +} + +float +ao_scheme_poly_number(ao_poly p); + +/* builtin */ +void +ao_scheme_builtin_write(ao_poly b); + +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 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); + +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); + +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; + +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); + +ao_poly +ao_scheme_stack_eval(void); + +/* error */ + +void +ao_scheme_vprintf(char *format, va_list args); + +void +ao_scheme_printf(char *format, ...); + +void +ao_scheme_error_poly(char *name, ao_poly poly, ao_poly last); + +void +ao_scheme_error_frame(int indent, char *name, struct ao_scheme_frame *frame); + +ao_poly +ao_scheme_error(int error, char *format, ...); + +/* builtins */ + +#define AO_SCHEME_BUILTIN_DECLS +#include "ao_scheme_builtin.h" + +/* debugging macros */ + +#if DBG_EVAL || DBG_READ || DBG_MEM +#define DBG_CODE 1 +int ao_scheme_stack_depth; +#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)) +#define DBG_POLY(a) ao_scheme_poly_write(a) +#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)) +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(...) DBGI(__VA_ARGS__) +#define RDBG_IN() DBG_IN() +#define RDBG_OUT() DBG_OUT() +#else +#define RDBGI(...) +#define RDBG_IN() +#define RDBG_OUT() +#endif + +#define DBG_MEM_START 1 + +#if DBG_MEM + +#include +extern int dbg_move_depth; +#define MDBG_DUMP 1 +#define MDBG_OFFSET(a) ((a) ? (int) ((uint8_t *) (a) - ao_scheme_pool) : -1) + +extern int dbg_mem; + +#define MDBG_DO(a) DBG_DO(a) +#define MDBG_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 new file mode 100644 index 00000000..cb32b7fe --- /dev/null +++ b/src/scheme/ao_scheme_atom.c @@ -0,0 +1,167 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#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; + +struct ao_scheme_atom * +ao_scheme_atom_intern(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 + ao_scheme_string_stash(0, name); + atom = ao_scheme_alloc(name_size(name)); + name = ao_scheme_string_fetch(0); + if (atom) { + atom->type = AO_SCHEME_ATOM; + atom->next = ao_scheme_atom_poly(ao_scheme_atoms); + ao_scheme_atoms = atom; + strcpy(atom->name, 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) +{ + struct ao_scheme_atom *atom = ao_scheme_poly_atom(a); + printf("%s", atom->name); +} diff --git a/src/scheme/ao_scheme_bool.c b/src/scheme/ao_scheme_bool.c new file mode 100644 index 00000000..c1e880ca --- /dev/null +++ b/src/scheme/ao_scheme_bool.c @@ -0,0 +1,73 @@ +/* + * Copyright © 2017 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +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) +{ + struct ao_scheme_bool *b = ao_scheme_poly_bool(v); + + 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 new file mode 100644 index 00000000..49f218f6 --- /dev/null +++ b/src/scheme/ao_scheme_builtin.c @@ -0,0 +1,868 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include +#include + +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 "???"; + } +} +#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 "???"; +} + +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 "(unknown)"; +} +#endif + +void +ao_scheme_builtin_write(ao_poly b) +{ + struct ao_scheme_builtin *builtin = ao_scheme_poly_builtin(b); + 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, "%s: arg %d invalid type %v", ao_scheme_poly_atom(name)->name, argc, car); + return _ao_scheme_bool_true; +} + +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_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); + cons = ao_scheme_cons_cdr(cons); + if (cons) + printf(" "); + } + printf("\n"); + 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_display(val); + cons = ao_scheme_cons_cdr(cons); + } + return _ao_scheme_bool_true; +} + +ao_poly +ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) +{ + struct ao_scheme_cons *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; + 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)); + else if (ct == AO_SCHEME_FLOAT) + ret = ao_scheme_float_get(-ao_scheme_poly_number(ret)); + break; + case builtin_divide: + if (ao_scheme_integer_typep(ct) && ao_scheme_poly_integer(ret) == 1) + ; + else if (ao_scheme_number_typep(ct)) { + float v = ao_scheme_poly_number(ret); + ret = ao_scheme_float_get(1/v); + } + break; + default: + break; + } + } + } else if (ao_scheme_integer_typep(rt) && ao_scheme_integer_typep(ct)) { + int32_t r = ao_scheme_poly_integer(ret); + int32_t c = ao_scheme_poly_integer(car); + int64_t t; + + switch(op) { + case builtin_plus: + r += c; + check_overflow: + if (r < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < r) + goto inexact; + break; + case builtin_minus: + r -= c; + goto check_overflow; + break; + case builtin_times: + t = (int64_t) r * (int64_t) c; + if (t < AO_SCHEME_MIN_BIGINT || AO_SCHEME_MAX_BIGINT < t) + goto inexact; + r = (int32_t) t; + break; + case builtin_divide: + if (c != 0 && (r % c) == 0) + r /= c; + else + goto inexact; + 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; + } + ret = ao_scheme_integer_poly(r); + } 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; + } + ret = ao_scheme_float_get(r); + } + + else if (rt == AO_SCHEME_STRING && ct == AO_SCHEME_STRING && op == builtin_plus) + ret = ao_scheme_string_poly(ao_scheme_string_cat(ao_scheme_poly_string(ret), + ao_scheme_poly_string(car))); + 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); +} + +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) { + if (left != right) + return _ao_scheme_bool_false; + } 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); + int32_t r = ao_scheme_poly_integer(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; + default: + break; + } + } else if (lt == AO_SCHEME_STRING && rt == AO_SCHEME_STRING) { + int c = strcmp(ao_scheme_poly_string(left), + ao_scheme_poly_string(right)); + 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; + default: + break; + } + } + } + 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_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) +{ + ao_poly led; + 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; + 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) +{ + ao_poly delay; + 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; + delay = ao_scheme_arg(cons, 0); + ao_scheme_os_delay(ao_scheme_poly_int(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_int_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 (v != AO_SCHEME_NIL && ao_scheme_poly_type(v) == AO_SCHEME_CONS) + return _ao_scheme_bool_true; + return _ao_scheme_bool_false; +} + +ao_poly +ao_scheme_do_integerp(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_INT: + case AO_SCHEME_BIGINT: + return _ao_scheme_bool_true; + default: + return _ao_scheme_bool_false; + } +} + +ao_poly +ao_scheme_do_numberp(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_INT: + case AO_SCHEME_BIGINT: + case AO_SCHEME_FLOAT: + return _ao_scheme_bool_true; + default: + return _ao_scheme_bool_false; + } +} + +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_led, 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_poly_type(v) != AO_SCHEME_CONS) + 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_string_copy(ao_scheme_poly_atom(ao_scheme_arg(cons, 0))->name)); +} + +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_atom_intern(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))); + 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)); +} + +#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 new file mode 100644 index 00000000..cb65e252 --- /dev/null +++ b/src/scheme/ao_scheme_builtin.txt @@ -0,0 +1,68 @@ +f_lambda eval +f_lambda read +nlambda lambda +nlambda nlambda +nlambda macro +f_lambda car +f_lambda cdr +f_lambda cons +f_lambda last +f_lambda length +nlambda quote +atom quasiquote +atom unquote +atom unquote_splicing unquote-splicing +f_lambda set +macro setq set! +f_lambda def +nlambda cond +nlambda begin +nlambda while +f_lambda write +f_lambda display +f_lambda plus + +f_lambda minus - +f_lambda times * +f_lambda divide / +f_lambda modulo modulo % +f_lambda remainder +f_lambda quotient +f_lambda equal = eq? eqv? +f_lambda less < +f_lambda greater > +f_lambda less_equal <= +f_lambda greater_equal >= +f_lambda list_to_string list->string +f_lambda string_to_list string->list +f_lambda flush_output flush-output +f_lambda delay +f_lambda led +f_lambda save +f_lambda restore +f_lambda call_cc call-with-current-continuation call/cc +f_lambda collect +f_lambda nullp null? +f_lambda not +f_lambda listp list? +f_lambda pairp pair? +f_lambda integerp integer? exact? exact-integer? +f_lambda numberp number? real? +f_lambda booleanp boolean? +f_lambda set_car set-car! +f_lambda set_cdr set-cdr! +f_lambda symbolp symbol? +f_lambda symbol_to_string symbol->string +f_lambda string_to_symbol string->symbol +f_lambda stringp string? +f_lambda procedurep procedure? +lambda apply +f_lambda read_char read-char +f_lambda write_char write-char +f_lambda exit +f_lambda current_jiffy current-jiffy +f_lambda current_second current-second +f_lambda jiffies_per_second jiffies-per-second +f_lambda finitep finite? +f_lambda infinitep infinite? +f_lambda inexactp inexact? +f_lambda sqrt diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c new file mode 100644 index 00000000..03dad956 --- /dev/null +++ b/src/scheme/ao_scheme_cons.c @@ -0,0 +1,201 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +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_poly_type(cdr) != AO_SCHEME_CONS) { + ao_scheme_poly_mark(cdr, 1); + 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_poly_base_type(cdr) != AO_SCHEME_CONS) { + (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(0, car); + ao_scheme_poly_stash(1, cdr); + cons = ao_scheme_alloc(sizeof (struct ao_scheme_cons)); + cdr = ao_scheme_poly_fetch(1); + car = ao_scheme_poly_fetch(0); + 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_poly_type(cdr) != AO_SCHEME_CONS) { + (void) ao_scheme_error(AO_SCHEME_INVALID, "improper list"); + 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)); +} + +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) +{ + struct ao_scheme_cons *cons = ao_scheme_poly_cons(c); + ao_poly cdr; + int first = 1; + + printf("("); + while (cons) { + if (!first) + printf(" "); + ao_scheme_poly_write(cons->car); + cdr = cons->cdr; + if (cdr == c) { + printf(" ..."); + break; + } + if (ao_scheme_poly_type(cdr) == AO_SCHEME_CONS) { + cons = ao_scheme_poly_cons(cdr); + first = 0; + } else { + printf(" . "); + ao_scheme_poly_write(cdr); + cons = NULL; + } + } + printf(")"); +} + +void +ao_scheme_cons_display(ao_poly c) +{ + struct ao_scheme_cons *cons = ao_scheme_poly_cons(c); + ao_poly cdr; + + while (cons) { + ao_scheme_poly_display(cons->car); + cdr = cons->cdr; + if (cdr == c) { + printf("..."); + break; + } + if (ao_scheme_poly_type(cdr) == AO_SCHEME_CONS) + cons = ao_scheme_poly_cons(cdr); + else { + ao_scheme_poly_display(cdr); + cons = NULL; + } + } +} + +int +ao_scheme_cons_length(struct ao_scheme_cons *cons) +{ + int len = 0; + while (cons) { + len++; + cons = ao_scheme_poly_cons(cons->cdr); + } + return len; +} diff --git a/src/scheme/ao_scheme_const.lisp b/src/scheme/ao_scheme_const.lisp new file mode 100644 index 00000000..422bdd63 --- /dev/null +++ b/src/scheme/ao_scheme_const.lisp @@ -0,0 +1,813 @@ +; +; Copyright © 2016 Keith Packard +; +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation, either version 2 of the License, or +; (at your option) any later version. +; +; This program is distributed in the hope that it will be useful, but +; WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +; General Public License for more details. +; +; Lisp code placed in ROM + + ; return a list containing all of the arguments +(def (quote list) (lambda l l)) + +(def (quote def!) + (macro (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 ((list? 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 ) + ; (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 c) c) +(define (integer->char c) 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")) + +;(define number->string (lambda (arg . opt) +; (let ((base (if (null? opt) 10 (car opt))) + ; +; + diff --git a/src/scheme/ao_scheme_error.c b/src/scheme/ao_scheme_error.c new file mode 100644 index 00000000..d580a2c0 --- /dev/null +++ b/src/scheme/ao_scheme_error.c @@ -0,0 +1,139 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include + +void +ao_scheme_error_poly(char *name, ao_poly poly, ao_poly last) +{ + int first = 1; + printf("\t\t%s(", name); + if (ao_scheme_poly_type(poly) == AO_SCHEME_CONS) { + if (poly) { + while (poly) { + struct ao_scheme_cons *cons = ao_scheme_poly_cons(poly); + if (!first) + printf("\t\t "); + else + first = 0; + ao_scheme_poly_write(cons->car); + printf("\n"); + if (poly == last) + break; + poly = cons->cdr; + } + printf("\t\t )\n"); + } else + printf(")\n"); + } else { + ao_scheme_poly_write(poly); + printf("\n"); + } +} + +static void tabs(int indent) +{ + while (indent--) + printf("\t"); +} + +void +ao_scheme_error_frame(int indent, char *name, struct ao_scheme_frame *frame) +{ + int f; + + tabs(indent); + printf ("%s{", name); + if (frame) { + struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); + if (frame->type & AO_SCHEME_FRAME_PRINT) + printf("recurse..."); + else { + frame->type |= AO_SCHEME_FRAME_PRINT; + for (f = 0; f < frame->num; f++) { + if (f != 0) { + tabs(indent); + printf(" "); + } + ao_scheme_poly_write(vals->vals[f].atom); + printf(" = "); + ao_scheme_poly_write(vals->vals[f].val); + printf("\n"); + } + if (frame->prev) + ao_scheme_error_frame(indent + 1, "prev: ", ao_scheme_poly_frame(frame->prev)); + frame->type &= ~AO_SCHEME_FRAME_PRINT; + } + tabs(indent); + printf(" }\n"); + } else + printf ("}\n"); +} + +void +ao_scheme_vprintf(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)); + 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(char *format, ...) +{ + va_list args; + va_start(args, format); + ao_scheme_vprintf(format, args); + va_end(args); +} + +ao_poly +ao_scheme_error(int error, 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)); + 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 new file mode 100644 index 00000000..9b3cf63e --- /dev/null +++ b/src/scheme/ao_scheme_eval.c @@ -0,0 +1,578 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include + +struct ao_scheme_stack *ao_scheme_stack; +ao_poly ao_scheme_v; +uint8_t ao_scheme_skip_cons_free; + +ao_poly +ao_scheme_set_cond(struct ao_scheme_cons *c) +{ + 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 */ + case AO_SCHEME_BOOL: + case AO_SCHEME_INT: + case AO_SCHEME_BIGINT: + case AO_SCHEME_FLOAT: + case AO_SCHEME_STRING: + case AO_SCHEME_BUILTIN: + case AO_SCHEME_LAMBDA: + 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) && !ao_scheme_skip_cons_free) { + 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; + } + ao_scheme_skip_cons_free = 0; + 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_skip_cons_free = 1; + 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_v || ao_scheme_poly_type(ao_scheme_v) != AO_SCHEME_CONS) { + 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_poly_type(ao_scheme_v) == AO_SCHEME_CONS) { + *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 new file mode 100644 index 00000000..541f0264 --- /dev/null +++ b/src/scheme/ao_scheme_float.c @@ -0,0 +1,148 @@ +/* + * Copyright © 2017 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include + +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", +}; + +void +ao_scheme_float_write(ao_poly p) +{ + struct ao_scheme_float *f = ao_scheme_poly_float(p); + float v = f->value; + + if (isnanf(v)) + printf("+nan.0"); + else if (isinff(v)) { + if (v < 0) + printf("-"); + else + printf("+"); + printf("inf.0"); + } else + printf ("%g", f->value); +} + +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_OTHER: + switch (ao_scheme_other_type(ao_scheme_poly_other(p))) { + case AO_SCHEME_BIGINT: + return ao_scheme_bigint_int(ao_scheme_poly_bigint(p)->value); + case AO_SCHEME_FLOAT: + return ao_scheme_poly_float(p)->value; + } + } + 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))); +} diff --git a/src/scheme/ao_scheme_frame.c b/src/scheme/ao_scheme_frame.c new file mode 100644 index 00000000..e5d481e7 --- /dev/null +++ b/src/scheme/ao_scheme_frame.c @@ -0,0 +1,330 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +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(ao_scheme_poly_write(v->val)); + 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 (;;) { + MDBG_MOVE("frame mark %d\n", MDBG_OFFSET(frame)); + if (!AO_SCHEME_IS_POOL(frame)) + break; + ao_scheme_poly_mark(frame->vals, 0); + 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; + int ret; + + MDBG_MOVE("frame move %d\n", MDBG_OFFSET(frame)); + if (!AO_SCHEME_IS_POOL(frame)) + break; + ao_scheme_poly_move(&frame->vals, 0); + 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", +}; + +void +ao_scheme_frame_write(ao_poly p) +{ + struct ao_scheme_frame *frame = ao_scheme_poly_frame(p); + struct ao_scheme_frame_vals *vals = ao_scheme_poly_frame_vals(frame->vals); + int f; + + printf ("{"); + if (frame) { + if (frame->type & AO_SCHEME_FRAME_PRINT) + printf("recurse..."); + else { + frame->type |= AO_SCHEME_FRAME_PRINT; + for (f = 0; f < frame->num; f++) { + if (f != 0) + printf(", "); + ao_scheme_poly_write(vals->vals[f].atom); + printf(" = "); + ao_scheme_poly_write(vals->vals[f].val); + } + if (frame->prev) + ao_scheme_poly_write(frame->prev); + frame->type &= ~AO_SCHEME_FRAME_PRINT; + } + } + printf("}"); +} + +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(0, frame); + vals = ao_scheme_frame_vals_new(num); + frame = ao_scheme_frame_fetch(0); + 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(0, frame); + new_vals = ao_scheme_frame_vals_new(new_num); + frame = ao_scheme_frame_fetch(0); + 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(0, atom); + ao_scheme_poly_stash(1, val); + frame = ao_scheme_frame_realloc(frame, f + 1); + val = ao_scheme_poly_fetch(1); + atom = ao_scheme_poly_fetch(0); + 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 new file mode 100644 index 00000000..350a5d35 --- /dev/null +++ b/src/scheme/ao_scheme_int.c @@ -0,0 +1,79 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +void +ao_scheme_int_write(ao_poly p) +{ + int i = ao_scheme_poly_int(p); + printf("%d", i); +} + +int32_t +ao_scheme_poly_integer(ao_poly p) +{ + switch (ao_scheme_poly_base_type(p)) { + case AO_SCHEME_INT: + return ao_scheme_poly_int(p); + case AO_SCHEME_OTHER: + if (ao_scheme_other_type(ao_scheme_poly_other(p)) == AO_SCHEME_BIGINT) + return ao_scheme_bigint_int(ao_scheme_poly_bigint(p)->value); + } + return AO_SCHEME_NOT_INTEGER; +} + +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 = ao_scheme_int_bigint(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) +{ + struct ao_scheme_bigint *bi = ao_scheme_poly_bigint(p); + + printf("%d", ao_scheme_bigint_int(bi->value)); +} diff --git a/src/scheme/ao_scheme_lambda.c b/src/scheme/ao_scheme_lambda.c new file mode 100644 index 00000000..ec6f858c --- /dev/null +++ b/src/scheme/ao_scheme_lambda.c @@ -0,0 +1,208 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#include "ao_scheme.h" + +int +lambda_size(void *addr) +{ + (void) addr; + return sizeof (struct ao_scheme_lambda); +} + +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); +} + +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) +{ + 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); + cons = ao_scheme_poly_cons(cons->cdr); + } + printf(")"); +} + +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(0, code); + lambda = ao_scheme_alloc(sizeof (struct ao_scheme_lambda)); + code = ao_scheme_cons_fetch(0); + 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(1, varargs); + next_frame = ao_scheme_frame_new(args_wanted + (varargs != AO_SCHEME_NIL)); + varargs = ao_scheme_poly_fetch(1); + 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_lex.c b/src/scheme/ao_scheme_lex.c new file mode 100644 index 00000000..266b1fc0 --- /dev/null +++ b/src/scheme/ao_scheme_lex.c @@ -0,0 +1,16 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + diff --git a/src/scheme/ao_scheme_make_builtin b/src/scheme/ao_scheme_make_builtin new file mode 100644 index 00000000..8e9c2c0b --- /dev/null +++ b/src/scheme/ao_scheme_make_builtin @@ -0,0 +1,190 @@ +#!/usr/bin/nickle + +typedef struct { + 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", +}; + +string[*] +make_lisp(string[*] tokens) +{ + string[...] lisp = {}; + + if (dim(tokens) < 3) + return (string[1]) { tokens[dim(tokens) - 1] }; + return (string[dim(tokens)-2]) { [i] = tokens[i+2] }; +} + +builtin_t +read_builtin(file f) { + string line = File::fgets(f); + string[*] tokens = String::wordsplit(line, " \t"); + + return (builtin_t) { + .type = dim(tokens) > 0 ? type_map[tokens[0]] : "#", + .c_name = dim(tokens) > 1 ? tokens[1] : "#", + .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; +} + +bool is_atom(builtin_t b) = b.type == "atom"; + +void +dump_ids(builtin_t[*] builtins) { + printf("#ifdef AO_SCHEME_BUILTIN_ID\n"); + printf("#undef AO_SCHEME_BUILTIN_ID\n"); + printf("enum ao_scheme_builtin_id {\n"); + for (int i = 0; i < dim(builtins); i++) + if (!is_atom(builtins[i])) + printf("\tbuiltin_%s,\n", builtins[i].c_name); + 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_atom(builtins[i])) + printf("\tcase builtin_%s: return ao_scheme_poly_atom(_atom(\"%s\"))->name;\n", + builtins[i].c_name, builtins[i].lisp_names[0]); + printf("\tdefault: return \"???\";\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_atom(builtins[i])) { + printf("\t[builtin_%s] = _ao_scheme_atom_", + builtins[i].c_name); + cify_lisp(builtins[i].lisp_names[0]); + printf(",\n"); + } + } + 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_atom(builtins[i])) + printf("\t[builtin_%s] = ao_scheme_do_%s,\n", + builtins[i].c_name, + builtins[i].c_name); + } + 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_atom(builtins[i])) { + printf("ao_poly\n"); + printf("ao_scheme_do_%s(struct ao_scheme_cons *cons);\n", + builtins[i].c_name); + } + } + 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_atom(builtins[i])) { + for (int j = 0; j < dim(builtins[i].lisp_names); j++) { + printf ("\t{ .name = \"%s\", .args = AO_SCHEME_FUNC_%s, .func = builtin_%s },\n", + builtins[i].lisp_names[j], + builtins[i].type, + builtins[i].c_name); + } + } + } + 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++) { + 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 main() { + if (dim(argv) < 2) { + File::fprintf(stderr, "usage: %s \n", argv[0]); + exit(1); + } + twixt(file f = File::open(argv[1], "r"); File::close(f)) { + builtin_t[*] builtins = read_builtins(f); + dump_ids(builtins); + dump_casename(builtins); + dump_arrayname(builtins); + dump_funcs(builtins); + dump_decls(builtins); + dump_consts(builtins); + dump_atoms(builtins); + } +} + +main(); diff --git a/src/scheme/ao_scheme_make_const.c b/src/scheme/ao_scheme_make_const.c new file mode 100644 index 00000000..cf42ec52 --- /dev/null +++ b/src/scheme/ao_scheme_make_const.c @@ -0,0 +1,395 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include +#include +#include +#include + +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 { + char *name; + int args; + enum ao_scheme_builtin_id func; +}; + +#define AO_SCHEME_BUILTIN_CONSTS +#include "ao_scheme_builtin.h" + +#define N_FUNC (sizeof funcs / sizeof funcs[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; +} + +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; + +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; +} + +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); + +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; +} + +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 (list != AO_SCHEME_NIL && ao_scheme_poly_type(list) == AO_SCHEME_CONS) { + 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; +} + +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); + putchar ('\n'); + } + return 1; +} + +static FILE *in; +static FILE *out; + +int +ao_scheme_getc(void) +{ + return getc(in); +} + +static const struct option options[] = { + { .name = "out", .has_arg = 1, .val = 'o' }, + { 0, 0, 0, 0 } +}; + +static void usage(char *program) +{ + fprintf(stderr, "usage: %s [--out=] [input]\n", program); + exit(1); +} + +int +main(int argc, char **argv) +{ + int f, o; + ao_poly val; + struct ao_scheme_atom *a; + struct ao_scheme_builtin *b; + int in_atom = 0; + char *out_name = NULL; + int c; + enum ao_scheme_builtin_id prev_func; + + in = stdin; + out = stdout; + + while ((c = getopt_long(argc, argv, "o:", options, NULL)) != -1) { + switch (c) { + case 'o': + out_name = 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; + for (f = 0; f < (int) N_FUNC; f++) { + if (funcs[f].func != prev_func) + b = ao_scheme_make_builtin(funcs[f].func, funcs[f].args); + a = ao_scheme_atom_intern(funcs[f].name); + ao_scheme_atom_def(ao_scheme_atom_poly(a), + ao_scheme_builtin_poly(b)); + } + + /* end of file value */ + a = ao_scheme_atom_intern("eof"); + ao_scheme_atom_def(ao_scheme_atom_poly(a), + ao_scheme_atom_poly(a)); + + /* 'else' */ + a = ao_scheme_atom_intern("else"); + + 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); + printf("\n"); + exit(1); + } + } + + if (out_name) { + out = fopen(out_name, "w"); + if (!out) { + perror(out_name); + exit(1); + } + } + + fprintf(out, "/* Generated file, do not edit */\n\n"); + + 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)) { + char *n = a->name, c; + fprintf(out, "#define _ao_scheme_atom_"); + while ((c = *n++)) { + if (isalnum(c)) + fprintf(out, "%c", c); + else + fprintf(out, "%02x", c); + } + fprintf(out, " 0x%04x\n", ao_scheme_atom_poly(a)); + } + fprintf(out, "#ifdef AO_SCHEME_CONST_BITS\n"); + fprintf(out, "const uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute((aligned(4))) = {"); + for (o = 0; o < ao_scheme_top; o++) { + uint8_t c; + if ((o & 0xf) == 0) + fprintf(out, "\n\t"); + else + fprintf(out, " "); + c = ao_scheme_const[o]; + if (!in_atom) + in_atom = is_atom(o); + if (in_atom) { + fprintf(out, " '%c',", c); + in_atom--; + } else { + fprintf(out, "0x%02x,", c); + } + } + 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 new file mode 100644 index 00000000..acc726c8 --- /dev/null +++ b/src/scheme/ao_scheme_mem.c @@ -0,0 +1,968 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#define AO_SCHEME_CONST_BITS + +#include "ao_scheme.h" +#include +#include + +#ifdef AO_SCHEME_MAKE_CONST + +/* + * When building the constant table, it is the + * pool for allocations. + */ + +#include +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 + +#if DBG_MEM +int dbg_move_depth; +int dbg_mem = DBG_MEM_START; +int dbg_validate = 0; + +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(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() +#endif + +uint8_t ao_scheme_exception; + +struct ao_scheme_root { + const struct ao_scheme_type *type; + void **addr; +}; + +static struct ao_scheme_cons *save_cons[2]; +static char *save_string[2]; +static struct ao_scheme_frame *save_frame[1]; +static ao_poly save_poly[3]; + +static const struct ao_scheme_root ao_scheme_root[] = { + { + .type = &ao_scheme_cons_type, + .addr = (void **) &save_cons[0], + }, + { + .type = &ao_scheme_cons_type, + .addr = (void **) &save_cons[1], + }, + { + .type = &ao_scheme_string_type, + .addr = (void **) &save_string[0], + }, + { + .type = &ao_scheme_string_type, + .addr = (void **) &save_string[1], + }, + { + .type = &ao_scheme_frame_type, + .addr = (void **) &save_frame[0], + }, + { + .type = NULL, + .addr = (void **) (void *) &save_poly[0] + }, + { + .type = NULL, + .addr = (void **) (void *) &save_poly[1] + }, + { + .type = NULL, + .addr = (void **) (void *) &save_poly[2] + }, + { + .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 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)) + 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; + 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 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; + + 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(); +#endif + + /* Shuffle existing entries right */ + int 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; + MDBG_MOVE("busy:"); + for (i = 0; i < ao_scheme_top; i += 4) { + if ((i & 0xff) == 0) { + MDBG_MORE("\n"); + MDBG_MOVE("%s", ""); + } + else if ((i & 0x1f) == 0) + MDBG_MORE(" "); + if (busy(ao_scheme_busy, i)) + MDBG_MORE("*"); + else + MDBG_MORE("-"); + } + MDBG_MORE ("\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, + [AO_SCHEME_STRING] = &ao_scheme_string_type, + [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_BIGINT] = &ao_scheme_bigint_type, + [AO_SCHEME_FLOAT] = &ao_scheme_float_type, +}; + +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 +int ao_scheme_collects[2]; +int ao_scheme_freed[2]; +int ao_scheme_loops[2]; +#endif + +int ao_scheme_last_top; + +int +ao_scheme_collect(uint8_t style) +{ + int i; + int top; +#if DBG_MEM_STATS + int loops = 0; +#endif +#if DBG_MEM + struct ao_scheme_record *mark_record = NULL, *move_record = NULL; + + MDBG_MOVE("collect %d\n", ao_scheme_collects[style]); +#endif + MDBG_DO(ao_scheme_frame_write(ao_scheme_frame_poly(ao_scheme_frame_global))); + + /* The first time through, we're doing a full collect */ + if (ao_scheme_last_top == 0) + style = AO_SCHEME_COLLECT_FULL; + + /* 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 (;;) { +#if DBG_MEM_STATS + loops++; +#endif + MDBG_MOVE("move chunks from %d to %d\n", chunk_low, top); + /* Find the sizes of the first chunk of objects to move */ + reset_chunks(); + walk(ao_scheme_mark_ref, ao_scheme_poly_mark_ref); +#if DBG_MEM + + 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; + } + + /* + * 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 + 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 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)); + + 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(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 + */ + + +/* + * Mark a block of memory with an explicit size + */ + +int +ao_scheme_mark_block(void *addr, int size) +{ + int offset; + if (!AO_SCHEME_IS_POOL(addr)) + return 1; + + offset = pool_offset(addr); + MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); + if (busy(ao_scheme_busy, offset)) { + MDBG_MOVE("already marked\n"); + return 1; + } + mark(ao_scheme_busy, offset); + note_chunk(offset, size); + return 0; +} + +/* + * Note a reference to memory and collect information about a few + * object sizes at a time + */ + +int +ao_scheme_mark_memory(const struct ao_scheme_type *type, void *addr) +{ + int offset; + if (!AO_SCHEME_IS_POOL(addr)) + return 1; + + offset = pool_offset(addr); + MDBG_MOVE("mark memory %d\n", MDBG_OFFSET(addr)); + if (busy(ao_scheme_busy, offset)) { + MDBG_MOVE("already marked\n"); + return 1; + } + mark(ao_scheme_busy, offset); + note_chunk(offset, ao_scheme_size(type, addr)); + return 0; +} + +/* + * Mark an object and all that it refereces + */ +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; + + 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)) + return 1; + + if (type == AO_SCHEME_CONS && do_note_cons) { + note_cons(pool_offset(addr)); + return 1; + } else { + if (type == AO_SCHEME_OTHER) + type = ao_scheme_other_type(addr); + + const struct ao_scheme_type *lisp_type = ao_scheme_types[type]; +#if DBG_MEM + if (!lisp_type) + ao_scheme_abort(); +#endif + + return ao_scheme_mark(lisp_type, addr); + } +} + +/* + * 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)) + 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(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); + MDBG_DO(ao_scheme_record(type, addr, ao_scheme_size(type, addr))); + return 0; +} + +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) +{ + uint8_t type; + ao_poly p = *ref; + int ret; + void *addr; + uint16_t offset, orig_offset; + uint8_t base_type; + + base_type = type = ao_scheme_poly_base_type(p); + + if (type == AO_SCHEME_INT) + return 1; + + addr = ao_scheme_ref(p); + if (!AO_SCHEME_IS_POOL(addr)) + return 1; + + orig_offset = pool_offset(addr); + offset = move_map(orig_offset); + + if (type == AO_SCHEME_CONS && do_note_cons) { + note_cons(orig_offset); + ret = 1; + } else { + if (type == AO_SCHEME_OTHER) + type = ao_scheme_other_type(ao_scheme_pool + offset); + + const struct ao_scheme_type *lisp_type = ao_scheme_types[type]; +#if DBG_MEM + if (!lisp_type) + ao_scheme_abort(); +#endif + + ret = ao_scheme_move(lisp_type, &addr); + } + + /* Re-write the poly value */ + if (offset != orig_offset) { + ao_poly np = ao_scheme_poly(ao_scheme_pool + offset, base_type); + MDBG_MOVE("poly %d moved %d -> %d\n", + type, orig_offset, offset); + *ref = np; + } + return ret; +} + +#if DBG_MEM +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_cons_stash(int id, struct ao_scheme_cons *cons) +{ + assert(save_cons[id] == 0); + save_cons[id] = cons; +} + +struct ao_scheme_cons * +ao_scheme_cons_fetch(int id) +{ + struct ao_scheme_cons *cons = save_cons[id]; + save_cons[id] = NULL; + return cons; +} + +void +ao_scheme_poly_stash(int id, ao_poly poly) +{ + assert(save_poly[id] == AO_SCHEME_NIL); + save_poly[id] = poly; +} + +ao_poly +ao_scheme_poly_fetch(int id) +{ + ao_poly poly = save_poly[id]; + save_poly[id] = AO_SCHEME_NIL; + return poly; +} + +void +ao_scheme_string_stash(int id, char *string) +{ + assert(save_string[id] == NULL); + save_string[id] = string; +} + +char * +ao_scheme_string_fetch(int id) +{ + char *string = save_string[id]; + save_string[id] = NULL; + return string; +} + +void +ao_scheme_frame_stash(int id, struct ao_scheme_frame *frame) +{ + assert(save_frame[id] == NULL); + save_frame[id] = frame; +} + +struct ao_scheme_frame * +ao_scheme_frame_fetch(int id) +{ + struct ao_scheme_frame *frame = save_frame[id]; + save_frame[id] = NULL; + return frame; +} diff --git a/src/scheme/ao_scheme_poly.c b/src/scheme/ao_scheme_poly.c new file mode 100644 index 00000000..d726321c --- /dev/null +++ b/src/scheme/ao_scheme_poly.c @@ -0,0 +1,118 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +struct ao_scheme_funcs { + void (*write)(ao_poly); + void (*display)(ao_poly); +}; + +static const struct ao_scheme_funcs ao_scheme_funcs[AO_SCHEME_NUM_TYPE] = { + [AO_SCHEME_CONS] = { + .write = ao_scheme_cons_write, + .display = ao_scheme_cons_display, + }, + [AO_SCHEME_STRING] = { + .write = ao_scheme_string_write, + .display = ao_scheme_string_display, + }, + [AO_SCHEME_INT] = { + .write = ao_scheme_int_write, + .display = ao_scheme_int_write, + }, + [AO_SCHEME_ATOM] = { + .write = ao_scheme_atom_write, + .display = ao_scheme_atom_write, + }, + [AO_SCHEME_BUILTIN] = { + .write = ao_scheme_builtin_write, + .display = ao_scheme_builtin_write, + }, + [AO_SCHEME_FRAME] = { + .write = ao_scheme_frame_write, + .display = ao_scheme_frame_write, + }, + [AO_SCHEME_FRAME_VALS] = { + .write = NULL, + .display = NULL, + }, + [AO_SCHEME_LAMBDA] = { + .write = ao_scheme_lambda_write, + .display = ao_scheme_lambda_write, + }, + [AO_SCHEME_STACK] = { + .write = ao_scheme_stack_write, + .display = ao_scheme_stack_write, + }, + [AO_SCHEME_BOOL] = { + .write = ao_scheme_bool_write, + .display = ao_scheme_bool_write, + }, + [AO_SCHEME_BIGINT] = { + .write = ao_scheme_bigint_write, + .display = ao_scheme_bigint_write, + }, + [AO_SCHEME_FLOAT] = { + .write = ao_scheme_float_write, + .display = ao_scheme_float_write, + }, +}; + +static const struct ao_scheme_funcs * +funcs(ao_poly p) +{ + uint8_t type = ao_scheme_poly_type(p); + + if (type < AO_SCHEME_NUM_TYPE) + return &ao_scheme_funcs[type]; + return NULL; +} + +void +ao_scheme_poly_write(ao_poly p) +{ + const struct ao_scheme_funcs *f = funcs(p); + + if (f && f->write) + f->write(p); +} + +void +ao_scheme_poly_display(ao_poly p) +{ + const struct ao_scheme_funcs *f = funcs(p); + + if (f && f->display) + f->display(p); +} + +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(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 new file mode 100644 index 00000000..6b1e9d66 --- /dev/null +++ b/src/scheme/ao_scheme_read.c @@ -0,0 +1,655 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include "ao_scheme_read.h" +#include +#include + +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, /* , */ + 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, /* ` */ + 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() +{ + 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; + } +} + +#define AO_SCHEME_TOKEN_MAX 32 + +static char token_string[AO_SCHEME_TOKEN_MAX]; +static int32_t token_int; +static int token_len; +static float token_float; + +static inline void add_token(int c) { + if (c && token_len < AO_SCHEME_TOKEN_MAX - 1) + 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'; +} + +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]) + +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; + case '`': + return QUASIQUOTE; + case ',': + c = lexc(); + if (c == '@') { + add_token(c); + end_token(); + return UNQUOTE_SPLICING; + } else { + lex_unget(c); + return UNQUOTE; + } + } + } + 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; + 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) { + int isfloat; + int hasdigit; + int isneg; + int isint; + int epos; + + isfloat = 1; + isint = 1; + hasdigit = 0; + token_int = 0; + isneg = 0; + epos = 0; + for (;;) { + if (!(lex_class & NUMBER)) { + isint = 0; + isfloat = 0; + } else { + if (!(lex_class & INTEGER)) + isint = 0; + if (token_len != epos && + (lex_class & SIGN)) + { + isint = 0; + isfloat = 0; + } + if (c == '-') + isneg = 1; + if (c == '.' && epos != 0) + isfloat = 0; + if (c == 'e' || c == 'E') { + if (token_len == 0) + isfloat = 0; + else + epos = token_len + 1; + } + if (lex_class & DIGIT) { + hasdigit = 1; + if (isint) + token_int = token_int * 10 + c - '0'; + } + } + add_token (c); + c = lexc (); + if ((lex_class & (NOTNAME)) && (c != '.' || !isfloat)) { + unsigned int u; +// if (lex_class & ENDOFFILE) +// clearerr (f); + lex_unget(c); + end_token (); + if (isint && hasdigit) { + if (isneg) + token_int = -token_int; + return NUM; + } + 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; + } + 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; + +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; + +#define READ_IN_QUOTE 0x01 +#define READ_SAW_DOT 0x02 +#define READ_DONE_DOT 0x04 + +static int +push_read_stack(int cons, int read_state) +{ + RDBGI("push read stack %p 0x%x\n", ao_scheme_read_cons, read_state); + RDBG_IN(); + if (cons) { + 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; + } + ao_scheme_read_cons = NULL; + ao_scheme_read_cons_tail = NULL; + return 1; +} + +static int +pop_read_stack(int cons) +{ + int read_state = 0; + if (cons) { + 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; + } + RDBG_OUT(); + RDBGI("pop read stack %p %d\n", ao_scheme_read_cons, read_state); + return read_state; +} + +ao_poly +ao_scheme_read(void) +{ + struct ao_scheme_atom *atom; + char *string; + int cons; + int read_state; + ao_poly v = AO_SCHEME_NIL; + + cons = 0; + read_state = 0; + ao_scheme_read_cons = ao_scheme_read_cons_tail = ao_scheme_read_stack = 0; + for (;;) { + parse_token = lex(); + while (parse_token == OPEN) { + if (!push_read_stack(cons, read_state)) + return AO_SCHEME_NIL; + cons++; + read_state = 0; + parse_token = lex(); + } + + switch (parse_token) { + case END: + default: + if (cons) + 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; + case FLOAT: + v = ao_scheme_float_get(token_float); + break; + 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_copy(token_string); + if (string) + v = ao_scheme_string_poly(string); + else + v = AO_SCHEME_NIL; + break; + case QUOTE: + case QUASIQUOTE: + case UNQUOTE: + case UNQUOTE_SPLICING: + if (!push_read_stack(cons, read_state)) + return AO_SCHEME_NIL; + cons++; + read_state = READ_IN_QUOTE; + switch (parse_token) { + case QUOTE: + v = _ao_scheme_atom_quote; + break; + 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; + } + break; + case CLOSE: + if (!cons) { + v = AO_SCHEME_NIL; + break; + } + v = ao_scheme_cons_poly(ao_scheme_read_cons); + --cons; + read_state = pop_read_stack(cons); + break; + case DOT: + if (!cons) { + 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 (!cons) + 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); + --cons; + read_state = pop_read_stack(cons); + } + } + return v; +} diff --git a/src/scheme/ao_scheme_read.h b/src/scheme/ao_scheme_read.h new file mode 100644 index 00000000..e9508835 --- /dev/null +++ b/src/scheme/ao_scheme_read.h @@ -0,0 +1,58 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#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 +# define QUASIQUOTE 5 +# define UNQUOTE 6 +# define UNQUOTE_SPLICING 7 +# define STRING 8 +# define NUM 9 +# define FLOAT 10 +# define DOT 11 +# define BOOL 12 + +/* + * character classes + */ + +# define PRINTABLE 0x0001 /* \t \n ' ' - ~ */ +# define SPECIAL 0x0002 /* ( [ { ) ] } ' ` , */ +# define DOTC 0x0004 /* . */ +# define WHITE 0x0008 /* ' ' \t \n */ +# define DIGIT 0x0010 /* [0-9] */ +# define SIGN 0x0020 /* +- */ +# define FLOATC 0x0040 /* . e E */ +# 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 new file mode 100644 index 00000000..9dbce5f2 --- /dev/null +++ b/src/scheme/ao_scheme_rep.c @@ -0,0 +1,36 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +ao_poly +ao_scheme_read_eval_print(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) { + if (ao_scheme_exception & AO_SCHEME_EXIT) + break; + ao_scheme_exception = 0; + } else { + ao_scheme_poly_write(out); + putchar ('\n'); + } + } + return out; +} diff --git a/src/scheme/ao_scheme_save.c b/src/scheme/ao_scheme_save.c new file mode 100644 index 00000000..af9345b8 --- /dev/null +++ b/src/scheme/ao_scheme_save.c @@ -0,0 +1,77 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +ao_poly +ao_scheme_do_save(struct ao_scheme_cons *cons) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_save, cons, 0, 0)) + return AO_SCHEME_NIL; + +#ifdef AO_SCHEME_SAVE + struct ao_scheme_os_save *os = (struct ao_scheme_os_save *) (void *) &ao_scheme_pool[AO_SCHEME_POOL]; + + 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) +{ + if (!ao_scheme_check_argc(_ao_scheme_atom_save, cons, 0, 0)) + return AO_SCHEME_NIL; + +#ifdef AO_SCHEME_SAVE + struct ao_scheme_os_save save; + struct ao_scheme_os_save *os = (struct ao_scheme_os_save *) (void *) &ao_scheme_pool[AO_SCHEME_POOL]; + + 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 new file mode 100644 index 00000000..d19dd6d6 --- /dev/null +++ b/src/scheme/ao_scheme_stack.c @@ -0,0 +1,280 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" + +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) +{ + struct ao_scheme_stack *s = ao_scheme_poly_stack(poly); + + while (s) { + if (s->type & AO_SCHEME_STACK_PRINT) { + printf("[recurse...]"); + return; + } + s->type |= AO_SCHEME_STACK_PRINT; + printf("\t[\n"); + printf("\t\texpr: "); ao_scheme_poly_write(s->list); printf("\n"); + printf("\t\tstate: %s\n", ao_scheme_state_names[s->state]); + ao_scheme_error_poly ("values: ", s->values, s->values_tail); + ao_scheme_error_poly ("sexprs: ", s->sexprs, AO_SCHEME_NIL); + ao_scheme_error_frame(2, "frame: ", ao_scheme_poly_frame(s->frame)); + printf("\t]\n"); + s->type &= ~AO_SCHEME_STACK_PRINT; + s = ao_scheme_poly_stack(s->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(0, old); + ao_scheme_stack_stash(1, new); + ao_scheme_stack_stash(2, prev); + n = ao_scheme_stack_new(); + prev = ao_scheme_stack_fetch(2); + new = ao_scheme_stack_fetch(1); + old = ao_scheme_stack_fetch(0); + 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_stack *new = ao_scheme_stack_copy(ao_scheme_poly_stack(ao_scheme_v)); + if (!new) + return AO_SCHEME_NIL; + + struct ao_scheme_cons *cons = ao_scheme_poly_cons(ao_scheme_stack->values); + + 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 new file mode 100644 index 00000000..e25306cb --- /dev/null +++ b/src/scheme/ao_scheme_string.c @@ -0,0 +1,161 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#include "ao_scheme.h" + +static void string_mark(void *addr) +{ + (void) addr; +} + +static int string_size(void *addr) +{ + if (!addr) + return 0; + return strlen(addr) + 1; +} + +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", +}; + +char * +ao_scheme_string_copy(char *a) +{ + int alen = strlen(a); + + ao_scheme_string_stash(0, a); + char *r = ao_scheme_alloc(alen + 1); + a = ao_scheme_string_fetch(0); + if (!r) + return NULL; + strcpy(r, a); + return r; +} + +char * +ao_scheme_string_cat(char *a, char *b) +{ + int alen = strlen(a); + int blen = strlen(b); + + ao_scheme_string_stash(0, a); + ao_scheme_string_stash(1, b); + char *r = ao_scheme_alloc(alen + blen + 1); + a = ao_scheme_string_fetch(0); + b = ao_scheme_string_fetch(1); + if (!r) + return NULL; + strcpy(r, a); + strcpy(r+alen, b); + return r; +} + +ao_poly +ao_scheme_string_pack(struct ao_scheme_cons *cons) +{ + int len = ao_scheme_cons_length(cons); + ao_scheme_cons_stash(0, cons); + char *r = ao_scheme_alloc(len + 1); + cons = ao_scheme_cons_fetch(0); + char *s = r; + + while (cons) { + if (!ao_scheme_integer_typep(ao_scheme_poly_type(cons->car))) + return ao_scheme_error(AO_SCHEME_INVALID, "non-int passed to pack"); + *s++ = ao_scheme_poly_integer(cons->car); + cons = ao_scheme_poly_cons(cons->cdr); + } + *s++ = 0; + return ao_scheme_string_poly(r); +} + +ao_poly +ao_scheme_string_unpack(char *a) +{ + struct ao_scheme_cons *cons = NULL, *tail = NULL; + int c; + int i; + + for (i = 0; (c = a[i]); i++) { + ao_scheme_cons_stash(0, cons); + ao_scheme_cons_stash(1, tail); + ao_scheme_string_stash(0, a); + struct ao_scheme_cons *n = ao_scheme_cons_cons(ao_scheme_int_poly(c), AO_SCHEME_NIL); + a = ao_scheme_string_fetch(0); + cons = ao_scheme_cons_fetch(0); + tail = ao_scheme_cons_fetch(1); + + 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) +{ + char *s = ao_scheme_poly_string(p); + char c; + + putchar('"'); + while ((c = *s++)) { + 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('"'); +} + +void +ao_scheme_string_display(ao_poly p) +{ + char *s = ao_scheme_poly_string(p); + char c; + + while ((c = *s++)) + putchar(c); +} diff --git a/src/scheme/make-const/.gitignore b/src/scheme/make-const/.gitignore new file mode 100644 index 00000000..bcd57242 --- /dev/null +++ b/src/scheme/make-const/.gitignore @@ -0,0 +1 @@ +ao_scheme_make_const diff --git a/src/scheme/make-const/Makefile b/src/scheme/make-const/Makefile new file mode 100644 index 00000000..caf7acbe --- /dev/null +++ b/src/scheme/make-const/Makefile @@ -0,0 +1,26 @@ +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 + +.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 new file mode 100644 index 00000000..f06bbbb1 --- /dev/null +++ b/src/scheme/make-const/ao_scheme_os.h @@ -0,0 +1,63 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#ifndef _AO_SCHEME_OS_H_ +#define _AO_SCHEME_OS_H_ + +#include +#include +#include + +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/test/ao_lisp_os.h b/src/test/ao_lisp_os.h deleted file mode 100644 index ebd16bb4..00000000 --- a/src/test/ao_lisp_os.h +++ /dev/null @@ -1,68 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. - */ - -#ifndef _AO_LISP_OS_H_ -#define _AO_LISP_OS_H_ - -#include -#include -#include - -#define AO_LISP_POOL_TOTAL 16384 -#define AO_LISP_SAVE 1 -#define DBG_MEM_STATS 1 - -extern int ao_lisp_getc(void); - -static inline void -ao_lisp_os_flush() { - fflush(stdout); -} - -static inline void -ao_lisp_abort(void) -{ - abort(); -} - -static inline void -ao_lisp_os_led(int led) -{ - printf("leds set to 0x%x\n", led); -} - -#define AO_LISP_JIFFIES_PER_SECOND 100 - -static inline void -ao_lisp_os_delay(int jiffies) -{ - struct timespec ts = { - .tv_sec = jiffies / AO_LISP_JIFFIES_PER_SECOND, - .tv_nsec = (jiffies % AO_LISP_JIFFIES_PER_SECOND) * (1000000000L / AO_LISP_JIFFIES_PER_SECOND) - }; - nanosleep(&ts, NULL); -} - -static inline int -ao_lisp_os_jiffy(void) -{ - struct timespec tp; - clock_gettime(CLOCK_MONOTONIC, &tp); - return tp.tv_sec * AO_LISP_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_LISP_JIFFIES_PER_SECOND)); -} - -#endif diff --git a/src/test/ao_lisp_test.c b/src/test/ao_lisp_test.c deleted file mode 100644 index 68e3a202..00000000 --- a/src/test/ao_lisp_test.c +++ /dev/null @@ -1,134 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include - -static FILE *ao_lisp_file; -static int newline = 1; - -static char save_file[] = "lisp.image"; - -int -ao_lisp_os_save(void) -{ - FILE *save = fopen(save_file, "w"); - - if (!save) { - perror(save_file); - return 0; - } - fwrite(ao_lisp_pool, 1, AO_LISP_POOL_TOTAL, save); - fclose(save); - return 1; -} - -int -ao_lisp_os_restore_save(struct ao_lisp_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_lisp_os_save), 1, restore); - fclose(restore); - if (ret != 1) - return 0; - return 1; -} - -int -ao_lisp_os_restore(void) -{ - FILE *restore = fopen(save_file, "r"); - size_t ret; - - if (!restore) { - perror(save_file); - return 0; - } - ret = fread(ao_lisp_pool, 1, AO_LISP_POOL_TOTAL, restore); - fclose(restore); - if (ret != AO_LISP_POOL_TOTAL) - return 0; - return 1; -} - -int -ao_lisp_getc(void) -{ - int c; - - if (ao_lisp_file) - return getc(ao_lisp_file); - - if (newline) { - printf("> "); - newline = 0; - } - c = getchar(); - if (c == '\n') - newline = 1; - return c; -} - -int -main (int argc, char **argv) -{ - while (*++argv) { - ao_lisp_file = fopen(*argv, "r"); - if (!ao_lisp_file) { - perror(*argv); - exit(1); - } - ao_lisp_read_eval_print(); - fclose(ao_lisp_file); - ao_lisp_file = NULL; - } - ao_lisp_read_eval_print(); - - printf ("collects: full: %d incremental %d\n", - ao_lisp_collects[AO_LISP_COLLECT_FULL], - ao_lisp_collects[AO_LISP_COLLECT_INCREMENTAL]); - - printf ("freed: full %d incremental %d\n", - ao_lisp_freed[AO_LISP_COLLECT_FULL], - ao_lisp_freed[AO_LISP_COLLECT_INCREMENTAL]); - - printf("loops: full %d incremental %d\n", - ao_lisp_loops[AO_LISP_COLLECT_FULL], - ao_lisp_loops[AO_LISP_COLLECT_INCREMENTAL]); - - printf("loops per collect: full %f incremental %f\n", - (double) ao_lisp_loops[AO_LISP_COLLECT_FULL] / - (double) ao_lisp_collects[AO_LISP_COLLECT_FULL], - (double) ao_lisp_loops[AO_LISP_COLLECT_INCREMENTAL] / - (double) ao_lisp_collects[AO_LISP_COLLECT_INCREMENTAL]); - - printf("freed per collect: full %f incremental %f\n", - (double) ao_lisp_freed[AO_LISP_COLLECT_FULL] / - (double) ao_lisp_collects[AO_LISP_COLLECT_FULL], - (double) ao_lisp_freed[AO_LISP_COLLECT_INCREMENTAL] / - (double) ao_lisp_collects[AO_LISP_COLLECT_INCREMENTAL]); - - printf("freed per loop: full %f incremental %f\n", - (double) ao_lisp_freed[AO_LISP_COLLECT_FULL] / - (double) ao_lisp_loops[AO_LISP_COLLECT_FULL], - (double) ao_lisp_freed[AO_LISP_COLLECT_INCREMENTAL] / - (double) ao_lisp_loops[AO_LISP_COLLECT_INCREMENTAL]); -} diff --git a/src/test/ao_scheme_os.h b/src/test/ao_scheme_os.h new file mode 100644 index 00000000..ebd16bb4 --- /dev/null +++ b/src/test/ao_scheme_os.h @@ -0,0 +1,68 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#ifndef _AO_LISP_OS_H_ +#define _AO_LISP_OS_H_ + +#include +#include +#include + +#define AO_LISP_POOL_TOTAL 16384 +#define AO_LISP_SAVE 1 +#define DBG_MEM_STATS 1 + +extern int ao_lisp_getc(void); + +static inline void +ao_lisp_os_flush() { + fflush(stdout); +} + +static inline void +ao_lisp_abort(void) +{ + abort(); +} + +static inline void +ao_lisp_os_led(int led) +{ + printf("leds set to 0x%x\n", led); +} + +#define AO_LISP_JIFFIES_PER_SECOND 100 + +static inline void +ao_lisp_os_delay(int jiffies) +{ + struct timespec ts = { + .tv_sec = jiffies / AO_LISP_JIFFIES_PER_SECOND, + .tv_nsec = (jiffies % AO_LISP_JIFFIES_PER_SECOND) * (1000000000L / AO_LISP_JIFFIES_PER_SECOND) + }; + nanosleep(&ts, NULL); +} + +static inline int +ao_lisp_os_jiffy(void) +{ + struct timespec tp; + clock_gettime(CLOCK_MONOTONIC, &tp); + return tp.tv_sec * AO_LISP_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_LISP_JIFFIES_PER_SECOND)); +} + +#endif diff --git a/src/test/ao_scheme_test.c b/src/test/ao_scheme_test.c new file mode 100644 index 00000000..68e3a202 --- /dev/null +++ b/src/test/ao_scheme_test.c @@ -0,0 +1,134 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_lisp.h" +#include + +static FILE *ao_lisp_file; +static int newline = 1; + +static char save_file[] = "lisp.image"; + +int +ao_lisp_os_save(void) +{ + FILE *save = fopen(save_file, "w"); + + if (!save) { + perror(save_file); + return 0; + } + fwrite(ao_lisp_pool, 1, AO_LISP_POOL_TOTAL, save); + fclose(save); + return 1; +} + +int +ao_lisp_os_restore_save(struct ao_lisp_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_lisp_os_save), 1, restore); + fclose(restore); + if (ret != 1) + return 0; + return 1; +} + +int +ao_lisp_os_restore(void) +{ + FILE *restore = fopen(save_file, "r"); + size_t ret; + + if (!restore) { + perror(save_file); + return 0; + } + ret = fread(ao_lisp_pool, 1, AO_LISP_POOL_TOTAL, restore); + fclose(restore); + if (ret != AO_LISP_POOL_TOTAL) + return 0; + return 1; +} + +int +ao_lisp_getc(void) +{ + int c; + + if (ao_lisp_file) + return getc(ao_lisp_file); + + if (newline) { + printf("> "); + newline = 0; + } + c = getchar(); + if (c == '\n') + newline = 1; + return c; +} + +int +main (int argc, char **argv) +{ + while (*++argv) { + ao_lisp_file = fopen(*argv, "r"); + if (!ao_lisp_file) { + perror(*argv); + exit(1); + } + ao_lisp_read_eval_print(); + fclose(ao_lisp_file); + ao_lisp_file = NULL; + } + ao_lisp_read_eval_print(); + + printf ("collects: full: %d incremental %d\n", + ao_lisp_collects[AO_LISP_COLLECT_FULL], + ao_lisp_collects[AO_LISP_COLLECT_INCREMENTAL]); + + printf ("freed: full %d incremental %d\n", + ao_lisp_freed[AO_LISP_COLLECT_FULL], + ao_lisp_freed[AO_LISP_COLLECT_INCREMENTAL]); + + printf("loops: full %d incremental %d\n", + ao_lisp_loops[AO_LISP_COLLECT_FULL], + ao_lisp_loops[AO_LISP_COLLECT_INCREMENTAL]); + + printf("loops per collect: full %f incremental %f\n", + (double) ao_lisp_loops[AO_LISP_COLLECT_FULL] / + (double) ao_lisp_collects[AO_LISP_COLLECT_FULL], + (double) ao_lisp_loops[AO_LISP_COLLECT_INCREMENTAL] / + (double) ao_lisp_collects[AO_LISP_COLLECT_INCREMENTAL]); + + printf("freed per collect: full %f incremental %f\n", + (double) ao_lisp_freed[AO_LISP_COLLECT_FULL] / + (double) ao_lisp_collects[AO_LISP_COLLECT_FULL], + (double) ao_lisp_freed[AO_LISP_COLLECT_INCREMENTAL] / + (double) ao_lisp_collects[AO_LISP_COLLECT_INCREMENTAL]); + + printf("freed per loop: full %f incremental %f\n", + (double) ao_lisp_freed[AO_LISP_COLLECT_FULL] / + (double) ao_lisp_loops[AO_LISP_COLLECT_FULL], + (double) ao_lisp_freed[AO_LISP_COLLECT_INCREMENTAL] / + (double) ao_lisp_loops[AO_LISP_COLLECT_INCREMENTAL]); +} -- cgit v1.2.3 From bd7a19a86f6d4fe19c7e72904e9b8ac0f2081ff7 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 5 Dec 2017 10:38:14 -0800 Subject: altos/scheme: Move scheme test program to scheme sub-directory Keeps it away from the usual test setup Signed-off-by: Keith Packard --- src/scheme/Makefile | 6 +- src/scheme/test/.gitignore | 1 + src/scheme/test/ao_scheme_os.h | 68 +++++++++++++++ src/scheme/test/ao_scheme_test.c | 139 +++++++++++++++++++++++++++++++ src/scheme/test/hanoi.scheme | 174 +++++++++++++++++++++++++++++++++++++++ src/test/Makefile | 21 +---- src/test/ao_scheme_os.h | 68 --------------- src/test/ao_scheme_test.c | 134 ------------------------------ src/test/hanoi.lisp | 151 --------------------------------- 9 files changed, 391 insertions(+), 371 deletions(-) create mode 100644 src/scheme/test/.gitignore create mode 100644 src/scheme/test/ao_scheme_os.h create mode 100644 src/scheme/test/ao_scheme_test.c create mode 100644 src/scheme/test/hanoi.scheme delete mode 100644 src/test/ao_scheme_os.h delete mode 100644 src/test/ao_scheme_test.c delete mode 100644 src/test/hanoi.lisp diff --git a/src/scheme/Makefile b/src/scheme/Makefile index d8e4b553..e3174be8 100644 --- a/src/scheme/Makefile +++ b/src/scheme/Makefile @@ -1,7 +1,8 @@ -all: ao_scheme_builtin.h ao_scheme_const.h +all: ao_scheme_builtin.h ao_scheme_const.h test/ao_scheme_test clean: +cd make-const && make clean + +cd test && make clean rm -f ao_scheme_const.h ao_scheme_builtin.h ao_scheme_const.h: ao_scheme_const.lisp make-const/ao_scheme_make_const @@ -13,4 +14,7 @@ ao_scheme_builtin.h: ao_scheme_make_builtin ao_scheme_builtin.txt make-const/ao_scheme_make_const: FRC +cd make-const && make ao_scheme_make_const +test/ao_scheme_test: FRC ao_scheme_const.h ao_scheme_builtin.h + +cd test && make ao_scheme_test + FRC: diff --git a/src/scheme/test/.gitignore b/src/scheme/test/.gitignore new file mode 100644 index 00000000..3cdae594 --- /dev/null +++ b/src/scheme/test/.gitignore @@ -0,0 +1 @@ +ao_scheme_test diff --git a/src/scheme/test/ao_scheme_os.h b/src/scheme/test/ao_scheme_os.h new file mode 100644 index 00000000..09a945bc --- /dev/null +++ b/src/scheme/test/ao_scheme_os.h @@ -0,0 +1,68 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#ifndef _AO_SCHEME_OS_H_ +#define _AO_SCHEME_OS_H_ + +#include +#include +#include + +#define AO_SCHEME_POOL_TOTAL 16384 +#define AO_SCHEME_SAVE 1 +#define DBG_MEM_STATS 1 + +extern int ao_scheme_getc(void); + +static inline void +ao_scheme_os_flush() { + fflush(stdout); +} + +static inline void +ao_scheme_abort(void) +{ + abort(); +} + +static inline void +ao_scheme_os_led(int led) +{ + printf("leds set to 0x%x\n", led); +} + +#define AO_SCHEME_JIFFIES_PER_SECOND 100 + +static inline void +ao_scheme_os_delay(int jiffies) +{ + struct timespec ts = { + .tv_sec = jiffies / AO_SCHEME_JIFFIES_PER_SECOND, + .tv_nsec = (jiffies % AO_SCHEME_JIFFIES_PER_SECOND) * (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND) + }; + nanosleep(&ts, NULL); +} + +static inline int +ao_scheme_os_jiffy(void) +{ + struct timespec tp; + clock_gettime(CLOCK_MONOTONIC, &tp); + return tp.tv_sec * AO_SCHEME_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_SCHEME_JIFFIES_PER_SECOND)); +} + +#endif diff --git a/src/scheme/test/ao_scheme_test.c b/src/scheme/test/ao_scheme_test.c new file mode 100644 index 00000000..15c71203 --- /dev/null +++ b/src/scheme/test/ao_scheme_test.c @@ -0,0 +1,139 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include "ao_scheme.h" +#include + +static FILE *ao_scheme_file; +static int newline = 1; + +static char save_file[] = "scheme.image"; + +int +ao_scheme_os_save(void) +{ + FILE *save = fopen(save_file, "w"); + + if (!save) { + perror(save_file); + return 0; + } + fwrite(ao_scheme_pool, 1, AO_SCHEME_POOL_TOTAL, save); + fclose(save); + return 1; +} + +int +ao_scheme_os_restore_save(struct ao_scheme_os_save *save, int offset) +{ + FILE *restore = fopen(save_file, "r"); + size_t ret; + + if (!restore) { + perror(save_file); + return 0; + } + fseek(restore, offset, SEEK_SET); + ret = fread(save, sizeof (struct ao_scheme_os_save), 1, restore); + fclose(restore); + if (ret != 1) + return 0; + return 1; +} + +int +ao_scheme_os_restore(void) +{ + FILE *restore = fopen(save_file, "r"); + size_t ret; + + if (!restore) { + perror(save_file); + return 0; + } + ret = fread(ao_scheme_pool, 1, AO_SCHEME_POOL_TOTAL, restore); + fclose(restore); + if (ret != AO_SCHEME_POOL_TOTAL) + return 0; + return 1; +} + +int +ao_scheme_getc(void) +{ + int c; + + if (ao_scheme_file) + return getc(ao_scheme_file); + + if (newline) { + if (ao_scheme_read_stack) + 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(); + + printf ("collects: full: %d incremental %d\n", + ao_scheme_collects[AO_SCHEME_COLLECT_FULL], + ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]); + + printf ("freed: full %d incremental %d\n", + ao_scheme_freed[AO_SCHEME_COLLECT_FULL], + ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL]); + + printf("loops: full %d incremental %d\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]); +} diff --git a/src/scheme/test/hanoi.scheme b/src/scheme/test/hanoi.scheme new file mode 100644 index 00000000..c4ae7378 --- /dev/null +++ b/src/scheme/test/hanoi.scheme @@ -0,0 +1,174 @@ +; +; Towers of Hanoi +; +; Copyright © 2016 Keith Packard +; +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation, either version 2 of the License, or +; (at your option) any later version. +; +; This program is distributed in the hope that it will be useful, but +; WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +; General Public License for more details. +; + + ; 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/test/Makefile b/src/test/Makefile index 4ac2c893..7bd13db9 100644 --- a/src/test/Makefile +++ b/src/test/Makefile @@ -1,13 +1,13 @@ vpath %.o . -vpath %.c ..:../kernel:../drivers:../util:../micropeak:../aes:../product:../lisp -vpath %.h ..:../kernel:../drivers:../util:../micropeak:../aes:../product:../lisp -vpath make-kalman ..:../kernel:../drivers:../util:../micropeak:../aes:../product:../lisp +vpath %.c ..:../kernel:../drivers:../util:../micropeak:../aes:../product +vpath %.h ..:../kernel:../drivers:../util:../micropeak:../aes:../product +vpath make-kalman ..:../kernel:../drivers:../util:../micropeak:../aes:../product PROGS=ao_flight_test ao_flight_test_baro ao_flight_test_accel ao_flight_test_noisy_accel ao_flight_test_mm \ ao_flight_test_metrum ao_flight_test_mini \ ao_gps_test ao_gps_test_skytraq ao_gps_test_ublox ao_convert_test ao_convert_pa_test ao_fec_test \ ao_aprs_test ao_micropeak_test ao_fat_test ao_aes_test ao_int64_test \ - ao_ms5607_convert_test ao_quaternion_test ao_lisp_test + ao_ms5607_convert_test ao_quaternion_test INCS=ao_kalman.h ao_ms5607.h ao_log.h ao_data.h altitude-pa.h altitude.h ao_quaternion.h ao_eeprom_read.h TEST_SRC=ao_flight_test.c @@ -97,16 +97,3 @@ ao_ms5607_convert_test: ao_ms5607_convert_test.c ao_ms5607_convert_8051.c ao_int ao_quaternion_test: ao_quaternion_test.c ao_quaternion.h cc $(CFLAGS) -o $@ ao_quaternion_test.c -lm -include ../lisp/Makefile-inc - -AO_LISP_SRCS=$(LISP_SRCS) ao_lisp_test.c - -AO_LISP_OBJS=$(AO_LISP_SRCS:.c=.o) - -ao_lisp_test: $(AO_LISP_OBJS) - cc $(CFLAGS) -o $@ $(AO_LISP_OBJS) -lm - -$(AO_LISP_OBJS): $(LISP_HDRS) ao_lisp_const.h - -clean:: - rm -f $(AO_LISP_OBJS) diff --git a/src/test/ao_scheme_os.h b/src/test/ao_scheme_os.h deleted file mode 100644 index ebd16bb4..00000000 --- a/src/test/ao_scheme_os.h +++ /dev/null @@ -1,68 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. - */ - -#ifndef _AO_LISP_OS_H_ -#define _AO_LISP_OS_H_ - -#include -#include -#include - -#define AO_LISP_POOL_TOTAL 16384 -#define AO_LISP_SAVE 1 -#define DBG_MEM_STATS 1 - -extern int ao_lisp_getc(void); - -static inline void -ao_lisp_os_flush() { - fflush(stdout); -} - -static inline void -ao_lisp_abort(void) -{ - abort(); -} - -static inline void -ao_lisp_os_led(int led) -{ - printf("leds set to 0x%x\n", led); -} - -#define AO_LISP_JIFFIES_PER_SECOND 100 - -static inline void -ao_lisp_os_delay(int jiffies) -{ - struct timespec ts = { - .tv_sec = jiffies / AO_LISP_JIFFIES_PER_SECOND, - .tv_nsec = (jiffies % AO_LISP_JIFFIES_PER_SECOND) * (1000000000L / AO_LISP_JIFFIES_PER_SECOND) - }; - nanosleep(&ts, NULL); -} - -static inline int -ao_lisp_os_jiffy(void) -{ - struct timespec tp; - clock_gettime(CLOCK_MONOTONIC, &tp); - return tp.tv_sec * AO_LISP_JIFFIES_PER_SECOND + (tp.tv_nsec / (1000000000L / AO_LISP_JIFFIES_PER_SECOND)); -} - -#endif diff --git a/src/test/ao_scheme_test.c b/src/test/ao_scheme_test.c deleted file mode 100644 index 68e3a202..00000000 --- a/src/test/ao_scheme_test.c +++ /dev/null @@ -1,134 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include "ao_lisp.h" -#include - -static FILE *ao_lisp_file; -static int newline = 1; - -static char save_file[] = "lisp.image"; - -int -ao_lisp_os_save(void) -{ - FILE *save = fopen(save_file, "w"); - - if (!save) { - perror(save_file); - return 0; - } - fwrite(ao_lisp_pool, 1, AO_LISP_POOL_TOTAL, save); - fclose(save); - return 1; -} - -int -ao_lisp_os_restore_save(struct ao_lisp_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_lisp_os_save), 1, restore); - fclose(restore); - if (ret != 1) - return 0; - return 1; -} - -int -ao_lisp_os_restore(void) -{ - FILE *restore = fopen(save_file, "r"); - size_t ret; - - if (!restore) { - perror(save_file); - return 0; - } - ret = fread(ao_lisp_pool, 1, AO_LISP_POOL_TOTAL, restore); - fclose(restore); - if (ret != AO_LISP_POOL_TOTAL) - return 0; - return 1; -} - -int -ao_lisp_getc(void) -{ - int c; - - if (ao_lisp_file) - return getc(ao_lisp_file); - - if (newline) { - printf("> "); - newline = 0; - } - c = getchar(); - if (c == '\n') - newline = 1; - return c; -} - -int -main (int argc, char **argv) -{ - while (*++argv) { - ao_lisp_file = fopen(*argv, "r"); - if (!ao_lisp_file) { - perror(*argv); - exit(1); - } - ao_lisp_read_eval_print(); - fclose(ao_lisp_file); - ao_lisp_file = NULL; - } - ao_lisp_read_eval_print(); - - printf ("collects: full: %d incremental %d\n", - ao_lisp_collects[AO_LISP_COLLECT_FULL], - ao_lisp_collects[AO_LISP_COLLECT_INCREMENTAL]); - - printf ("freed: full %d incremental %d\n", - ao_lisp_freed[AO_LISP_COLLECT_FULL], - ao_lisp_freed[AO_LISP_COLLECT_INCREMENTAL]); - - printf("loops: full %d incremental %d\n", - ao_lisp_loops[AO_LISP_COLLECT_FULL], - ao_lisp_loops[AO_LISP_COLLECT_INCREMENTAL]); - - printf("loops per collect: full %f incremental %f\n", - (double) ao_lisp_loops[AO_LISP_COLLECT_FULL] / - (double) ao_lisp_collects[AO_LISP_COLLECT_FULL], - (double) ao_lisp_loops[AO_LISP_COLLECT_INCREMENTAL] / - (double) ao_lisp_collects[AO_LISP_COLLECT_INCREMENTAL]); - - printf("freed per collect: full %f incremental %f\n", - (double) ao_lisp_freed[AO_LISP_COLLECT_FULL] / - (double) ao_lisp_collects[AO_LISP_COLLECT_FULL], - (double) ao_lisp_freed[AO_LISP_COLLECT_INCREMENTAL] / - (double) ao_lisp_collects[AO_LISP_COLLECT_INCREMENTAL]); - - printf("freed per loop: full %f incremental %f\n", - (double) ao_lisp_freed[AO_LISP_COLLECT_FULL] / - (double) ao_lisp_loops[AO_LISP_COLLECT_FULL], - (double) ao_lisp_freed[AO_LISP_COLLECT_INCREMENTAL] / - (double) ao_lisp_loops[AO_LISP_COLLECT_INCREMENTAL]); -} diff --git a/src/test/hanoi.lisp b/src/test/hanoi.lisp deleted file mode 100644 index 4afde883..00000000 --- a/src/test/hanoi.lisp +++ /dev/null @@ -1,151 +0,0 @@ -; -; Towers of Hanoi -; -; Copyright © 2016 Keith Packard -; -; This program is free software; you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation, either version 2 of the License, or -; (at your option) any later version. -; -; This program is distributed in the hope that it will be useful, but -; WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -; General Public License for more details. -; - - ; 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) - ) - - ; Here's the pieces to display - -(define tower '(" * " " *** " " ***** " " ******* " " ********* " "***********")) - - ; Here's all of the towers of pieces - ; This is generated when the program is run - -(define towers ()) - -(define (one- x) (- x 1)) -(define (one+ x) (+ x 1)) - ; 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 (one+ y) 0 (cdr tower)) - ) - ) - ) - (else - (display-string x y " ") - (display-tower x (one+ y) (one- clear) tower) - ) - ) - ) - - ; Position of the top of the tower on the screen - ; Shorter towers start further down the screen - -(define (tower-pos y tower) - (- y (length tower)) - ) - - ; Display all of the towers, spaced 20 columns apart - -(define (display-towers x y towers) - (cond ((not (null? towers)) - (display-tower x 0 (tower-pos y (car towers)) (car towers)) - (display-towers (+ x 20) y (cdr towers))) - ) - ) - -(define top 0) - ; Display all of the towers, then move the cursor - ; out of the way and flush the output - -(define (display-hanoi) - (display-towers 0 top towers) - (move-to 1 21) - (flush-output) - ) - - ; Reset towers to the starting state, with - ; all of the pieces in the first tower and the - ; other two empty - -(define (reset-towers) - (set! towers (list tower () ())) - (set! top (+ (length tower) 3)) - (length tower) - ) - - ; Replace a tower in the list of towers - ; with a new value - -(define (replace list pos member) - (cond ((= pos 0) (cons member (cdr list))) - (else (cons (car list) (replace (cdr list) (one- pos) member))) - ) - ) - - ; Move a piece from the top of one tower - ; to the top of another - -(define move-delay 10) - -(define (move-piece from to) - (let* ((from-tower (list-ref towers from)) - (to-tower (list-ref towers to)) - (piece (car from-tower))) - (set! from-tower (cdr from-tower)) - (set! to-tower (cons piece to-tower)) - (set! towers (replace towers from from-tower)) - (set! towers (replace towers to to-tower)) - (display-hanoi) - (delay move-delay) - ) - ) - -; The implementation of the game - -(define (_hanoi n from to use) - (cond ((= 1 n) - (move-piece from to) - ) - (else - (_hanoi (one- n) from use to) - (_hanoi 1 from to use) - (_hanoi (one- n) use to from) - ) - ) - ) - - ; A pretty interface which - ; resets the state of the game, - ; clears the screen and runs - ; the program - -(define (hanoi) - (let ((len (reset-towers))) - (clear) - (_hanoi len 0 1 2) - (move-to 0 23) - #t - ) - ) - ) -- cgit v1.2.3 From 038581bd212e66bcf017c7ace28c80a3ae0d0f50 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 5 Dec 2017 10:42:02 -0800 Subject: altos/scheme: Add explicit dependency on ao_scheme_builtin.h for ao_scheme_make_const This ensures that a parallel build will wait for ao_scheme_builtin.h to be complete before attempting to compile ao_scheme_make_const Signed-off-by: Keith Packard --- src/scheme/Makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/scheme/Makefile b/src/scheme/Makefile index e3174be8..ea94c1c0 100644 --- a/src/scheme/Makefile +++ b/src/scheme/Makefile @@ -11,7 +11,7 @@ ao_scheme_const.h: ao_scheme_const.lisp make-const/ao_scheme_make_const 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 +make-const/ao_scheme_make_const: FRC ao_scheme_builtin.h +cd make-const && make ao_scheme_make_const test/ao_scheme_test: FRC ao_scheme_const.h ao_scheme_builtin.h -- cgit v1.2.3 From 2aa02234b1ac2b1701b44fcec9e9bd82bea526b7 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 5 Dec 2017 10:48:04 -0800 Subject: altos/cortexelf-v1: Adapt to lisp->scheme name change Signed-off-by: Keith Packard --- src/cortexelf-v1/.gitignore | 3 ++ src/cortexelf-v1/Makefile | 44 ++++++++------------ src/cortexelf-v1/ao_cortexelf.c | 8 ++-- src/cortexelf-v1/ao_lisp_os.h | 79 ------------------------------------ src/cortexelf-v1/ao_lisp_os_save.c | 53 ------------------------ src/cortexelf-v1/ao_scheme_os.h | 79 ++++++++++++++++++++++++++++++++++++ src/cortexelf-v1/ao_scheme_os_save.c | 53 ++++++++++++++++++++++++ src/scheme/Makefile-scheme | 6 +-- src/stm/Makefile.defs | 2 +- 9 files changed, 161 insertions(+), 166 deletions(-) create mode 100644 src/cortexelf-v1/.gitignore delete mode 100644 src/cortexelf-v1/ao_lisp_os.h delete mode 100644 src/cortexelf-v1/ao_lisp_os_save.c create mode 100644 src/cortexelf-v1/ao_scheme_os.h create mode 100644 src/cortexelf-v1/ao_scheme_os_save.c diff --git a/src/cortexelf-v1/.gitignore b/src/cortexelf-v1/.gitignore new file mode 100644 index 00000000..0189131b --- /dev/null +++ b/src/cortexelf-v1/.gitignore @@ -0,0 +1,3 @@ +cortexelf-v1*.elf +cortexelf-v1*.hex +ao_product.h diff --git a/src/cortexelf-v1/Makefile b/src/cortexelf-v1/Makefile index be225e57..12c658dc 100644 --- a/src/cortexelf-v1/Makefile +++ b/src/cortexelf-v1/Makefile @@ -4,7 +4,8 @@ # include ../stm/Makefile.defs -LDFLAGS=-L../stm -Wl,-Tcortexelf.ld +include ../scheme/Makefile-inc + INC = \ ao.h \ @@ -19,15 +20,12 @@ INC = \ math.h \ ao_mpu.h \ stm32l.h \ - math.h \ ao_vga.h \ ao_draw.h \ ao_draw_int.h \ ao_font.h \ ao_ps2.h \ - ao_lisp.h \ - ao_lisp_const.h \ - ao_lisp_os.h \ + $(SCHEME_HDRS) \ ao_flip_bits.h \ Makefile @@ -46,6 +44,7 @@ ALTOS_SRC = \ ao_cmd.c \ ao_config.c \ ao_task.c \ + ao_errno.c \ ao_stdio.c \ ao_panic.c \ ao_timer.c \ @@ -74,24 +73,8 @@ ALTOS_SRC = \ ao_event.c \ ao_1802.c \ ao_hex.c \ - ao_lisp_lex.c \ - ao_lisp_mem.c \ - ao_lisp_cons.c \ - ao_lisp_eval.c \ - ao_lisp_string.c \ - ao_lisp_atom.c \ - ao_lisp_int.c \ - ao_lisp_poly.c \ - ao_lisp_bool.c \ - ao_lisp_builtin.c \ - ao_lisp_read.c \ - ao_lisp_rep.c \ - ao_lisp_frame.c \ - ao_lisp_error.c \ - ao_lisp_lambda.c \ - ao_lisp_save.c \ - ao_lisp_stack.c \ - ao_lisp_os_save.c \ + $(SCHEME_SRCS) \ + ao_scheme_os_save.c \ $(PROFILE) \ $(SAMPLE_PROFILE) \ $(STACK_GUARD) @@ -100,12 +83,21 @@ PRODUCT=CortexELF-v1 PRODUCT_DEF=-DCORTEXELF IDPRODUCT=0x000a -CFLAGS = $(PRODUCT_DEF) $(STM_CFLAGS) $(PROFILE_DEF) $(SAMPLE_PROFILE_DEF) $(STACK_GUARD_DEF) -Os -g - PROGNAME=cortexelf-v1 PROG=$(PROGNAME)-$(VERSION).elf HEX=$(PROGNAME)-$(VERSION).ihx +MAP=$(PROG).map + +MAPFILE=-Wl,-M=$(MAP) + +LDFLAGS=-L../stm -L/local/newlib-mini/arm-none-eabi/lib/thumb/v7-m/ -Wl,-Tcortexelf.ld $(MAPFILE) -nostartfiles +AO_CFLAGS=-I. -I../stm -I../kernel -I../drivers -I../draw -I../scheme -I.. -I/local/newlib-mini/arm-none-eabi/include +LIBS=-lc -lm -lgcc + +CFLAGS = $(PRODUCT_DEF) $(STM_CFLAGS) $(PROFILE_DEF) $(SAMPLE_PROFILE_DEF) $(STACK_GUARD_DEF) -Os -g + + SRC=$(ALTOS_SRC) ao_cortexelf.c OBJ=$(SRC:.c=.o) @@ -131,7 +123,7 @@ clean:: ao_flip_bits.h: ao_flip_bits.5c nickle ao_flip_bits.5c > $@ -include ../lisp/Makefile-lisp +include ../scheme/Makefile-scheme install: diff --git a/src/cortexelf-v1/ao_cortexelf.c b/src/cortexelf-v1/ao_cortexelf.c index 61a9d219..5ed78bf0 100644 --- a/src/cortexelf-v1/ao_cortexelf.c +++ b/src/cortexelf-v1/ao_cortexelf.c @@ -27,7 +27,7 @@ #include #include #include -#include +#include #include #include #include @@ -188,8 +188,8 @@ ao_console_send(void) } } -static void lisp_cmd() { - ao_lisp_read_eval_print(); +static void scheme_cmd() { + ao_scheme_read_eval_print(); } static void @@ -224,7 +224,7 @@ __code struct ao_cmds ao_demo_cmds[] = { { ao_ps2_read_keys, "K\0Read keys from keyboard" }, { ao_console_send, "C\0Send data to console, end with ~" }, { ao_serial_blather, "S\0Blather on serial ports briefly" }, - { lisp_cmd, "l\0Run lisp interpreter" }, + { scheme_cmd, "l\0Run scheme interpreter" }, { led_cmd, "L start value\0Show value (byte) at digit start" }, { 0, NULL } }; diff --git a/src/cortexelf-v1/ao_lisp_os.h b/src/cortexelf-v1/ao_lisp_os.h deleted file mode 100644 index 27ea7806..00000000 --- a/src/cortexelf-v1/ao_lisp_os.h +++ /dev/null @@ -1,79 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. - */ - -#ifndef _AO_LISP_OS_H_ -#define _AO_LISP_OS_H_ - -#include "ao.h" - -#define AO_LISP_POOL_TOTAL 16384 -#define AO_LISP_SAVE 1 - -#ifndef __BYTE_ORDER -#define __LITTLE_ENDIAN 1234 -#define __BIG_ENDIAN 4321 -#define __BYTE_ORDER __LITTLE_ENDIAN -#endif - -static inline int -ao_lisp_getc() { - static uint8_t at_eol; - int c; - - if (at_eol) { - ao_cmd_readline(); - at_eol = 0; - } - c = ao_cmd_lex(); - if (c == '\n') - at_eol = 1; - return c; -} - -static inline void -ao_lisp_os_flush(void) -{ - flush(); -} - -static inline void -ao_lisp_abort(void) -{ - ao_panic(1); -} - -static inline void -ao_lisp_os_led(int led) -{ - (void) led; -} - -#define AO_LISP_JIFFIES_PER_SECOND AO_HERTZ - -static inline void -ao_lisp_os_delay(int delay) -{ - ao_delay(delay); -} - -static inline int -ao_lisp_os_jiffy(void) -{ - return ao_tick_count; -} - -#endif diff --git a/src/cortexelf-v1/ao_lisp_os_save.c b/src/cortexelf-v1/ao_lisp_os_save.c deleted file mode 100644 index 7c853990..00000000 --- a/src/cortexelf-v1/ao_lisp_os_save.c +++ /dev/null @@ -1,53 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include -#include -#include - -extern uint8_t __flash__[]; - -/* saved variables to rebuild the heap - - ao_lisp_atoms - ao_lisp_frame_global - */ - -int -ao_lisp_os_save(void) -{ - int i; - - for (i = 0; i < AO_LISP_POOL_TOTAL; i += 256) { - uint32_t *dst = (uint32_t *) (void *) &__flash__[i]; - uint32_t *src = (uint32_t *) (void *) &ao_lisp_pool[i]; - - ao_flash_page(dst, src); - } - return 1; -} - -int -ao_lisp_os_restore_save(struct ao_lisp_os_save *save, int offset) -{ - memcpy(save, &__flash__[offset], sizeof (struct ao_lisp_os_save)); - return 1; -} - -int -ao_lisp_os_restore(void) -{ - memcpy(ao_lisp_pool, __flash__, AO_LISP_POOL_TOTAL); - return 1; -} diff --git a/src/cortexelf-v1/ao_scheme_os.h b/src/cortexelf-v1/ao_scheme_os.h new file mode 100644 index 00000000..58e4f5b3 --- /dev/null +++ b/src/cortexelf-v1/ao_scheme_os.h @@ -0,0 +1,79 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#ifndef _AO_SCHEME_OS_H_ +#define _AO_SCHEME_OS_H_ + +#include "ao.h" + +#define AO_SCHEME_POOL_TOTAL 16384 +#define AO_SCHEME_SAVE 1 + +#ifndef __BYTE_ORDER +#define __LITTLE_ENDIAN 1234 +#define __BIG_ENDIAN 4321 +#define __BYTE_ORDER __LITTLE_ENDIAN +#endif + +static inline int +ao_scheme_getc() { + static uint8_t at_eol; + int c; + + if (at_eol) { + ao_cmd_readline(); + at_eol = 0; + } + c = ao_cmd_lex(); + if (c == '\n') + at_eol = 1; + return c; +} + +static inline void +ao_scheme_os_flush(void) +{ + flush(); +} + +static inline void +ao_scheme_abort(void) +{ + ao_panic(1); +} + +static inline void +ao_scheme_os_led(int led) +{ + (void) led; +} + +#define AO_SCHEME_JIFFIES_PER_SECOND AO_HERTZ + +static inline void +ao_scheme_os_delay(int delay) +{ + ao_delay(delay); +} + +static inline int +ao_scheme_os_jiffy(void) +{ + return ao_tick_count; +} + +#endif diff --git a/src/cortexelf-v1/ao_scheme_os_save.c b/src/cortexelf-v1/ao_scheme_os_save.c new file mode 100644 index 00000000..4cec79c6 --- /dev/null +++ b/src/cortexelf-v1/ao_scheme_os_save.c @@ -0,0 +1,53 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include +#include +#include + +extern uint8_t __flash__[]; + +/* saved variables to rebuild the heap + + ao_scheme_atoms + ao_scheme_frame_global + */ + +int +ao_scheme_os_save(void) +{ + int i; + + for (i = 0; i < AO_SCHEME_POOL_TOTAL; i += 256) { + uint32_t *dst = (uint32_t *) (void *) &__flash__[i]; + uint32_t *src = (uint32_t *) (void *) &ao_scheme_pool[i]; + + ao_flash_page(dst, src); + } + return 1; +} + +int +ao_scheme_os_restore_save(struct ao_scheme_os_save *save, int offset) +{ + memcpy(save, &__flash__[offset], sizeof (struct ao_scheme_os_save)); + return 1; +} + +int +ao_scheme_os_restore(void) +{ + memcpy(ao_scheme_pool, __flash__, AO_SCHEME_POOL_TOTAL); + return 1; +} diff --git a/src/scheme/Makefile-scheme b/src/scheme/Makefile-scheme index 2427cffa..b9018e19 100644 --- a/src/scheme/Makefile-scheme +++ b/src/scheme/Makefile-scheme @@ -1,4 +1,4 @@ -include ../lisp/Makefile-inc +include ../scheme/Makefile-inc -ao_scheme_const.h: $(LISP_SRCS) $(LISP_HDRS) - +cd ../lisp && make $@ +ao_scheme_const.h: $(SCHEME_SRCS) $(SCHEME_HDRS) + +cd ../scheme && make $@ diff --git a/src/stm/Makefile.defs b/src/stm/Makefile.defs index 66ed4be8..4d0d27c7 100644 --- a/src/stm/Makefile.defs +++ b/src/stm/Makefile.defs @@ -1,4 +1,4 @@ -vpath % ../stm:../product:../drivers:../kernel:../util:../kalman:../aes:../math:../draw:../lisp:.. +vpath % ../stm:../product:../drivers:../kernel:../util:../kalman:../aes:../math:../draw:../scheme:.. vpath make-altitude ../util vpath make-kalman ../util vpath kalman.5c ../kalman -- cgit v1.2.3 From 1bf219209c8d9e31a9c3726dad169ff5d17ed4b2 Mon Sep 17 00:00:00 2001 From: Bdale Garbee Date: Tue, 5 Dec 2017 13:17:18 -0700 Subject: handle repeated invocations without failing as often --- ao-bringup/turnon_telemega | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ao-bringup/turnon_telemega b/ao-bringup/turnon_telemega index e2b539e1..d7ccc570 100755 --- a/ao-bringup/turnon_telemega +++ b/ao-bringup/turnon_telemega @@ -44,11 +44,11 @@ esac echo $FLASH_STM -$FLASH_STM $REPO/loaders/telemega-v$VERSION*.elf || exit 1 +$FLASH_STM $REPO/loaders/telemega-v$VERSION*.elf sleep 5 -$USBLOAD --serial=$SERIAL $REPO/telemega-v$VERSION*.elf || exit 1 +$USBLOAD --serial=$SERIAL --force $REPO/telemega-v$VERSION*.elf || exit 1 sleep 5 -- cgit v1.2.3 From d314a5654fafa5eac86d8293f1197a2f2c2eac72 Mon Sep 17 00:00:00 2001 From: Bdale Garbee Date: Tue, 5 Dec 2017 13:18:45 -0700 Subject: moving to TeleMega v3.0 by default --- ao-bringup/turnon_telemega_v2.0 | 81 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 81 insertions(+) create mode 100755 ao-bringup/turnon_telemega_v2.0 diff --git a/ao-bringup/turnon_telemega_v2.0 b/ao-bringup/turnon_telemega_v2.0 new file mode 100755 index 00000000..d7ccc570 --- /dev/null +++ b/ao-bringup/turnon_telemega_v2.0 @@ -0,0 +1,81 @@ +#!/bin/sh + +if [ -x /usr/bin/ao-flash-stm ]; then + FLASH_STM=/usr/bin/ao-flash-stm +else + echo "Can't find ao-flash-stm! Aborting." + exit 1 +fi + +if [ -x /usr/bin/ao-usbload ]; then + USBLOAD=/usr/bin/ao-usbload +else + echo "Can't find ao-usbload! Aborting." + exit 1 +fi + +VERSION=2.0 +REPO=~/altusmetrumllc/Binaries +PRODUCT=TeleMega + +echo "$PRODUCT v$VERSION Turn-On and Calibration Program" +echo "Copyright 2014 by Bdale Garbee. Released under GPL v2" +echo +echo "Expectations:" +echo "\t$PRODUCT v$VERSION powered from USB" +echo "\t\twith ST-Link-V2 cabled to debug header" +echo "\t\twith coax from UHF to frequency counter" +echo + +case $# in + 1) + SERIAL="$1" + echo "$PRODUCT-$VERSION serial number: $SERIAL" + ;; + 0) + echo -n "$PRODUCT-$VERSION serial number: " + read SERIAL + ;; + *) + echo "Usage: $0 " 1>&2 + exit 1; + ;; +esac + +echo $FLASH_STM + +$FLASH_STM $REPO/loaders/telemega-v$VERSION*.elf + +sleep 5 + +$USBLOAD --serial=$SERIAL --force $REPO/telemega-v$VERSION*.elf || exit 1 + +sleep 5 + +dev=`ao-list | awk '/TeleMega-v'"$VERSION"'/ { print $3; exit(0); }'` + +case "$dev" in +/dev/tty*) + echo "TeleMega found on $dev" + ;; +*) + echo 'No TeleMega-v'"$VERSION"' found' + exit 1 + ;; +esac + +echo 'E 0' > $dev + +SERIAL=$SERIAL ./cal-freq $dev + +failed=1 +while [ $failed = 1 ]; do + ../ao-tools/ao-cal-accel/ao-cal-accel $dev + failed=$? +done + +echo 'E 1' > $dev + +./test-telemega + +exit $? -- cgit v1.2.3 From 185b11367cd85948885fceafb5d46303b6f1356d Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 5 Dec 2017 12:22:34 -0800 Subject: altos/drivers: Start adding defines to get mag data out of MPU9250 Signed-off-by: Keith Packard --- src/drivers/ao_mpu9250.h | 71 ++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 60 insertions(+), 11 deletions(-) diff --git a/src/drivers/ao_mpu9250.h b/src/drivers/ao_mpu9250.h index a124d799..df1be7c7 100644 --- a/src/drivers/ao_mpu9250.h +++ b/src/drivers/ao_mpu9250.h @@ -102,21 +102,67 @@ # define MPU9250_ACCEL_CONFIG_AFS_SEL_16G 3 # define MPU9250_ACCEL_CONFIG_AFS_SEL_MASK 3 +#define MPU9250_MST_CTRL 0x24 +#define MPU9250_MST_CTRL_MULT_MST_EN 7 +#define MPU9250_MST_CTRL_WAIT_FOR_ES 6 +#define MPU9250_MST_CTRL_SLV_3_FIFO_EN 5 +#define MPU9250_MST_CTRL_I2C_MST_P_NSR 4 +#define MPU9250_MST_CTRL_I2C_MST_CLK 0 +#define MPU9250_MST_CTRL_I2C_MST_CLK_348 0 +#define MPU9250_MST_CTRL_I2C_MST_CLK_333 1 +#define MPU9250_MST_CTRL_I2C_MST_CLK_320 2 +#define MPU9250_MST_CTRL_I2C_MST_CLK_308 3 +#define MPU9250_MST_CTRL_I2C_MST_CLK_296 4 +#define MPU9250_MST_CTRL_I2C_MST_CLK_286 5 +#define MPU9250_MST_CTRL_I2C_MST_CLK_276 6 +#define MPU9250_MST_CTRL_I2C_MST_CLK_267 7 +#define MPU9250_MST_CTRL_I2C_MST_CLK_258 8 +#define MPU9250_MST_CTRL_I2C_MST_CLK_500 9 +#define MPU9250_MST_CTRL_I2C_MST_CLK_471 10 +#define MPU9250_MST_CTRL_I2C_MST_CLK_444 11 +#define MPU9250_MST_CTRL_I2C_MST_CLK_421 12 +#define MPU9250_MST_CTRL_I2C_MST_CLK_400 13 +#define MPU9250_MST_CTRL_I2C_MST_CLK_381 14 +#define MPU9250_MST_CTRL_I2C_MST_CLK_364 15 +#define MPU9250_MST_CTRL_I2C_MST_CLK_MASK 15 + +#define MPU9250_I2C_SLV0_ADDR 0x25 +#define MPU9250_I2C_SLV0_REG 0x26 +#define MPU9250_I2C_SLV0_CTRL 0x27 + +#define MPU9250_I2C_SLV1_ADDR 0x28 +#define MPU9250_I2C_SLV1_REG 0x29 +#define MPU9250_I2C_SLV1_CTRL 0x2a + +#define MPU9250_I2C_SLV2_ADDR 0x2b +#define MPU9250_I2C_SLV2_REG 0x2c +#define MPU9250_I2C_SLV2_CTRL 0x2d + +#define MPU9250_I2C_SLV3_ADDR 0x2e +#define MPU9250_I2C_SLV3_REG 0x2f +#define MPU9250_I2C_SLV3_CTRL 0x30 + +#define MPU9250_I2C_SLV4_ADDR 0x31 +#define MPU9250_I2C_SLV4_REG 0x32 +#define MPU9250_I2C_SLV4_DO 0x33 +#define MPU9250_I2C_SLV4_CTRL 0x34 +#define MPU9250_I2C_SLV4_DI 0x35 + +#define MPU9250_I2C_MST_STATUS 0x36 + +#define MPU9250_INT_PIN_CFG 0x37 + #define MPU9250_INT_ENABLE 0x38 -#define MPU9250_INT_ENABLE_FF_EN 7 -#define MPU9250_INT_ENABLE_MOT_EN 6 -#define MPU9250_INT_ENABLE_ZMOT_EN 5 +#define MPU9250_INT_ENABLE_WOM_EN 6 #define MPU9250_INT_ENABLE_FIFO_OFLOW_EN 4 -#define MPU9250_INT_ENABLE_I2C_MST_INT_EN 3 -#define MPU9250_INT_ENABLE_DATA_RDY_EN 0 +#define MPU9250_INT_ENABLE_FSYNC_INT_EN 3 +#define MPU9250_INT_ENABLE_RAW_RDY_EN 0 #define MPU9250_INT_STATUS 0x3a -#define MPU9250_INT_STATUS_FF_EN 7 -#define MPU9250_INT_STATUS_MOT_EN 6 -#define MPU9250_INT_STATUS_ZMOT_EN 5 -#define MPU9250_INT_STATUS_FIFO_OFLOW_EN 4 -#define MPU9250_INT_STATUS_I2C_MST_INT_EN 3 -#define MPU9250_INT_STATUS_DATA_RDY_EN 0 +#define MPU9250_INT_STATUS_WOM_INT 6 +#define MPU9250_INT_STATUS_FIFO_OFLOW_INT 4 +#define MPU9250_INT_STATUS_FSYNC_INT 3 +#define MPU9250_INT_STATUS_RAW_RDY_INT 0 #define MPU9250_ACCEL_XOUT_H 0x3b #define MPU9250_ACCEL_XOUT_L 0x3c @@ -194,6 +240,9 @@ struct ao_mpu9250_sample { int16_t gyro_x; int16_t gyro_y; int16_t gyro_z; + int16_t mag_x; + int16_t mag_y; + int16_t mag_z; }; extern struct ao_mpu9250_sample ao_mpu9250_current; -- cgit v1.2.3 From 1133130986a78628ea297ce1f6a023baf4382d8f Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 9 Dec 2017 16:56:20 -0800 Subject: altos/scheme: Let readline know if there's a list in progress This lets the interactive prompt change based on what state the lexer is in Signed-off-by: Keith Packard --- src/scheme/ao_scheme.h | 6 +- src/scheme/ao_scheme_builtin.c | 2 +- src/scheme/ao_scheme_const.scheme | 813 ++++++++++++++++++++++++++++++++++++++ src/scheme/ao_scheme_float.c | 6 +- src/scheme/ao_scheme_read.c | 40 +- src/scheme/test/ao_scheme_test.c | 2 +- 6 files changed, 845 insertions(+), 24 deletions(-) create mode 100644 src/scheme/ao_scheme_const.scheme diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index 4589f8a5..10518716 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -31,7 +31,7 @@ typedef uint16_t ao_poly; typedef int16_t ao_signed_poly; -#ifdef AO_SCHEME_SAVE +#if AO_SCHEME_SAVE struct ao_scheme_os_save { ao_poly atoms; @@ -77,6 +77,9 @@ extern uint8_t ao_scheme_const[AO_SCHEME_POOL_CONST] __attribute__((aligned(4))) #ifndef AO_SCHEME_POOL #define AO_SCHEME_POOL 3072 #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 @@ -745,6 +748,7 @@ 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; diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index 49f218f6..aa818646 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -636,7 +636,7 @@ ao_scheme_do_collect(struct ao_scheme_cons *cons) int free; (void) cons; free = ao_scheme_collect(AO_SCHEME_COLLECT_FULL); - return ao_scheme_int_poly(free); + return ao_scheme_integer_poly(free); } ao_poly diff --git a/src/scheme/ao_scheme_const.scheme b/src/scheme/ao_scheme_const.scheme new file mode 100644 index 00000000..422bdd63 --- /dev/null +++ b/src/scheme/ao_scheme_const.scheme @@ -0,0 +1,813 @@ +; +; Copyright © 2016 Keith Packard +; +; This program is free software; you can redistribute it and/or modify +; it under the terms of the GNU General Public License as published by +; the Free Software Foundation, either version 2 of the License, or +; (at your option) any later version. +; +; This program is distributed in the hope that it will be useful, but +; WITHOUT ANY WARRANTY; without even the implied warranty of +; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +; General Public License for more details. +; +; Lisp code placed in ROM + + ; return a list containing all of the arguments +(def (quote list) (lambda l l)) + +(def (quote def!) + (macro (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 ((list? 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 ) + ; (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 c) c) +(define (integer->char c) 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")) + +;(define number->string (lambda (arg . opt) +; (let ((base (if (null? opt) 10 (car opt))) + ; +; + diff --git a/src/scheme/ao_scheme_float.c b/src/scheme/ao_scheme_float.c index 541f0264..99249030 100644 --- a/src/scheme/ao_scheme_float.c +++ b/src/scheme/ao_scheme_float.c @@ -39,6 +39,10 @@ const struct ao_scheme_type ao_scheme_float_type = { .name = "float", }; +#ifndef FLOAT_FORMAT +#define FLOAT_FORMAT "%g" +#endif + void ao_scheme_float_write(ao_poly p) { @@ -54,7 +58,7 @@ ao_scheme_float_write(ao_poly p) printf("+"); printf("inf.0"); } else - printf ("%g", f->value); + printf (FLOAT_FORMAT, v); } float diff --git a/src/scheme/ao_scheme_read.c b/src/scheme/ao_scheme_read.c index 6b1e9d66..30e29441 100644 --- a/src/scheme/ao_scheme_read.c +++ b/src/scheme/ao_scheme_read.c @@ -151,7 +151,7 @@ static const uint16_t lex_classes[128] = { static int lex_unget_c; static inline int -lex_get() +lex_get(void) { int c; if (lex_unget_c) { @@ -244,7 +244,7 @@ lex_quoted(void) } } -#define AO_SCHEME_TOKEN_MAX 32 +#define AO_SCHEME_TOKEN_MAX 128 static char token_string[AO_SCHEME_TOKEN_MAX]; static int32_t token_int; @@ -470,6 +470,7 @@ static inline int lex(void) 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; @@ -479,11 +480,11 @@ struct ao_scheme_cons *ao_scheme_read_stack; #define READ_DONE_DOT 0x04 static int -push_read_stack(int cons, int read_state) +push_read_stack(int read_state) { RDBGI("push read stack %p 0x%x\n", ao_scheme_read_cons, read_state); RDBG_IN(); - if (cons) { + 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))); @@ -496,10 +497,10 @@ push_read_stack(int cons, int read_state) } static int -pop_read_stack(int cons) +pop_read_stack(void) { int read_state = 0; - if (cons) { + 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); @@ -523,19 +524,18 @@ ao_scheme_read(void) { struct ao_scheme_atom *atom; char *string; - int cons; int read_state; ao_poly v = AO_SCHEME_NIL; - cons = 0; + 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 (parse_token == OPEN) { - if (!push_read_stack(cons, read_state)) + if (!push_read_stack(read_state)) return AO_SCHEME_NIL; - cons++; + ao_scheme_read_list++; read_state = 0; parse_token = lex(); } @@ -543,7 +543,7 @@ ao_scheme_read(void) switch (parse_token) { case END: default: - if (cons) + if (ao_scheme_read_list) ao_scheme_error(AO_SCHEME_EOF, "unexpected end of file"); return _ao_scheme_atom_eof; break; @@ -577,9 +577,9 @@ ao_scheme_read(void) case QUASIQUOTE: case UNQUOTE: case UNQUOTE_SPLICING: - if (!push_read_stack(cons, read_state)) + if (!push_read_stack(read_state)) return AO_SCHEME_NIL; - cons++; + ao_scheme_read_list++; read_state = READ_IN_QUOTE; switch (parse_token) { case QUOTE: @@ -597,16 +597,16 @@ ao_scheme_read(void) } break; case CLOSE: - if (!cons) { + if (!ao_scheme_read_list) { v = AO_SCHEME_NIL; break; } v = ao_scheme_cons_poly(ao_scheme_read_cons); - --cons; - read_state = pop_read_stack(cons); + --ao_scheme_read_list; + read_state = pop_read_stack(); break; case DOT: - if (!cons) { + if (!ao_scheme_read_list) { ao_scheme_error(AO_SCHEME_INVALID, ". outside of cons"); return AO_SCHEME_NIL; } @@ -620,7 +620,7 @@ ao_scheme_read(void) /* loop over QUOTE ends */ for (;;) { - if (!cons) + if (!ao_scheme_read_list) return v; if (read_state & READ_DONE_DOT) { @@ -647,8 +647,8 @@ ao_scheme_read(void) break; v = ao_scheme_cons_poly(ao_scheme_read_cons); - --cons; - read_state = pop_read_stack(cons); + --ao_scheme_read_list; + read_state = pop_read_stack(); } } return v; diff --git a/src/scheme/test/ao_scheme_test.c b/src/scheme/test/ao_scheme_test.c index 15c71203..686e7169 100644 --- a/src/scheme/test/ao_scheme_test.c +++ b/src/scheme/test/ao_scheme_test.c @@ -78,7 +78,7 @@ ao_scheme_getc(void) return getc(ao_scheme_file); if (newline) { - if (ao_scheme_read_stack) + if (ao_scheme_read_list) printf("+ "); else printf("> "); -- cgit v1.2.3 From 111622dbcd56c225a9d5ace9f0ef745e62f8a94c Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sat, 9 Dec 2017 16:57:35 -0800 Subject: altoslib: Fix 8 to 12 bit conversion for Mega pyro voltage data The conversion was losing the replicated top four bits by shifting by the wrong amount. Signed-off-by: Keith Packard --- altoslib/AltosTelemetryMegaData.java | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/altoslib/AltosTelemetryMegaData.java b/altoslib/AltosTelemetryMegaData.java index 7ef9c637..f5961c8c 100644 --- a/altoslib/AltosTelemetryMegaData.java +++ b/altoslib/AltosTelemetryMegaData.java @@ -24,7 +24,9 @@ public class AltosTelemetryMegaData extends AltosTelemetryStandard { int v_batt() { return int16(6); } int v_pyro() { return int16(8); } - int sense(int i) { int v = uint8(10+i); return v << 4 | v >> 8; } + + /* pyro sense values are sent in 8 bits, expand to 12 bits */ + int sense(int i) { int v = uint8(10+i); return (v << 4) | (v >> 4); } int ground_pres() { return int32(16); } int ground_accel() { return int16(20); } -- cgit v1.2.3 From 0d3365e2c04793cd8432c30a66881f53385a2e60 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 00:00:23 -0800 Subject: altos/scheme: Fix name of constant scheme file .lisp -> .scheme Signed-off-by: Keith Packard --- src/scheme/Makefile | 4 ++-- src/scheme/ao_scheme_const.scheme | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/scheme/Makefile b/src/scheme/Makefile index ea94c1c0..dc36dde1 100644 --- a/src/scheme/Makefile +++ b/src/scheme/Makefile @@ -5,8 +5,8 @@ clean: +cd test && make clean rm -f ao_scheme_const.h ao_scheme_builtin.h -ao_scheme_const.h: ao_scheme_const.lisp make-const/ao_scheme_make_const - make-const/ao_scheme_make_const -o $@ ao_scheme_const.lisp +ao_scheme_const.h: ao_scheme_const.scheme make-const/ao_scheme_make_const + make-const/ao_scheme_make_const -o $@ ao_scheme_const.scheme ao_scheme_builtin.h: ao_scheme_make_builtin ao_scheme_builtin.txt nickle ao_scheme_make_builtin ao_scheme_builtin.txt > $@ diff --git a/src/scheme/ao_scheme_const.scheme b/src/scheme/ao_scheme_const.scheme index 422bdd63..ab6a309a 100644 --- a/src/scheme/ao_scheme_const.scheme +++ b/src/scheme/ao_scheme_const.scheme @@ -641,7 +641,7 @@ (char-whitespace? #\space) (define (char->integer c) c) -(define (integer->char c) char-integer) +(define integer->char char->integer) (define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c)) -- cgit v1.2.3 From 17fe6de833cccb6d43d0ac0ed84a4faaa3463a09 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 00:02:00 -0800 Subject: altos/scheme: Add vectors Constant time and smaller can be a feature. Signed-off-by: Keith Packard --- src/scheme/Makefile-inc | 3 +- src/scheme/README | 2 +- src/scheme/ao_scheme.h | 48 ++- src/scheme/ao_scheme_builtin.c | 65 +++- src/scheme/ao_scheme_builtin.txt | 7 + src/scheme/ao_scheme_const.lisp | 813 --------------------------------------- src/scheme/ao_scheme_eval.c | 8 +- src/scheme/ao_scheme_mem.c | 1 + src/scheme/ao_scheme_poly.c | 4 + src/scheme/ao_scheme_read.c | 14 +- src/scheme/ao_scheme_read.h | 1 + 11 files changed, 139 insertions(+), 827 deletions(-) delete mode 100644 src/scheme/ao_scheme_const.lisp diff --git a/src/scheme/Makefile-inc b/src/scheme/Makefile-inc index d23ee3d7..1a080a4e 100644 --- a/src/scheme/Makefile-inc +++ b/src/scheme/Makefile-inc @@ -15,7 +15,8 @@ SCHEME_SRCS=\ ao_scheme_rep.c \ ao_scheme_save.c \ ao_scheme_stack.c \ - ao_scheme_error.c + ao_scheme_error.c \ + ao_scheme_vector.c SCHEME_HDRS=\ ao_scheme.h \ diff --git a/src/scheme/README b/src/scheme/README index 98932b44..a18457fd 100644 --- a/src/scheme/README +++ b/src/scheme/README @@ -5,6 +5,6 @@ This follows the R7RS with the following known exceptions: * No dynamic-wind or exceptions * No environments * No ports -* No syntax-rules; (have classic macros) +* No syntax-rules * No record types * No libraries diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index 10518716..89616617 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -104,7 +104,8 @@ extern uint8_t ao_scheme_pool[AO_SCHEME_POOL + AO_SCHEME_POOL_EXTRA] __attribut #define AO_SCHEME_BOOL 10 #define AO_SCHEME_BIGINT 11 #define AO_SCHEME_FLOAT 12 -#define AO_SCHEME_NUM_TYPE 13 +#define AO_SCHEME_VECTOR 13 +#define AO_SCHEME_NUM_TYPE 14 /* Leave two bits for types to use as they please */ #define AO_SCHEME_OTHER_TYPE_MASK 0x3f @@ -192,6 +193,13 @@ struct ao_scheme_float { float value; }; +struct ao_scheme_vector { + uint8_t type; + uint8_t pad1; + uint16_t length; + ao_poly vals[]; +}; + #if __BYTE_ORDER == __LITTLE_ENDIAN static inline uint32_t ao_scheme_int_bigint(int32_t i) { @@ -500,6 +508,18 @@ ao_scheme_poly_float(ao_poly poly) float ao_scheme_poly_number(ao_poly p); +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); +} + /* memory functions */ extern int ao_scheme_collects[2]; @@ -680,6 +700,32 @@ void ao_scheme_bigint_write(ao_poly i); extern const struct ao_scheme_type ao_scheme_bigint_type; + +/* vector */ + +void +ao_scheme_vector_write(ao_poly v); + +void +ao_scheme_vector_display(ao_poly v); + +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(ao_poly p); diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index aa818646..ae96df7f 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -267,7 +267,6 @@ ao_scheme_do_write(struct ao_scheme_cons *cons) if (cons) printf(" "); } - printf("\n"); return _ao_scheme_bool_true; } @@ -751,7 +750,7 @@ ao_poly ao_scheme_do_listp(struct ao_scheme_cons *cons) { ao_poly v; - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + if (!ao_scheme_check_argc(_ao_scheme_atom_list3f, cons, 1, 1)) return AO_SCHEME_NIL; v = ao_scheme_arg(cons, 0); for (;;) { @@ -864,5 +863,67 @@ ao_scheme_do_jiffies_per_second(struct ao_scheme_cons *cons) return (ao_scheme_int_poly(AO_SCHEME_JIFFIES_PER_SECOND)); } +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_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); +} + #define AO_SCHEME_BUILTIN_FUNCS #include "ao_scheme_builtin.h" diff --git a/src/scheme/ao_scheme_builtin.txt b/src/scheme/ao_scheme_builtin.txt index cb65e252..e7b3d75c 100644 --- a/src/scheme/ao_scheme_builtin.txt +++ b/src/scheme/ao_scheme_builtin.txt @@ -66,3 +66,10 @@ f_lambda finitep finite? f_lambda infinitep infinite? f_lambda inexactp inexact? f_lambda sqrt +f_lambda vector_ref vector-ref +f_lambda vector_set vector-set! +f_lambda vector +f_lambda list_to_vector list->vector +f_lambda vector_to_list vector->list +f_lambda vector_length vector-length +f_lambda vectorp vector? diff --git a/src/scheme/ao_scheme_const.lisp b/src/scheme/ao_scheme_const.lisp deleted file mode 100644 index 422bdd63..00000000 --- a/src/scheme/ao_scheme_const.lisp +++ /dev/null @@ -1,813 +0,0 @@ -; -; Copyright © 2016 Keith Packard -; -; This program is free software; you can redistribute it and/or modify -; it under the terms of the GNU General Public License as published by -; the Free Software Foundation, either version 2 of the License, or -; (at your option) any later version. -; -; This program is distributed in the hope that it will be useful, but -; WITHOUT ANY WARRANTY; without even the implied warranty of -; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -; General Public License for more details. -; -; Lisp code placed in ROM - - ; return a list containing all of the arguments -(def (quote list) (lambda l l)) - -(def (quote def!) - (macro (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 ((list? 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 ) - ; (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 c) c) -(define (integer->char c) 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")) - -;(define number->string (lambda (arg . opt) -; (let ((base (if (null? opt) 10 (car opt))) - ; -; - diff --git a/src/scheme/ao_scheme_eval.c b/src/scheme/ao_scheme_eval.c index 9b3cf63e..907ecf0b 100644 --- a/src/scheme/ao_scheme_eval.c +++ b/src/scheme/ao_scheme_eval.c @@ -108,13 +108,7 @@ ao_scheme_eval_sexpr(void) 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 */ - case AO_SCHEME_BOOL: - case AO_SCHEME_INT: - case AO_SCHEME_BIGINT: - case AO_SCHEME_FLOAT: - case AO_SCHEME_STRING: - case AO_SCHEME_BUILTIN: - case AO_SCHEME_LAMBDA: + default: ao_scheme_stack->state = eval_val; break; } diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c index acc726c8..fe4bc4f5 100644 --- a/src/scheme/ao_scheme_mem.c +++ b/src/scheme/ao_scheme_mem.c @@ -467,6 +467,7 @@ static const struct ao_scheme_type * const ao_scheme_types[AO_SCHEME_NUM_TYPE] = [AO_SCHEME_BOOL] = &ao_scheme_bool_type, [AO_SCHEME_BIGINT] = &ao_scheme_bigint_type, [AO_SCHEME_FLOAT] = &ao_scheme_float_type, + [AO_SCHEME_VECTOR] = &ao_scheme_vector_type, }; static int diff --git a/src/scheme/ao_scheme_poly.c b/src/scheme/ao_scheme_poly.c index d726321c..553585db 100644 --- a/src/scheme/ao_scheme_poly.c +++ b/src/scheme/ao_scheme_poly.c @@ -68,6 +68,10 @@ static const struct ao_scheme_funcs ao_scheme_funcs[AO_SCHEME_NUM_TYPE] = { .write = ao_scheme_float_write, .display = ao_scheme_float_write, }, + [AO_SCHEME_VECTOR] = { + .write = ao_scheme_vector_write, + .display = ao_scheme_vector_display + }, }; static const struct ao_scheme_funcs * diff --git a/src/scheme/ao_scheme_read.c b/src/scheme/ao_scheme_read.c index 30e29441..9ed54b9f 100644 --- a/src/scheme/ao_scheme_read.c +++ b/src/scheme/ao_scheme_read.c @@ -340,6 +340,8 @@ _lex(void) add_token(c); end_token(); return BOOL; + case '(': + return OPEN_VECTOR; case '\\': for (;;) { int alphabetic; @@ -474,10 +476,12 @@ 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) @@ -490,7 +494,8 @@ push_read_stack(int 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; @@ -513,6 +518,7 @@ pop_read_stack(void) 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); @@ -532,7 +538,9 @@ ao_scheme_read(void) ao_scheme_read_cons = ao_scheme_read_cons_tail = ao_scheme_read_stack = 0; for (;;) { parse_token = lex(); - while (parse_token == OPEN) { + while (parse_token == OPEN || parse_token == OPEN_VECTOR) { + if (parse_token == OPEN_VECTOR) + read_state |= READ_SAW_VECTOR; if (!push_read_stack(read_state)) return AO_SCHEME_NIL; ao_scheme_read_list++; @@ -604,6 +612,8 @@ ao_scheme_read(void) v = ao_scheme_cons_poly(ao_scheme_read_cons); --ao_scheme_read_list; read_state = pop_read_stack(); + if (read_state & READ_SAW_VECTOR) + v = ao_scheme_vector_poly(ao_scheme_list_to_vector(ao_scheme_poly_cons(v))); break; case DOT: if (!ao_scheme_read_list) { diff --git a/src/scheme/ao_scheme_read.h b/src/scheme/ao_scheme_read.h index e9508835..e10a7d05 100644 --- a/src/scheme/ao_scheme_read.h +++ b/src/scheme/ao_scheme_read.h @@ -32,6 +32,7 @@ # define FLOAT 10 # define DOT 11 # define BOOL 12 +# define OPEN_VECTOR 13 /* * character classes -- cgit v1.2.3 From abb856cd66e00d739e4efb1930b5c168eaf48029 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 00:02:34 -0800 Subject: altos/scheme: Avoid crashing with non-list in length Use ao_scheme_cons_cdr to fetch the next list element as that returns NULL for non-cons elements. Signed-off-by: Keith Packard --- src/scheme/ao_scheme_cons.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c index 03dad956..21ee10cc 100644 --- a/src/scheme/ao_scheme_cons.c +++ b/src/scheme/ao_scheme_cons.c @@ -195,7 +195,7 @@ ao_scheme_cons_length(struct ao_scheme_cons *cons) int len = 0; while (cons) { len++; - cons = ao_scheme_poly_cons(cons->cdr); + cons = ao_scheme_cons_cdr(cons); } return len; } -- cgit v1.2.3 From 6d14f809b54b99725447a934047167c2e7febe82 Mon Sep 17 00:00:00 2001 From: Bdale Garbee Date: Mon, 11 Dec 2017 10:17:40 -0700 Subject: TeleMega v3.0 turnon scripts --- ao-bringup/test-telemega | 2 +- ao-bringup/turnon_telemega | 4 ++-- ao-bringup/turnon_telemega_v2.0 | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/ao-bringup/test-telemega b/ao-bringup/test-telemega index 0ac475a3..ec024e32 100755 --- a/ao-bringup/test-telemega +++ b/ao-bringup/test-telemega @@ -1,6 +1,6 @@ #!/bin/sh -VERSION=2.0 +VERSION=3.0 PRODUCT=TeleMega BASE=`echo $PRODUCT | tr 'A-Z' 'a-z'` diff --git a/ao-bringup/turnon_telemega b/ao-bringup/turnon_telemega index d7ccc570..49776788 100755 --- a/ao-bringup/turnon_telemega +++ b/ao-bringup/turnon_telemega @@ -14,12 +14,12 @@ else exit 1 fi -VERSION=2.0 +VERSION=3.0 REPO=~/altusmetrumllc/Binaries PRODUCT=TeleMega echo "$PRODUCT v$VERSION Turn-On and Calibration Program" -echo "Copyright 2014 by Bdale Garbee. Released under GPL v2" +echo "Copyright 2017 by Bdale Garbee. Released under GPL v3" echo echo "Expectations:" echo "\t$PRODUCT v$VERSION powered from USB" diff --git a/ao-bringup/turnon_telemega_v2.0 b/ao-bringup/turnon_telemega_v2.0 index d7ccc570..3c80dd94 100755 --- a/ao-bringup/turnon_telemega_v2.0 +++ b/ao-bringup/turnon_telemega_v2.0 @@ -76,6 +76,6 @@ done echo 'E 1' > $dev -./test-telemega +./test-telemega-v2.0 exit $? -- cgit v1.2.3 From 7e14e243565e814ddd524c8d09454719dc89c6d8 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 13:13:27 -0800 Subject: altos/scheme: Add a bunch of string and vector builtins Just make the language closer to r7rs Signed-off-by: Keith Packard --- src/scheme/ao_scheme_builtin.c | 124 ++++++++++++++++++++++++++++++++++++--- src/scheme/ao_scheme_builtin.txt | 19 +++--- 2 files changed, 128 insertions(+), 15 deletions(-) diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index ae96df7f..397ce032 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -123,10 +123,21 @@ ao_scheme_check_argt(ao_poly name, struct ao_scheme_cons *cons, int argc, int ty 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, "%s: arg %d invalid type %v", ao_scheme_poly_atom(name)->name, argc, car); + return ao_scheme_error(AO_SCHEME_INVALID, "%v: arg %d invalid type %v", name, argc, car); return _ao_scheme_bool_true; } +int32_t +ao_scheme_arg_int(ao_poly name, struct ao_scheme_cons *cons, int argc) +{ + ao_poly p = ao_scheme_arg(cons, argc); + int32_t i = ao_scheme_poly_integer(p); + + if (i == AO_SCHEME_NOT_INTEGER) + (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) { @@ -568,6 +579,88 @@ ao_scheme_do_string_to_list(struct ao_scheme_cons *cons) 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 (ref == AO_SCHEME_NOT_INTEGER) + return AO_SCHEME_NIL; + string = ao_scheme_poly_string(ao_scheme_arg(cons, 0)); + 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) +{ + char *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)); +} + +ao_poly +ao_scheme_do_string_copy(struct ao_scheme_cons *cons) +{ + char *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)); + ref = ao_scheme_arg_int(_ao_scheme_atom_string2dset21, cons, 1); + if (ref == AO_SCHEME_NOT_INTEGER) + return AO_SCHEME_NIL; + val = ao_scheme_arg_int(_ao_scheme_atom_string2dset21, cons, 2); + if (val == AO_SCHEME_NOT_INTEGER) + 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) { @@ -580,10 +673,11 @@ ao_scheme_do_flush_output(struct ao_scheme_cons *cons) ao_poly ao_scheme_do_led(struct ao_scheme_cons *cons) { - ao_poly led; + int32_t led; 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)) + led = ao_scheme_arg_int(_ao_scheme_atom_led, cons, 0); + if (led == AO_SCHEME_NOT_INTEGER) return AO_SCHEME_NIL; led = ao_scheme_arg(cons, 0); ao_scheme_os_led(ao_scheme_poly_int(led)); @@ -593,13 +687,14 @@ ao_scheme_do_led(struct ao_scheme_cons *cons) ao_poly ao_scheme_do_delay(struct ao_scheme_cons *cons) { - ao_poly delay; - if (!ao_scheme_check_argc(_ao_scheme_atom_led, cons, 1, 1)) + int32_t delay; + + if (!ao_scheme_check_argc(_ao_scheme_atom_delay, cons, 1, 1)) return AO_SCHEME_NIL; - if (!ao_scheme_check_argt(_ao_scheme_atom_led, cons, 0, AO_SCHEME_INT, 0)) + delay = ao_scheme_arg_int(_ao_scheme_atom_delay, cons, 0); + if (delay == AO_SCHEME_NOT_INTEGER) return AO_SCHEME_NIL; - delay = ao_scheme_arg(cons, 0); - ao_scheme_os_delay(ao_scheme_poly_int(delay)); + ao_scheme_os_delay(delay); return delay; } @@ -869,6 +964,19 @@ 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 (k == AO_SCHEME_NOT_INTEGER) + 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) { diff --git a/src/scheme/ao_scheme_builtin.txt b/src/scheme/ao_scheme_builtin.txt index e7b3d75c..b7261ce1 100644 --- a/src/scheme/ao_scheme_builtin.txt +++ b/src/scheme/ao_scheme_builtin.txt @@ -20,7 +20,7 @@ nlambda begin nlambda while f_lambda write f_lambda display -f_lambda plus + +f_lambda plus + string-append f_lambda minus - f_lambda times * f_lambda divide / @@ -28,12 +28,10 @@ f_lambda modulo modulo % f_lambda remainder f_lambda quotient f_lambda equal = eq? eqv? -f_lambda less < -f_lambda greater > -f_lambda less_equal <= -f_lambda greater_equal >= -f_lambda list_to_string list->string -f_lambda string_to_list string->list +f_lambda less < string string>? +f_lambda less_equal <= string<=? +f_lambda greater_equal >= string>=? f_lambda flush_output flush-output f_lambda delay f_lambda led @@ -51,9 +49,15 @@ f_lambda booleanp boolean? f_lambda set_car set-car! f_lambda set_cdr set-cdr! f_lambda symbolp symbol? +f_lambda list_to_string list->string +f_lambda string_to_list string->list f_lambda symbol_to_string symbol->string f_lambda string_to_symbol string->symbol f_lambda stringp string? +f_lambda string_ref string-ref +f_lambda string_set string-set! +f_lambda string_copy string-copy +f_lambda string_length string-length f_lambda procedurep procedure? lambda apply f_lambda read_char read-char @@ -69,6 +73,7 @@ f_lambda sqrt f_lambda vector_ref vector-ref f_lambda vector_set vector-set! f_lambda vector +f_lambda make_vector make-vector f_lambda list_to_vector list->vector f_lambda vector_to_list vector->list f_lambda vector_length vector-length -- cgit v1.2.3 From 7517da1646fc30faaa9ee1c969cfa35ae1a17423 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 16:50:06 -0800 Subject: altos/scheme: Use 64-bit ints to track memory allocation stats These are only collected for debug purposes, but can get quite large if the interpreter runs for a while. Signed-off-by: Keith Packard --- src/scheme/ao_scheme.h | 6 +++--- src/scheme/ao_scheme_mem.c | 6 +++--- src/scheme/test/ao_scheme_test.c | 6 +++--- 3 files changed, 9 insertions(+), 9 deletions(-) diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index 89616617..4655b2a9 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -522,9 +522,9 @@ ao_scheme_poly_vector(ao_poly poly) /* memory functions */ -extern int ao_scheme_collects[2]; -extern int ao_scheme_freed[2]; -extern int ao_scheme_loops[2]; +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 diff --git a/src/scheme/ao_scheme_mem.c b/src/scheme/ao_scheme_mem.c index fe4bc4f5..45d4de98 100644 --- a/src/scheme/ao_scheme_mem.c +++ b/src/scheme/ao_scheme_mem.c @@ -483,9 +483,9 @@ ao_scheme_poly_mark_ref(ao_poly *p, uint8_t do_note_cons) } #if DBG_MEM_STATS -int ao_scheme_collects[2]; -int ao_scheme_freed[2]; -int ao_scheme_loops[2]; +uint64_t ao_scheme_collects[2]; +uint64_t ao_scheme_freed[2]; +uint64_t ao_scheme_loops[2]; #endif int ao_scheme_last_top; diff --git a/src/scheme/test/ao_scheme_test.c b/src/scheme/test/ao_scheme_test.c index 686e7169..0c77d8d5 100644 --- a/src/scheme/test/ao_scheme_test.c +++ b/src/scheme/test/ao_scheme_test.c @@ -107,15 +107,15 @@ main (int argc, char **argv) } ao_scheme_read_eval_print(); - printf ("collects: full: %d incremental %d\n", + printf ("collects: full: %lu incremental %lu\n", ao_scheme_collects[AO_SCHEME_COLLECT_FULL], ao_scheme_collects[AO_SCHEME_COLLECT_INCREMENTAL]); - printf ("freed: full %d incremental %d\n", + printf ("freed: full %lu incremental %lu\n", ao_scheme_freed[AO_SCHEME_COLLECT_FULL], ao_scheme_freed[AO_SCHEME_COLLECT_INCREMENTAL]); - printf("loops: full %d incremental %d\n", + printf("loops: full %lu incremental %lu\n", ao_scheme_loops[AO_SCHEME_COLLECT_FULL], ao_scheme_loops[AO_SCHEME_COLLECT_INCREMENTAL]); -- cgit v1.2.3 From b72638e60b6636b479b79bbf0047cf7409f58820 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 16:51:25 -0800 Subject: altos/scheme: add list-copy A lot easier as a built-in; the obvious scheme version is recursive. Signed-off-by: Keith Packard --- src/scheme/ao_scheme.h | 3 +++ src/scheme/ao_scheme_builtin.c | 13 +++++++++++++ src/scheme/ao_scheme_builtin.txt | 1 + src/scheme/ao_scheme_cons.c | 38 +++++++++++++++++++++++++++++++++++++- 4 files changed, 54 insertions(+), 1 deletion(-) diff --git a/src/scheme/ao_scheme.h b/src/scheme/ao_scheme.h index 4655b2a9..2fa1ed60 100644 --- a/src/scheme/ao_scheme.h +++ b/src/scheme/ao_scheme.h @@ -634,6 +634,9 @@ ao_scheme_cons_display(ao_poly); 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; diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index 397ce032..6f9e1390 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -197,6 +197,19 @@ ao_scheme_do_length(struct ao_scheme_cons *cons) 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) { diff --git a/src/scheme/ao_scheme_builtin.txt b/src/scheme/ao_scheme_builtin.txt index b7261ce1..17f5ea0c 100644 --- a/src/scheme/ao_scheme_builtin.txt +++ b/src/scheme/ao_scheme_builtin.txt @@ -8,6 +8,7 @@ f_lambda cdr f_lambda cons f_lambda last f_lambda length +f_lambda list_copy list-copy nlambda quote atom quasiquote atom unquote diff --git a/src/scheme/ao_scheme_cons.c b/src/scheme/ao_scheme_cons.c index 21ee10cc..02512e15 100644 --- a/src/scheme/ao_scheme_cons.c +++ b/src/scheme/ao_scheme_cons.c @@ -112,7 +112,7 @@ ao_scheme_cons_cdr(struct ao_scheme_cons *cons) if (cdr == AO_SCHEME_NIL) return NULL; if (ao_scheme_poly_type(cdr) != AO_SCHEME_CONS) { - (void) ao_scheme_error(AO_SCHEME_INVALID, "improper list"); + (void) ao_scheme_error(AO_SCHEME_INVALID, "improper cdr %v", cdr); return NULL; } return ao_scheme_poly_cons(cdr); @@ -124,6 +124,42 @@ 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(0, cons); + ao_scheme_cons_stash(1, head); + ao_scheme_poly_stash(0, ao_scheme_cons_poly(tail)); + new = ao_scheme_alloc(sizeof (struct ao_scheme_cons)); + cons = ao_scheme_cons_fetch(0); + head = ao_scheme_cons_fetch(1); + tail = ao_scheme_poly_cons(ao_scheme_poly_fetch(0)); + 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_poly_type(cdr) != AO_SCHEME_CONS) { + tail->cdr = cdr; + break; + } + cons = ao_scheme_poly_cons(cdr); + } + return head; +} + void ao_scheme_cons_free(struct ao_scheme_cons *cons) { -- cgit v1.2.3 From bdafb4dfad89d92efec37ed826d5f22e9167e717 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 16:52:26 -0800 Subject: altos/scheme: Stash cons across value allocation in compare Large ints, strings and floats can cause allocation, requiring that the 'cons' pointer be stashed and retrieved in case it moved. Signed-off-by: Keith Packard --- src/scheme/ao_scheme_builtin.c | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index 6f9e1390..7a590735 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -319,6 +319,7 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) if (cons == orig_cons) { ret = car; + ao_scheme_cons_stash(0, cons); if (cons->cdr == AO_SCHEME_NIL) { switch (op) { case builtin_minus: @@ -339,6 +340,7 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) break; } } + cons = ao_scheme_cons_fetch(0); } else if (ao_scheme_integer_typep(rt) && ao_scheme_integer_typep(ct)) { int32_t r = ao_scheme_poly_integer(ret); int32_t c = ao_scheme_poly_integer(car); @@ -390,7 +392,9 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) default: break; } + ao_scheme_cons_stash(0, cons); ret = ao_scheme_integer_poly(r); + cons = ao_scheme_cons_fetch(0); } else if (ao_scheme_number_typep(rt) && ao_scheme_number_typep(ct)) { float r, c; inexact: @@ -416,12 +420,18 @@ ao_scheme_math(struct ao_scheme_cons *orig_cons, enum ao_scheme_builtin_id op) default: break; } + ao_scheme_cons_stash(0, cons); ret = ao_scheme_float_get(r); + cons = ao_scheme_cons_fetch(0); } - - else if (rt == AO_SCHEME_STRING && ct == AO_SCHEME_STRING && op == builtin_plus) + else if (rt == AO_SCHEME_STRING && ct == AO_SCHEME_STRING && op == builtin_plus) { + ao_scheme_cons_stash(0, cons); ret = ao_scheme_string_poly(ao_scheme_string_cat(ao_scheme_poly_string(ret), - ao_scheme_poly_string(car))); + ao_scheme_poly_string(car))); + cons = ao_scheme_cons_fetch(0); + if (!ret) + return ret; + } else return ao_scheme_error(AO_SCHEME_INVALID, "invalid args"); } -- cgit v1.2.3 From 3e7a703bb2e70a0568b44159b993386f7ec46e04 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 16:53:25 -0800 Subject: altos/scheme: Make eqv? work for numbers and strings Large numbers, floats and strings need a value check, not just a comparison between ao_polys Signed-off-by: Keith Packard --- src/scheme/ao_scheme_builtin.c | 44 ++++++++++++++++++++++++++++++++++++++---- 1 file changed, 40 insertions(+), 4 deletions(-) diff --git a/src/scheme/ao_scheme_builtin.c b/src/scheme/ao_scheme_builtin.c index 7a590735..1754e677 100644 --- a/src/scheme/ao_scheme_builtin.c +++ b/src/scheme/ao_scheme_builtin.c @@ -492,9 +492,8 @@ ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op) for (cons = ao_scheme_cons_cdr(cons); cons; cons = ao_scheme_cons_cdr(cons)) { ao_poly right = cons->car; - if (op == builtin_equal) { - if (left != right) - return _ao_scheme_bool_false; + if (op == builtin_equal && left == right) { + ; } else { uint8_t lt = ao_scheme_poly_type(left); uint8_t rt = ao_scheme_poly_type(right); @@ -519,6 +518,38 @@ ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op) if (!(l >= r)) return _ao_scheme_bool_false; break; + case builtin_equal: + if (!(l == r)) + return _ao_scheme_bool_false; + default: + break; + } + } 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; } @@ -542,10 +573,15 @@ ao_scheme_compare(struct ao_scheme_cons *cons, enum ao_scheme_builtin_id op) 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; } -- cgit v1.2.3 From dd2ed58fcdffaff7b5a9ef898affa3e1ec01ef44 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 16:54:50 -0800 Subject: altos/scheme: Make test scheme app heap maximum size It's only 32kB. Signed-off-by: Keith Packard --- src/scheme/test/ao_scheme_os.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/scheme/test/ao_scheme_os.h b/src/scheme/test/ao_scheme_os.h index 09a945bc..ea363fb3 100644 --- a/src/scheme/test/ao_scheme_os.h +++ b/src/scheme/test/ao_scheme_os.h @@ -22,7 +22,7 @@ #include #include -#define AO_SCHEME_POOL_TOTAL 16384 +#define AO_SCHEME_POOL_TOTAL 32768 #define AO_SCHEME_SAVE 1 #define DBG_MEM_STATS 1 -- cgit v1.2.3 From 7d77071f5b45632937f262600ca95c7b71f4d3da Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 16:55:57 -0800 Subject: altos/scheme: Add Makefile for scheme test app Signed-off-by: Keith Packard --- src/scheme/test/Makefile | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) create mode 100644 src/scheme/test/Makefile diff --git a/src/scheme/test/Makefile b/src/scheme/test/Makefile new file mode 100644 index 00000000..9d39d33e --- /dev/null +++ b/src/scheme/test/Makefile @@ -0,0 +1,19 @@ +include ../Makefile-inc + +vpath %.o . +vpath %.c .. +vpath %.h .. + +SRCS=$(SCHEME_SRCS) ao_scheme_test.c + +OBJS=$(SRCS:.c=.o) + +CFLAGS=-O2 -g -Wall -Wextra -I. -I.. + +ao_scheme_test: $(OBJS) + cc $(CFLAGS) -o $@ $(OBJS) -lm + +$(OBJS): $(SCHEME_HDRS) + +clean:: + rm -f $(OBJS) ao_scheme_test -- cgit v1.2.3 From 655576011e9cc648c7c4bbf51179744a427ff237 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 18:21:01 -0800 Subject: altos/lambdakey-v1.0: Switch to newlib, get things compiling again scheme is now way too large to fit on this device; some subsetting is clearly indicated. Signed-off-by: Keith Packard --- src/lambdakey-v1.0/Makefile | 35 +++++++-------- src/lambdakey-v1.0/ao_lambdakey.c | 8 ++-- src/lambdakey-v1.0/ao_lisp_os.h | 62 -------------------------- src/lambdakey-v1.0/ao_lisp_os_save.c | 53 ----------------------- src/lambdakey-v1.0/ao_scheme_os.h | 79 ++++++++++++++++++++++++++++++++++ src/lambdakey-v1.0/ao_scheme_os_save.c | 53 +++++++++++++++++++++++ 6 files changed, 151 insertions(+), 139 deletions(-) delete mode 100644 src/lambdakey-v1.0/ao_lisp_os.h delete mode 100644 src/lambdakey-v1.0/ao_lisp_os_save.c create mode 100644 src/lambdakey-v1.0/ao_scheme_os.h create mode 100644 src/lambdakey-v1.0/ao_scheme_os_save.c diff --git a/src/lambdakey-v1.0/Makefile b/src/lambdakey-v1.0/Makefile index 2609bea3..6b819ffb 100644 --- a/src/lambdakey-v1.0/Makefile +++ b/src/lambdakey-v1.0/Makefile @@ -5,6 +5,12 @@ include ../stmf0/Makefile.defs +include ../scheme/Makefile-inc + +NEWLIB_FULL=-lm -lc -lgcc + +LIBS=$(NEWLIB_FULL) + INC = \ ao.h \ ao_arch.h \ @@ -13,9 +19,7 @@ INC = \ ao_pins.h \ ao_product.h \ ao_task.h \ - ao_lisp.h \ - ao_lisp_const.h \ - ao_lisp_os.h \ + $(SCHEME_HDRS) \ stm32f0.h \ Makefile @@ -35,23 +39,8 @@ ALTOS_SRC = \ ao_timer.c \ ao_usb_stm.c \ ao_flash_stm.c \ - ao_lisp_lex.c \ - ao_lisp_mem.c \ - ao_lisp_cons.c \ - ao_lisp_eval.c \ - ao_lisp_string.c \ - ao_lisp_atom.c \ - ao_lisp_int.c \ - ao_lisp_poly.c \ - ao_lisp_builtin.c \ - ao_lisp_read.c \ - ao_lisp_rep.c \ - ao_lisp_frame.c \ - ao_lisp_error.c \ - ao_lisp_lambda.c \ - ao_lisp_save.c \ - ao_lisp_stack.c \ - ao_lisp_os_save.c + $(SCHEME_SRCS) \ + ao_scheme_os_save.c PRODUCT=LambdaKey-v1.0 PRODUCT_DEF=-DLAMBDAKEY @@ -61,6 +50,12 @@ CFLAGS = $(PRODUCT_DEF) -I. $(STMF0_CFLAGS) -Os -g LDFLAGS=$(CFLAGS) -L$(TOPDIR)/stmf0 -Wl,-Tlambda.ld +MAP=$(PROG).map +NEWLIB=/local/newlib-mini +MAPFILE=-Wl,-M=$(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 + PROGNAME=lambdakey-v1.0 PROG=$(PROGNAME)-$(VERSION).elf HEX=$(PROGNAME)-$(VERSION).ihx diff --git a/src/lambdakey-v1.0/ao_lambdakey.c b/src/lambdakey-v1.0/ao_lambdakey.c index 8bd344cf..d0996eb4 100644 --- a/src/lambdakey-v1.0/ao_lambdakey.c +++ b/src/lambdakey-v1.0/ao_lambdakey.c @@ -13,14 +13,14 @@ */ #include -#include +#include -static void lisp_cmd() { - ao_lisp_read_eval_print(); +static void scheme_cmd() { + ao_scheme_read_eval_print(); } static const struct ao_cmds blink_cmds[] = { - { lisp_cmd, "l\0Run lisp interpreter" }, + { scheme_cmd, "l\0Run scheme interpreter" }, { 0, 0 } }; diff --git a/src/lambdakey-v1.0/ao_lisp_os.h b/src/lambdakey-v1.0/ao_lisp_os.h deleted file mode 100644 index 1993ac44..00000000 --- a/src/lambdakey-v1.0/ao_lisp_os.h +++ /dev/null @@ -1,62 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation; version 2 of the License. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License along - * with this program; if not, write to the Free Software Foundation, Inc., - * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. - */ - -#ifndef _AO_LISP_OS_H_ -#define _AO_LISP_OS_H_ - -#include "ao.h" - -static inline int -ao_lisp_getc() { - static uint8_t at_eol; - int c; - - if (at_eol) { - ao_cmd_readline(); - at_eol = 0; - } - c = ao_cmd_lex(); - if (c == '\n') - at_eol = 1; - return c; -} - -static inline void -ao_lisp_os_flush(void) -{ - flush(); -} - -static inline void -ao_lisp_abort(void) -{ - ao_panic(1); -} - -static inline void -ao_lisp_os_led(int led) -{ - ao_led_set(led); -} - -static inline void -ao_lisp_os_delay(int delay) -{ - ao_delay(AO_MS_TO_TICKS(delay)); -} - -#endif diff --git a/src/lambdakey-v1.0/ao_lisp_os_save.c b/src/lambdakey-v1.0/ao_lisp_os_save.c deleted file mode 100644 index 44138398..00000000 --- a/src/lambdakey-v1.0/ao_lisp_os_save.c +++ /dev/null @@ -1,53 +0,0 @@ -/* - * Copyright © 2016 Keith Packard - * - * This program is free software; you can redistribute it and/or modify - * it under the terms of the GNU General Public License as published by - * the Free Software Foundation, either version 2 of the License, or - * (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, but - * WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - */ - -#include -#include -#include - -extern uint8_t __flash__[]; - -/* saved variables to rebuild the heap - - ao_lisp_atoms - ao_lisp_frame_global - */ - -int -ao_lisp_os_save(void) -{ - int i; - - for (i = 0; i < AO_LISP_POOL_TOTAL; i += 256) { - uint32_t *dst = (uint32_t *) &__flash__[i]; - uint32_t *src = (uint32_t *) &ao_lisp_pool[i]; - - ao_flash_page(dst, src); - } - return 1; -} - -int -ao_lisp_os_restore_save(struct ao_lisp_os_save *save, int offset) -{ - memcpy(save, &__flash__[offset], sizeof (struct ao_lisp_os_save)); - return 1; -} - -int -ao_lisp_os_restore(void) -{ - memcpy(ao_lisp_pool, __flash__, AO_LISP_POOL_TOTAL); - return 1; -} diff --git a/src/lambdakey-v1.0/ao_scheme_os.h b/src/lambdakey-v1.0/ao_scheme_os.h new file mode 100644 index 00000000..a620684f --- /dev/null +++ b/src/lambdakey-v1.0/ao_scheme_os.h @@ -0,0 +1,79 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#ifndef _AO_SCHEME_OS_H_ +#define _AO_SCHEME_OS_H_ + +#include "ao.h" + +#define AO_SCHEME_SAVE 1 + +#define AO_SCHEME_POOL_TOTAL 2048 + +#ifndef __BYTE_ORDER +#define __LITTLE_ENDIAN 1234 +#define __BIG_ENDIAN 4321 +#define __BYTE_ORDER __LITTLE_ENDIAN +#endif + +static inline int +ao_scheme_getc() { + static uint8_t at_eol; + int c; + + if (at_eol) { + ao_cmd_readline(); + at_eol = 0; + } + c = ao_cmd_lex(); + if (c == '\n') + at_eol = 1; + return c; +} + +static inline void +ao_scheme_os_flush(void) +{ + flush(); +} + +static inline void +ao_scheme_abort(void) +{ + ao_panic(1); +} + +static inline void +ao_scheme_os_led(int led) +{ + ao_led_set(led); +} + +#define AO_SCHEME_JIFFIES_PER_SECOND AO_HERTZ + +static inline void +ao_scheme_os_delay(int delay) +{ + ao_delay(delay); +} + +static inline int +ao_scheme_os_jiffy(void) +{ + return ao_tick_count; +} +#endif diff --git a/src/lambdakey-v1.0/ao_scheme_os_save.c b/src/lambdakey-v1.0/ao_scheme_os_save.c new file mode 100644 index 00000000..184ddb8d --- /dev/null +++ b/src/lambdakey-v1.0/ao_scheme_os_save.c @@ -0,0 +1,53 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include +#include +#include + +extern uint8_t __flash__[]; + +/* saved variables to rebuild the heap + + ao_scheme_atoms + ao_scheme_frame_global + */ + +int +ao_scheme_os_save(void) +{ + int i; + + for (i = 0; i < AO_SCHEME_POOL_TOTAL; i += 256) { + void *dst = &__flash__[i]; + void *src = &ao_scheme_pool[i]; + + ao_flash_page(dst, src); + } + return 1; +} + +int +ao_scheme_os_restore_save(struct ao_scheme_os_save *save, int offset) +{ + memcpy(save, &__flash__[offset], sizeof (struct ao_scheme_os_save)); + return 1; +} + +int +ao_scheme_os_restore(void) +{ + memcpy(ao_scheme_pool, __flash__, AO_SCHEME_POOL_TOTAL); + return 1; +} -- cgit v1.2.3 From b0de72d942eb87c5acd190878dd57ca4f812e8a1 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 18:32:18 -0800 Subject: altos: Add scheme for stm discovery board demo Signed-off-by: Keith Packard --- src/stm-scheme-newlib/.gitignore | 4 ++ src/stm-scheme-newlib/Makefile | 84 +++++++++++++++++++++++++ src/stm-scheme-newlib/ao_demo.c | 51 ++++++++++++++++ src/stm-scheme-newlib/ao_pins.h | 91 ++++++++++++++++++++++++++++ src/stm-scheme-newlib/ao_scheme_os.h | 78 ++++++++++++++++++++++++ src/stm-scheme-newlib/ao_scheme_os_save.c | 53 ++++++++++++++++ src/stm-scheme-newlib/flash-loader/Makefile | 8 +++ src/stm-scheme-newlib/flash-loader/ao_pins.h | 36 +++++++++++ 8 files changed, 405 insertions(+) create mode 100644 src/stm-scheme-newlib/.gitignore create mode 100644 src/stm-scheme-newlib/Makefile create mode 100644 src/stm-scheme-newlib/ao_demo.c create mode 100644 src/stm-scheme-newlib/ao_pins.h create mode 100644 src/stm-scheme-newlib/ao_scheme_os.h create mode 100644 src/stm-scheme-newlib/ao_scheme_os_save.c create mode 100644 src/stm-scheme-newlib/flash-loader/Makefile create mode 100644 src/stm-scheme-newlib/flash-loader/ao_pins.h diff --git a/src/stm-scheme-newlib/.gitignore b/src/stm-scheme-newlib/.gitignore new file mode 100644 index 00000000..60d664f4 --- /dev/null +++ b/src/stm-scheme-newlib/.gitignore @@ -0,0 +1,4 @@ +*.elf +*.map +*.syms +ao_product.h diff --git a/src/stm-scheme-newlib/Makefile b/src/stm-scheme-newlib/Makefile new file mode 100644 index 00000000..a4c249a3 --- /dev/null +++ b/src/stm-scheme-newlib/Makefile @@ -0,0 +1,84 @@ +# +# AltOS build +# +# + +include ../stm/Makefile.defs +include ../scheme/Makefile-inc + +NEWLIB_FULL=-lm -lc -lgcc + +LIBS=$(NEWLIB_FULL) + +INC = \ + ao.h \ + ao_arch.h \ + ao_arch_funcs.h \ + ao_boot.h \ + ao_pins.h \ + ao_product.h \ + ao_task.h \ + $(SCHEME_HDRS) + +# +# Common AltOS sources +# +ALTOS_SRC = \ + ao_interrupt.c \ + ao_boot_chain.c \ + ao_product.c \ + ao_romconfig.c \ + ao_cmd.c \ + ao_task.c \ + ao_led.c \ + ao_stdio_newlib.c \ + ao_panic.c \ + ao_timer.c \ + ao_mutex.c \ + ao_dma_stm.c \ + ao_usb_stm.c \ + ao_exti_stm.c \ + $(SCHEME_SRCS) + +PRODUCT=StmScheme-v0.0 +PRODUCT_DEF=-DSTM_SCHEME +IDPRODUCT=0x000a + +CFLAGS = $(PRODUCT_DEF) $(STM_CFLAGS) -g -Os + +PROG=stm-scheme-$(VERSION) +ELF=$(PROG).elf +IHX=$(PROG).ihx +LIBSYMS=$(PROG).syms +MAP=$(PROG).map + +NEWLIB=/local/newlib-mini +MAPFILE=-Wl,-M=$(MAP) +LDFLAGS=-L../stm -L$(NEWLIB)/arm-none-eabi/lib/thumb/v7-m/ -Wl,-Taltos.ld $(MAPFILE) -nostartfiles +AO_CFLAGS=-I. -I../stm -I../kernel -I../drivers -I.. -I../scheme -isystem $(NEWLIB)/arm-none-eabi/include -DNEWLIB + +SRC=$(ALTOS_SRC) ao_demo.c +OBJ=$(SRC:.c=.o) + +all: $(ELF) $(IHX) $(LIBSYMS) + +$(ELF): Makefile $(OBJ) + $(call quiet,CC) $(LDFLAGS) $(CFLAGS) -o $@ $(OBJ) $(LIBS) + +$(LIBSYMS): $(ELF) + grep '^ ' $(MAP) | grep -v 'size before relaxing' > $@ + +ao_product.h: ao-make-product.5c ../Version + $(call quiet,NICKLE,$<) $< -m altusmetrum.org -i $(IDPRODUCT) -p $(PRODUCT) -v $(VERSION) > $@ + +$(OBJ): $(INC) + +distclean: clean + +clean: + rm -f *.o *.elf *.ihx *.map *.syms + rm -f ao_product.h + +install: + +uninstall: diff --git a/src/stm-scheme-newlib/ao_demo.c b/src/stm-scheme-newlib/ao_demo.c new file mode 100644 index 00000000..13a31288 --- /dev/null +++ b/src/stm-scheme-newlib/ao_demo.c @@ -0,0 +1,51 @@ +/* + * Copyright © 2011 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * 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.h" +#include +#include +#include + +static void scheme_cmd() { + ao_scheme_read_eval_print(); +} + + +__code struct ao_cmds ao_demo_cmds[] = { + { scheme_cmd, "l\0Run scheme interpreter" }, + { 0, NULL } +}; + +int +main(void) +{ + ao_clock_init(); + + ao_task_init(); + + ao_led_init(LEDS_AVAILABLE); + ao_timer_init(); + ao_dma_init(); + ao_cmd_init(); + ao_usb_init(); + + ao_cmd_register(&ao_demo_cmds[0]); + + ao_start_scheduler(); + return 0; +} diff --git a/src/stm-scheme-newlib/ao_pins.h b/src/stm-scheme-newlib/ao_pins.h new file mode 100644 index 00000000..524490f7 --- /dev/null +++ b/src/stm-scheme-newlib/ao_pins.h @@ -0,0 +1,91 @@ +/* + * Copyright © 2012 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * 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_PINS_H_ +#define _AO_PINS_H_ + +/* Bridge SB17 on the board and use the MCO from the other chip */ +#define AO_HSE 8000000 +#define AO_HSE_BYPASS 1 + +/* PLLVCO = 96MHz (so that USB will work) */ +#define AO_PLLMUL 12 +#define AO_RCC_CFGR_PLLMUL (STM_RCC_CFGR_PLLMUL_12) + +/* SYSCLK = 32MHz */ +#define AO_PLLDIV 3 +#define AO_RCC_CFGR_PLLDIV (STM_RCC_CFGR_PLLDIV_3) + +/* HCLK = 32MHZ (CPU clock) */ +#define AO_AHB_PRESCALER 1 +#define AO_RCC_CFGR_HPRE_DIV STM_RCC_CFGR_HPRE_DIV_1 + +/* Run APB1 at HCLK/1 */ +#define AO_APB1_PRESCALER 1 +#define AO_RCC_CFGR_PPRE1_DIV STM_RCC_CFGR_PPRE2_DIV_1 + +/* Run APB2 at HCLK/1 */ +#define AO_APB2_PRESCALER 1 +#define AO_RCC_CFGR_PPRE2_DIV STM_RCC_CFGR_PPRE2_DIV_1 + +#define HAS_SERIAL_1 0 +#define USE_SERIAL_1_STDIN 0 +#define SERIAL_1_PB6_PB7 1 +#define SERIAL_1_PA9_PA10 0 + +#define HAS_SERIAL_2 0 +#define USE_SERIAL_2_STDIN 0 +#define SERIAL_2_PA2_PA3 0 +#define SERIAL_2_PD5_PD6 1 + +#define HAS_SERIAL_3 0 +#define USE_SERIAL_3_STDIN 1 +#define SERIAL_3_PB10_PB11 0 +#define SERIAL_3_PC10_PC11 0 +#define SERIAL_3_PD8_PD9 1 + +#define HAS_SPI_1 0 +#define SPI_1_PB3_PB4_PB5 1 +#define SPI_1_OSPEEDR STM_OSPEEDR_10MHz + +#define HAS_SPI_2 0 + +#define HAS_USB 1 +#define HAS_BEEP 0 +#define PACKET_HAS_SLAVE 0 + +#define AO_BOOT_CHAIN 1 + +#define LOW_LEVEL_DEBUG 0 + +#define LED_PORT_ENABLE STM_RCC_AHBENR_GPIOBEN +#define LED_PORT (&stm_gpiob) +#define LED_PIN_GREEN 7 +#define LED_PIN_BLUE 6 +#define AO_LED_GREEN (1 << LED_PIN_GREEN) +#define AO_LED_BLUE (1 << LED_PIN_BLUE) +#define AO_LED_PANIC AO_LED_BLUE + +#define LEDS_AVAILABLE (AO_LED_BLUE | AO_LED_GREEN) + +#define HAS_ADC 0 + +#define AO_TICK_TYPE uint32_t +#define AO_TICK_SIGNED int32_t + +#endif /* _AO_PINS_H_ */ diff --git a/src/stm-scheme-newlib/ao_scheme_os.h b/src/stm-scheme-newlib/ao_scheme_os.h new file mode 100644 index 00000000..21b6001a --- /dev/null +++ b/src/stm-scheme-newlib/ao_scheme_os.h @@ -0,0 +1,78 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; version 2 of the License. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA. + */ + +#ifndef _AO_SCHEME_OS_H_ +#define _AO_SCHEME_OS_H_ + +#include "ao.h" + +#define AO_SCHEME_POOL 10240 + +#ifndef __BYTE_ORDER +#define __LITTLE_ENDIAN 1234 +#define __BIG_ENDIAN 4321 +#define __BYTE_ORDER __LITTLE_ENDIAN +#endif + +static inline int +ao_scheme_getc() { + static uint8_t at_eol; + int c; + + if (at_eol) { + ao_cmd_readline(); + at_eol = 0; + } + c = ao_cmd_lex(); + if (c == '\n') + at_eol = 1; + return c; +} + +static inline void +ao_scheme_os_flush(void) +{ + flush(); +} + +static inline void +ao_scheme_abort(void) +{ + ao_panic(1); +} + +static inline void +ao_scheme_os_led(int led) +{ + ao_led_set(led); +} + +#define AO_SCHEME_JIFFIES_PER_SECOND AO_HERTZ + +static inline void +ao_scheme_os_delay(int delay) +{ + ao_delay(delay); +} + +static inline int +ao_scheme_os_jiffy(void) +{ + return ao_tick_count; +} + +#endif diff --git a/src/stm-scheme-newlib/ao_scheme_os_save.c b/src/stm-scheme-newlib/ao_scheme_os_save.c new file mode 100644 index 00000000..ce46f18e --- /dev/null +++ b/src/stm-scheme-newlib/ao_scheme_os_save.c @@ -0,0 +1,53 @@ +/* + * Copyright © 2016 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation, either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + */ + +#include +#include "ao_scheme.h" +#include + +extern uint8_t __flash__[]; + +/* saved variables to rebuild the heap + + ao_scheme_atoms + ao_scheme_frame_global + */ + +int +ao_scheme_os_save(void) +{ + int i; + + for (i = 0; i < AO_SCHEME_POOL_TOTAL; i += 256) { + uint32_t *dst = (uint32_t *) (void *) &__flash__[i]; + uint32_t *src = (uint32_t *) (void *) &ao_scheme_pool[i]; + + ao_flash_page(dst, src); + } + return 1; +} + +int +ao_scheme_os_restore_save(struct ao_scheme_os_save *save, int offset) +{ + memcpy(save, &__flash__[offset], sizeof (struct ao_scheme_os_save)); + return 1; +} + +int +ao_scheme_os_restore(void) +{ + memcpy(ao_scheme_pool, __flash__, AO_SCHEME_POOL_TOTAL); + return 1; +} diff --git a/src/stm-scheme-newlib/flash-loader/Makefile b/src/stm-scheme-newlib/flash-loader/Makefile new file mode 100644 index 00000000..4c60f317 --- /dev/null +++ b/src/stm-scheme-newlib/flash-loader/Makefile @@ -0,0 +1,8 @@ +# +# AltOS flash loader build +# +# + +TOPDIR=../.. +HARDWARE=stm-scheme +include $(TOPDIR)/stm/Makefile-flash.defs diff --git a/src/stm-scheme-newlib/flash-loader/ao_pins.h b/src/stm-scheme-newlib/flash-loader/ao_pins.h new file mode 100644 index 00000000..eb5fcb8b --- /dev/null +++ b/src/stm-scheme-newlib/flash-loader/ao_pins.h @@ -0,0 +1,36 @@ +/* + * Copyright © 2013 Keith Packard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, but + * WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * General Public License for more details. + * + * 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_PINS_H_ +#define _AO_PINS_H_ + +/* Bridge SB17 on the board and use the MCO from the other chip */ +#define AO_HSE 8000000 +#define AO_HSE_BYPASS 1 + +#include + +/* Use the 'user switch' to force boot loader on power on */ + +#define AO_BOOT_PIN 1 +#define AO_BOOT_APPLICATION_GPIO stm_gpioa +#define AO_BOOT_APPLICATION_PIN 0 +#define AO_BOOT_APPLICATION_VALUE 0 +#define AO_BOOT_APPLICATION_MODE 0 + +#endif /* _AO_PINS_H_ */ -- cgit v1.2.3 From 8ebecd364fd328e9c649c11729bddf58731aaafb Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 18:34:49 -0800 Subject: altos: Allow building with newlib + avr stdio on ARM Redefines some stdio bits so that we can build with either pdclib or newlib + avr stdio. Signed-off-by: Keith Packard --- src/cc1111/ao_arch.h | 4 ++++ src/kernel/ao_stdio.c | 4 ++-- src/kernel/ao_task.h | 3 +++ src/lambdakey-v1.0/Makefile | 2 +- src/stm/ao_serial_stm.c | 8 ++++---- src/stmf0/Makefile-stmf0.defs | 2 +- 6 files changed, 15 insertions(+), 8 deletions(-) diff --git a/src/cc1111/ao_arch.h b/src/cc1111/ao_arch.h index bacfabb8..937e6d0c 100644 --- a/src/cc1111/ao_arch.h +++ b/src/cc1111/ao_arch.h @@ -234,6 +234,10 @@ ao_button_get(uint16_t timeout) __critical; void ao_button_clear(void) __critical; +/* console I/O funcs */ +#define ao_getchar getchar +#define ao_putchar putchar + /* ao_string.c */ void diff --git a/src/kernel/ao_stdio.c b/src/kernel/ao_stdio.c index f0ee0a14..dc09b5c7 100644 --- a/src/kernel/ao_stdio.c +++ b/src/kernel/ao_stdio.c @@ -84,7 +84,7 @@ __pdata int8_t ao_cur_stdio; #endif void -putchar(char c) +ao_putchar(char c) { #if LOW_LEVEL_DEBUG if (!ao_cur_task) { @@ -110,7 +110,7 @@ flush(void) __xdata uint8_t ao_stdin_ready; char -getchar(void) __reentrant +ao_getchar(void) __reentrant { int c; int8_t stdio; diff --git a/src/kernel/ao_task.h b/src/kernel/ao_task.h index 30b018ff..7549b598 100644 --- a/src/kernel/ao_task.h +++ b/src/kernel/ao_task.h @@ -44,6 +44,9 @@ struct ao_task { ao_arch_task_members /* any architecture-specific fields */ uint8_t task_id; /* unique id */ __code char *name; /* task name */ +#ifdef NEWLIB + int __errno; /* storage for errno in newlib libc */ +#endif #if HAS_TASK_QUEUE struct ao_list queue; struct ao_list alarm_queue; diff --git a/src/lambdakey-v1.0/Makefile b/src/lambdakey-v1.0/Makefile index 6b819ffb..4eb045b6 100644 --- a/src/lambdakey-v1.0/Makefile +++ b/src/lambdakey-v1.0/Makefile @@ -54,7 +54,7 @@ MAP=$(PROG).map NEWLIB=/local/newlib-mini MAPFILE=-Wl,-M=$(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 +AO_CFLAGS=-I. -I../stmf0 -I../kernel -I../drivers -I.. -I../scheme -isystem $(NEWLIB)/arm-none-eabi/include -DNEWLIB PROGNAME=lambdakey-v1.0 PROG=$(PROGNAME)-$(VERSION).elf diff --git a/src/stm/ao_serial_stm.c b/src/stm/ao_serial_stm.c index ef562313..2afee5b5 100644 --- a/src/stm/ao_serial_stm.c +++ b/src/stm/ao_serial_stm.c @@ -60,13 +60,13 @@ _ao_usart_cts(struct ao_stm_usart *usart) #endif static void -_ao_usart_rx(struct ao_stm_usart *usart, int stdin) +_ao_usart_rx(struct ao_stm_usart *usart, int is_stdin) { if (usart->reg->sr & (1 << STM_USART_SR_RXNE)) { if (!ao_fifo_full(usart->rx_fifo)) { ao_fifo_insert(usart->rx_fifo, usart->reg->dr); ao_wakeup(&usart->rx_fifo); - if (stdin) + if (is_stdin) ao_wakeup(&ao_stdin_ready); #if HAS_SERIAL_SW_FLOW /* If the fifo is nearly full, turn off RTS and wait @@ -84,9 +84,9 @@ _ao_usart_rx(struct ao_stm_usart *usart, int stdin) } static void -ao_usart_isr(struct ao_stm_usart *usart, int stdin) +ao_usart_isr(struct ao_stm_usart *usart, int is_stdin) { - _ao_usart_rx(usart, stdin); + _ao_usart_rx(usart, is_stdin); if (!_ao_usart_tx_start(usart)) usart->reg->cr1 &= ~(1<< STM_USART_CR1_TXEIE); diff --git a/src/stmf0/Makefile-stmf0.defs b/src/stmf0/Makefile-stmf0.defs index f2c53499..fa6e6e86 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)/lisp +vpath % $(TOPDIR)/stmf0:$(TOPDIR)/product:$(TOPDIR)/drivers:$(TOPDIR)/kernel:$(TOPDIR)/util:$(TOPDIR)/kalman:$(TOPDIR)/aes:$(TOPDIR):$(TOPDIR)/math:$(TOPDIR)/scheme vpath make-altitude $(TOPDIR)/util vpath make-kalman $(TOPDIR)/util vpath kalman.5c $(TOPDIR)/kalman -- cgit v1.2.3 From ec638405045d33d48476ab85edf09a2e1756e3e3 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Sun, 10 Dec 2017 18:35:53 -0800 Subject: altos/scheme: Allow ao_scheme_read_eval_print to be restarted Reset exceptions at the top so that we can call it more than once. Signed-off-by: Keith Packard --- src/scheme/ao_scheme_rep.c | 2 ++ src/scheme/test/Makefile | 3 +++ 2 files changed, 5 insertions(+) diff --git a/src/scheme/ao_scheme_rep.c b/src/scheme/ao_scheme_rep.c index 9dbce5f2..5b94d940 100644 --- a/src/scheme/ao_scheme_rep.c +++ b/src/scheme/ao_scheme_rep.c @@ -18,6 +18,8 @@ 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) diff --git a/src/scheme/test/Makefile b/src/scheme/test/Makefile index 9d39d33e..c48add1f 100644 --- a/src/scheme/test/Makefile +++ b/src/scheme/test/Makefile @@ -17,3 +17,6 @@ $(OBJS): $(SCHEME_HDRS) clean:: rm -f $(OBJS) ao_scheme_test + +install: ao_scheme_test + cp ao_scheme_test $$HOME/bin/ao-scheme -- cgit v1.2.3 From 8d65e7b367712075a42d26c6d4bbff474dc1ae14 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Tue, 5 Dec 2017 12:22:34 -0800 Subject: altos/drivers: Hook up mag sensor for MPU9250 Set mag sensor to provide data at 100Hz. Set i2c master to pull mag data at sample rate (200Hz). Signed-off-by: Keith Packard --- src/drivers/ao_mpu9250.c | 180 ++++++++++++++++++++++++++++++++++++++++++++--- src/drivers/ao_mpu9250.h | 71 +++++++++++++++++++ 2 files changed, 241 insertions(+), 10 deletions(-) diff --git a/src/drivers/ao_mpu9250.c b/src/drivers/ao_mpu9250.c index b79f27ca..ae8dacd0 100644 --- a/src/drivers/ao_mpu9250.c +++ b/src/drivers/ao_mpu9250.c @@ -22,6 +22,8 @@ #if HAS_MPU9250 +#define MPU9250_TEST 0 + static uint8_t ao_mpu9250_configured; extern uint8_t ao_sensor_errors; @@ -43,8 +45,12 @@ extern uint8_t ao_sensor_errors; #define ao_mpu9250_spi_end() ao_spi_clr_cs(AO_MPU9250_SPI_CS_PORT, \ (1 << AO_MPU9250_SPI_CS_PIN)) -#endif +#else +#define ao_mpu9250_spi_get() +#define ao_mpu9250_spi_put() + +#endif static void _ao_mpu9250_reg_write(uint8_t addr, uint8_t value) @@ -102,6 +108,61 @@ _ao_mpu9250_reg_read(uint8_t addr) return value; } +static void +_ao_mpu9250_slv4_setup(uint8_t addr, uint8_t reg) +{ + /* Set i2c slave address */ + _ao_mpu9250_reg_write(MPU9250_I2C_SLV4_ADDR, + addr); + + /* Set i2c register address */ + _ao_mpu9250_reg_write(MPU9250_I2C_SLV4_REG, + reg); +} + +static void +_ao_mpu9250_slv4_run(void) +{ + uint8_t ctrl; + + /* Start the transfer */ + _ao_mpu9250_reg_write(MPU9250_I2C_SLV4_CTRL, + (1 << MPU9250_I2C_SLV4_CTRL_I2C_SLV4_EN) | + (0 << MPU9250_I2C_SLV4_CTRL_SLV4_DONE_INT_EN) | + (0 << MPU9250_I2C_SLV4_CTRL_I2C_SLV4_REG_DIS) | + (0 << MPU9250_I2C_SLV4_CTRL_I2C_MST_DLY)); + + /* Poll for completion */ + for (;;) { + ctrl = _ao_mpu9250_reg_read(MPU9250_I2C_SLV4_CTRL); + if ((ctrl & (1 << MPU9250_I2C_SLV4_CTRL_I2C_SLV4_EN)) == 0) + break; + ao_delay(0); + } +} + +static uint8_t +_ao_mpu9250_mag_reg_read(uint8_t reg) +{ + _ao_mpu9250_slv4_setup((1 << 7) | MPU9250_MAG_ADDR, reg); + + _ao_mpu9250_slv4_run(); + + return _ao_mpu9250_reg_read(MPU9250_I2C_SLV4_DI); +} + +static void +_ao_mpu9250_mag_reg_write(uint8_t reg, uint8_t value) +{ + _ao_mpu9250_slv4_setup((0 << 7) | MPU9250_MAG_ADDR, reg); + + /* Set the data */ + _ao_mpu9250_reg_write(MPU9250_I2C_SLV4_DO, + value); + + _ao_mpu9250_slv4_run(); +} + static void _ao_mpu9250_sample(struct ao_mpu9250_sample *sample) { @@ -180,6 +241,7 @@ _ao_mpu9250_wait_alive(void) } #define ST_TRIES 10 +#define MAG_TRIES 10 static void _ao_mpu9250_setup(void) @@ -187,6 +249,7 @@ _ao_mpu9250_setup(void) struct ao_mpu9250_sample normal_mode, test_mode; int errors; int st_tries; + int mag_tries; if (ao_mpu9250_configured) return; @@ -205,7 +268,7 @@ _ao_mpu9250_setup(void) /* Reset signal conditioning, disabling I2C on SPI systems */ _ao_mpu9250_reg_write(MPU9250_USER_CTRL, (0 << MPU9250_USER_CTRL_FIFO_EN) | - (0 << MPU9250_USER_CTRL_I2C_MST_EN) | + (1 << MPU9250_USER_CTRL_I2C_MST_EN) | (AO_MPU9250_SPI << MPU9250_USER_CTRL_I2C_IF_DIS) | (0 << MPU9250_USER_CTRL_FIFO_RESET) | (0 << MPU9250_USER_CTRL_I2C_MST_RESET) | @@ -233,6 +296,14 @@ _ao_mpu9250_setup(void) (0 << MPU9250_PWR_MGMT_1_TEMP_DIS) | (MPU9250_PWR_MGMT_1_CLKSEL_PLL_X_AXIS << MPU9250_PWR_MGMT_1_CLKSEL)); + /* Set I2C clock and options */ + _ao_mpu9250_reg_write(MPU9250_MST_CTRL, + (0 << MPU9250_MST_CTRL_MULT_MST_EN) | + (0 << MPU9250_MST_CTRL_WAIT_FOR_ES) | + (0 << MPU9250_MST_CTRL_SLV_3_FIFO_EN) | + (0 << MPU9250_MST_CTRL_I2C_MST_P_NSR) | + (MPU9250_MST_CTRL_I2C_MST_CLK_400 << MPU9250_MST_CTRL_I2C_MST_CLK)); + /* Set sample rate divider to sample at full speed */ _ao_mpu9250_reg_write(MPU9250_SMPRT_DIV, 0); @@ -292,6 +363,53 @@ _ao_mpu9250_setup(void) if (st_tries == ST_TRIES) ao_sensor_errors = 1; + /* Set up the mag sensor */ + + /* make sure it's alive */ + for (mag_tries = 0; mag_tries < MAG_TRIES; mag_tries++) { + if (_ao_mpu9250_mag_reg_read(MPU9250_MAG_WIA) == MPU9250_MAG_WIA_VALUE) + break; + } + + if (mag_tries == MAG_TRIES) + ao_sensor_errors = 1; + + /* Select continuous mode 2 (100Hz), 16 bit samples */ + + _ao_mpu9250_mag_reg_write(MPU9250_MAG_CNTL1, + (MPU9250_MAG_CNTL1_BIT_16 << MPU9250_MAG_CNTL1_BIT) | + (MPU9250_MAG_CNTL1_MODE_CONT_2 << MPU9250_MAG_CNTL1_MODE)); + + /* Set i2c master to delay shadowing data until read is + * complete (avoids tearing the data) */ + + _ao_mpu9250_reg_write(MPU9250_I2C_MST_DELAY_CTRL, + (1 << MPU9250_I2C_MST_DELAY_CTRL_DELAY_ES_SHADOW) | + (0 << MPU9250_I2C_MST_DELAY_CTRL_I2C_SLV4_DLY_EN) | + (0 << MPU9250_I2C_MST_DELAY_CTRL_I2C_SLV3_DLY_EN) | + (0 << MPU9250_I2C_MST_DELAY_CTRL_I2C_SLV2_DLY_EN) | + (0 << MPU9250_I2C_MST_DELAY_CTRL_I2C_SLV1_DLY_EN) | + (0 << MPU9250_I2C_MST_DELAY_CTRL_I2C_SLV0_DLY_EN)); + + /* Set up i2c slave 0 to read the mag registers starting at HXL (3) */ + + _ao_mpu9250_reg_write(MPU9250_I2C_SLV0_ADDR, + (1 << 7) | MPU9250_MAG_ADDR); + + _ao_mpu9250_reg_write(MPU9250_I2C_SLV0_REG, + MPU9250_MAG_HXL); + + /* Byte swap so the mag values match the gyro/accel. Read 7 bytes + * to include the status register + */ + + _ao_mpu9250_reg_write(MPU9250_I2C_SLV0_CTRL, + (1 << MPU9250_I2C_SLV0_CTRL_I2C_SLV0_EN) | + (1 << MPU9250_I2C_SLV0_CTRL_I2C_SLV0_BYTE_SW) | + (0 << MPU9250_I2C_SLV0_CTRL_I2C_SLV0_REG_DIS) | + (1 << MPU9250_I2C_SLV0_CTRL_I2C_SLV0_GRP) | + (MPU9250_MAG_ST2 - MPU9250_MAG_HXL + 1) << MPU9250_I2C_SLV0_CTRL_I2C_SLV0_LENG); + /* Filter to about 100Hz, which also sets the gyro rate to 1000Hz */ _ao_mpu9250_reg_write(MPU9250_CONFIG, (MPU9250_CONFIG_FIFO_MODE_REPLACE << MPU9250_CONFIG_FIFO_MODE) | @@ -312,20 +430,15 @@ static void ao_mpu9250(void) { struct ao_mpu9250_sample sample; + /* ao_mpu9250_init already grabbed the SPI bus and mutex */ _ao_mpu9250_setup(); -#if AO_MPU9250_SPI ao_mpu9250_spi_put(); -#endif for (;;) { -#if AO_MPU9250_SPI ao_mpu9250_spi_get(); -#endif _ao_mpu9250_sample(&sample); -#if AO_MPU9250_SPI ao_mpu9250_spi_put(); -#endif ao_arch_block_interrupts(); ao_mpu9250_current = sample; AO_DATA_PRESENT(AO_DATA_MPU9250); @@ -339,15 +452,20 @@ static struct ao_task ao_mpu9250_task; static void ao_mpu9250_show(void) { - printf ("Accel: %7d %7d %7d Gyro: %7d %7d %7d\n", + printf ("Accel: %7d %7d %7d Gyro: %7d %7d %7d Mag: %7d %7d %7d\n", ao_mpu9250_current.accel_x, ao_mpu9250_current.accel_y, ao_mpu9250_current.accel_z, ao_mpu9250_current.gyro_x, ao_mpu9250_current.gyro_y, - ao_mpu9250_current.gyro_z); + ao_mpu9250_current.gyro_z, + ao_mpu9250_current.mag_x, + ao_mpu9250_current.mag_y, + ao_mpu9250_current.mag_z); } +#if MPU9250_TEST + static void ao_mpu9250_read(void) { @@ -384,10 +502,52 @@ ao_mpu9250_write(void) ao_mpu9250_spi_put(); } +static void +ao_mpu9250_mag_read(void) +{ + uint8_t addr; + uint8_t val; + + ao_cmd_hex(); + if (ao_cmd_status != ao_cmd_success) + return; + addr = ao_cmd_lex_i; + ao_mpu9250_spi_get(); + val = _ao_mpu9250_mag_reg_read(addr); + ao_mpu9250_spi_put(); + printf("Addr %02x val %02x\n", addr, val); +} + +static void +ao_mpu9250_mag_write(void) +{ + uint8_t addr; + uint8_t val; + + ao_cmd_hex(); + if (ao_cmd_status != ao_cmd_success) + return; + addr = ao_cmd_lex_i; + ao_cmd_hex(); + if (ao_cmd_status != ao_cmd_success) + return; + val = ao_cmd_lex_i; + printf("Addr %02x val %02x\n", addr, val); + ao_mpu9250_spi_get(); + _ao_mpu9250_mag_reg_write(addr, val); + ao_mpu9250_spi_put(); +} + +#endif /* MPU9250_TEST */ + static const struct ao_cmds ao_mpu9250_cmds[] = { { ao_mpu9250_show, "I\0Show MPU9250 status" }, +#if MPU9250_TEST { ao_mpu9250_read, "R \0Read MPU9250 register" }, { ao_mpu9250_write, "W \0Write MPU9250 register" }, + { ao_mpu9250_mag_read, "G \0Read MPU9250 Mag register" }, + { ao_mpu9250_mag_write, "P \0Write MPU9250 Mag register" }, +#endif { 0, NULL } }; diff --git a/src/drivers/ao_mpu9250.h b/src/drivers/ao_mpu9250.h index df1be7c7..5e8e0885 100644 --- a/src/drivers/ao_mpu9250.h +++ b/src/drivers/ao_mpu9250.h @@ -130,6 +130,12 @@ #define MPU9250_I2C_SLV0_REG 0x26 #define MPU9250_I2C_SLV0_CTRL 0x27 +#define MPU9250_I2C_SLV0_CTRL_I2C_SLV0_EN 7 +#define MPU9250_I2C_SLV0_CTRL_I2C_SLV0_BYTE_SW 6 +#define MPU9250_I2C_SLV0_CTRL_I2C_SLV0_REG_DIS 5 +#define MPU9250_I2C_SLV0_CTRL_I2C_SLV0_GRP 4 +#define MPU9250_I2C_SLV0_CTRL_I2C_SLV0_LENG 0 + #define MPU9250_I2C_SLV1_ADDR 0x28 #define MPU9250_I2C_SLV1_REG 0x29 #define MPU9250_I2C_SLV1_CTRL 0x2a @@ -146,6 +152,11 @@ #define MPU9250_I2C_SLV4_REG 0x32 #define MPU9250_I2C_SLV4_DO 0x33 #define MPU9250_I2C_SLV4_CTRL 0x34 +#define MPU9250_I2C_SLV4_CTRL_I2C_SLV4_EN 7 +#define MPU9250_I2C_SLV4_CTRL_SLV4_DONE_INT_EN 6 +#define MPU9250_I2C_SLV4_CTRL_I2C_SLV4_REG_DIS 5 +#define MPU9250_I2C_SLV4_CTRL_I2C_MST_DLY 0 + #define MPU9250_I2C_SLV4_DI 0x35 #define MPU9250_I2C_MST_STATUS 0x36 @@ -179,6 +190,15 @@ #define MPU9250_GYRO_ZOUT_H 0x47 #define MPU9250_GYRO_ZOUT_L 0x48 +#define MPU9250_I2C_MST_DELAY_CTRL 0x67 + +#define MPU9250_I2C_MST_DELAY_CTRL_DELAY_ES_SHADOW 7 +#define MPU9250_I2C_MST_DELAY_CTRL_I2C_SLV4_DLY_EN 4 +#define MPU9250_I2C_MST_DELAY_CTRL_I2C_SLV3_DLY_EN 3 +#define MPU9250_I2C_MST_DELAY_CTRL_I2C_SLV2_DLY_EN 2 +#define MPU9250_I2C_MST_DELAY_CTRL_I2C_SLV1_DLY_EN 1 +#define MPU9250_I2C_MST_DELAY_CTRL_I2C_SLV0_DLY_EN 0 + #define MPU9250_SIGNAL_PATH_RESET 0x68 #define MPU9250_SIGNAL_PATH_RESET_GYRO_RESET 2 #define MPU9250_SIGNAL_PATH_RESET_ACCEL_RESET 1 @@ -212,6 +232,57 @@ #define MPU9250_WHO_AM_I 0x75 #define MPU9250_I_AM_9250 0x71 +/* AK8963 mag sensor on the I2C bus */ + +#define MPU9250_MAG_ADDR 0x0c + +#define MPU9250_MAG_WIA 0x00 +#define MPU9250_MAG_WIA_VALUE 0x48 + +#define MPU9250_MAG_INFO 0x01 +#define MPU9250_MAG_ST1 0x02 +#define MPU9250_MAG_ST1_DOR 1 +#define MPU9250_MAG_ST1_DRDY 0 + +#define MPU9250_MAG_HXL 0x03 +#define MPU9250_MAG_HXH 0x04 +#define MPU9250_MAG_HYL 0x05 +#define MPU9250_MAG_HYH 0x06 +#define MPU9250_MAG_HZL 0x07 +#define MPU9250_MAG_HZH 0x08 +#define MPU9250_MAG_ST2 0x09 +#define MPU9250_MAG_ST2_BITM 4 +#define MPU9250_MAG_ST2_HOFL 3 + +#define MPU9250_MAG_CNTL1 0x0a +#define MPU9250_MAG_CNTL1_MODE 0 +#define MPU9250_MAG_CNTL1_MODE_POWER_DOWN 0x0 +#define MPU9250_MAG_CNTL1_MODE_SINGLE 0x1 +#define MPU9250_MAG_CNTL1_MODE_CONT_1 0x2 /* 8Hz */ +#define MPU9250_MAG_CNTL1_MODE_CONT_2 0x6 /* 100Hz */ +#define MPU9250_MAG_CNTL1_MODE_EXTERNAL 0x4 +#define MPU9250_MAG_CNTL1_MODE_SELF_TEST 0x8 +#define MPU9250_MAG_CNTL1_MODE_FUSE_ACCESS 0xf + +#define MPU9250_MAG_CNTL1_BIT 4 +#define MPU9250_MAG_CNTL1_BIT_14 0 +#define MPU9250_MAG_CNTL1_BIT_16 1 + +#define MPU9250_MAG_CNTL2 0x0b +#define MPU9250_MAG_CNTL2_SRST 0 + +#define MPU9250_MAG_ASTC 0x0c +#define MPU9250_MAG_ASTC_SELF 6 + +#define MPU9250_MAG_TS1 0x0d +#define MPU9250_MAG_TS2 0x0e +#define MPU9250_MAG_I2CDIS 0x0f +#define MPU9250_MAG_I2CDIS_VALUE 0x1d + +#define MPU9250_MAG_ASAX 0x10 +#define MPU9250_MAG_ASAY 0x11 +#define MPU9250_MAG_ASAZ 0x12 + /* Self test acceleration is approximately 0.5g */ #define MPU9250_ST_ACCEL(full_scale) (32767 / ((full_scale) * 2)) -- cgit v1.2.3 From 992797db2158b23d46c496e5e223deeca28bf4c9 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 11 Dec 2017 12:23:00 -0800 Subject: doc: Note TeleMega v3.0 support in 1.8.3 relnotes Signed-off-by: Keith Packard --- doc/release-notes-1.8.3.inc | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/doc/release-notes-1.8.3.inc b/doc/release-notes-1.8.3.inc index b298bf3b..a612dd6b 100644 --- a/doc/release-notes-1.8.3.inc +++ b/doc/release-notes-1.8.3.inc @@ -2,13 +2,19 @@ :toc!: :doctype: article - Version 1.8.3 includes two important flight computer fixes, - changed KML export data for Tripoli Record reporting and some - updates to graph presentation and data downloading. + Version 1.8.3 includes support for TeleMega version 3.0 along + with two important flight computer fixes. This version also + changes KML export data to make Tripoli Record reporting + better and some updates to graph presentation and data + downloading. == AltOS - AltOS Bug Fixes + AltOS New Features + + * Support for TeleMega version 3.0 hardware. + + == AltOS Bug Fixes * Ground testing EasyMega and TeleMega additional pyro channels could result in a sticky 'fired' status which would @@ -19,6 +25,10 @@ == AltosUI and TeleGPS Applications + AltosUI New Features + + * Support for TeleMega version 3.0. + AltosUI and TeleGPS Changes * KML export now reports both barometric and GPS altitude data -- cgit v1.2.3 From 713e8ca6b6cfb29555d8d847e0bb2652cfe011ae Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 11 Dec 2017 12:23:29 -0800 Subject: Bump to version 1.8.3 Signed-off-by: Keith Packard --- configure.ac | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/configure.ac b/configure.ac index 6b922183..02fca439 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.2.1) +AC_INIT([altos], 1.8.3) ANDROID_VERSION=16 AC_CONFIG_SRCDIR([src/kernel/ao.h]) AM_INIT_AUTOMAKE([foreign dist-bzip2]) AM_MAINTAINER_MODE -RELEASE_DATE=2017-10-05 +RELEASE_DATE=2017-12-11 AC_SUBST(RELEASE_DATE) VERSION_DASH=`echo $VERSION | sed 's/\./-/g'` -- cgit v1.2.3 From 05efe58cb13b58292527668ca51639eaebe1112b Mon Sep 17 00:00:00 2001 From: Bdale Garbee Date: Mon, 11 Dec 2017 14:44:15 -0700 Subject: take telescience out of the routine builds --- src/Makefile | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Makefile b/src/Makefile index defeea96..03a5314d 100644 --- a/src/Makefile +++ b/src/Makefile @@ -39,7 +39,6 @@ ARMM3DIRS=\ telegps-v2.0 telegps-v2.0/flash-loader \ telelco-v0.2 telelco-v0.2/flash-loader \ telelco-v0.3 telelco-v0.3/flash-loader \ - telescience-v0.2 telescience-v0.2/flash-loader \ teledongle-v3.0 teledongle-v3.0/flash-loader \ teleballoon-v2.0 \ telebt-v3.0 telebt-v3.0/flash-loader \ @@ -56,7 +55,7 @@ ARMM0DIRS=\ micropeak-v2.0 micropeak-v2.0/flash-loader AVRDIRS=\ - telescience-v0.1 telescience-pwm micropeak nanopeak-v0.1 microkite + micropeak nanopeak-v0.1 microkite SUBDIRS= -- cgit v1.2.3 From 962df1f8c7f7ffbebe9b32d6ac363b333af606b3 Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 11 Dec 2017 13:47:54 -0800 Subject: altos: Remove more software for hardware prototypes These never saw the light of day. Signed-off-by: Keith Packard --- src/Makefile | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/src/Makefile b/src/Makefile index 03a5314d..8420b376 100644 --- a/src/Makefile +++ b/src/Makefile @@ -21,7 +21,6 @@ SDCCDIRS=\ teledongle-v0.2 \ telemini-v1.0 \ telebt-v1.0 \ - teleterra-v0.2 teleshield-v0.1 \ telefire-v0.1 telefire-v0.2 \ telerepeat-v1.0 @@ -33,7 +32,6 @@ ARMM3DIRS=\ telemega-v3.0 telemega-v3.0/flash-loader \ telemetrum-v2.0 telemetrum-v2.0/flash-loader \ telemetrum-v3.0 telemetrum-v3.0/flash-loader \ - megadongle-v0.1 megadongle-v0.1/flash-loader \ telegps-v0.3 telegps-v0.3/flash-loader \ telegps-v1.0 telegps-v1.0/flash-loader \ telegps-v2.0 telegps-v2.0/flash-loader \ @@ -48,14 +46,13 @@ ARMM3DIRS=\ ARMM0DIRS=\ easymini-v1.0 easymini-v1.0/flash-loader \ - chaoskey-v0.1 chaoskey-v0.1/flash-loader \ chaoskey-v1.0 chaoskey-v1.0/flash-loader \ telemini-v3.0 telemini-v3.0/flash-loader \ easymini-v2.0 easymini-v2.0/flash-loader \ micropeak-v2.0 micropeak-v2.0/flash-loader AVRDIRS=\ - micropeak nanopeak-v0.1 microkite + micropeak microkite SUBDIRS= -- cgit v1.2.3 From fa3ff3a089e4af88dd0cc9a9e92511a0ba4a8e0f Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 11 Dec 2017 14:08:32 -0800 Subject: altos: Actually store current MPU9250 data in data ring The ring is updated when the ADC finishes; all of the other sensor data needs to be copied in at that point. Signed-off-by: Keith Packard --- src/stm/ao_adc_stm.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/stm/ao_adc_stm.c b/src/stm/ao_adc_stm.c index c3cca5e4..24912bb2 100644 --- a/src/stm/ao_adc_stm.c +++ b/src/stm/ao_adc_stm.c @@ -57,6 +57,9 @@ static void ao_adc_done(int index) #endif #if HAS_MPU6000 ao_data_ring[ao_data_head].mpu6000 = ao_mpu6000_current; +#endif +#if HAS_MPU9250 + ao_data_ring[ao_data_head].mpu9250 = ao_mpu9250_current; #endif ao_data_ring[ao_data_head].tick = ao_tick_count; ao_data_head = ao_data_ring_next(ao_data_head); -- cgit v1.2.3 From 2efb997865ee46bf0e8d5145c95d051a7656222a Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 11 Dec 2017 14:42:45 -0800 Subject: altoslib: Keep old GPS values when updating data This way, updating satellite information doesn't drop all of the regular GPS data on the floor. Signed-off-by: Keith Packard --- altoslib/AltosCalData.java | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/altoslib/AltosCalData.java b/altoslib/AltosCalData.java index fdea5e21..03e2cbd7 100644 --- a/altoslib/AltosCalData.java +++ b/altoslib/AltosCalData.java @@ -241,6 +241,8 @@ public class AltosCalData { public AltosGPS gps_pad = null; + public AltosGPS prev_gps = null; + public double gps_pad_altitude = AltosLib.MISSING; public void set_cal_gps(AltosGPS gps) { @@ -251,6 +253,7 @@ public class AltosCalData { gps_pad_altitude = gps.alt; } temp_gps = null; + prev_gps = gps; } /* @@ -275,7 +278,7 @@ public class AltosCalData { public AltosGPS make_temp_cal_gps(int tick, boolean sats) { if (temp_gps == null) - temp_gps = new AltosGPS(); + temp_gps = new AltosGPS(prev_gps); if (sats) { if (tick != temp_gps_sat_tick) temp_gps.cc_gps_sat = null; -- cgit v1.2.3 From b4d78ad85e8f5b1bee78746d63bb4b069e087e5a Mon Sep 17 00:00:00 2001 From: Keith Packard Date: Mon, 11 Dec 2017 16:30:46 -0800 Subject: doc: Update release notes and docinfo for 1.8.3 Signed-off-by: Keith Packard --- doc/altusmetrum-docinfo.xml | 7 ++++--- doc/release-notes-1.8.3-docinfo.xml | 2 +- doc/release-notes-1.8.3.inc | 35 ++++++++++++++++++++++++++--------- doc/telegps-docinfo.xml | 9 +++++++++ 4 files changed, 40 insertions(+), 13 deletions(-) diff --git a/doc/altusmetrum-docinfo.xml b/doc/altusmetrum-docinfo.xml index 874c1dbd..3b0793b8 100644 --- a/doc/altusmetrum-docinfo.xml +++ b/doc/altusmetrum-docinfo.xml @@ -48,10 +48,11 @@ 1.8.3 - 12 Nove 2017 + 11 Dec 2017 - Support TeleGPS v2.0 hardware. Add accelerometer recalibration - UI. + Support TeleMega v3.0 hardware. Fix one firmware bug affecting + all flight computers and another two affecting TeleMega and + EasyMega. Several new AltosUI graphing features. diff --git a/doc/release-notes-1.8.3-docinfo.xml b/doc/release-notes-1.8.3-docinfo.xml index 91a03926..e0366586 100644 --- a/doc/release-notes-1.8.3-docinfo.xml +++ b/doc/release-notes-1.8.3-docinfo.xml @@ -8,7 +8,7 @@ Packard keithp@keithp.com -12 November 2017 +11 December 2017 2017 Bdale Garbee and Keith Packard diff --git a/doc/release-notes-1.8.3.inc b/doc/release-notes-1.8.3.inc index a612dd6b..4bc879ad 100644 --- a/doc/release-notes-1.8.3.inc +++ b/doc/release-notes-1.8.3.inc @@ -10,11 +10,11 @@ == AltOS - AltOS New Features + === AltOS New Features * Support for TeleMega version 3.0 hardware. - == AltOS Bug Fixes + === AltOS Bug Fixes * Ground testing EasyMega and TeleMega additional pyro channels could result in a sticky 'fired' status which would @@ -23,20 +23,37 @@ * Corrupted flight log records could prevent future flights from capturing log data. + * Fixed saving of pyro configuration that ended with + 'Descending'. + == AltosUI and TeleGPS Applications - AltosUI New Features + === AltosUI New Features * Support for TeleMega version 3.0. - AltosUI and TeleGPS Changes - - * KML export now reports both barometric and GPS altitude data - to make it more useful for Tripoli record reporting. - * Graph lines have improved appearance to make them easier to - distinguish. + distinguish. Markers may be placed at data points to show + captured recorded data values. + + * Graphing offers the ability to adjust the smoothing of + computed speed and acceleration data. * The download dialog now offers to graph new flights, checks for existing files to avoid overwriting data and reports if there are checksum errors in the downloaded data. + + === AltosUI/TeleGPS Bug Fixes + + * Restore TeleGPS tracking behavior. + + * Display flight computer call sign and serial number in + Monitor Idle mode instead of ground station values. + + === AltosUI and TeleGPS Changes + + * KML export now reports both barometric and GPS altitude data + to make it more useful for Tripoli record reporting. + + * CSV export now includes TeleMega/EasyMega pyro voltages and + tilt angle. diff --git a/doc/telegps-docinfo.xml b/doc/telegps-docinfo.xml index 1ef088fe..5e347cfd 100644 --- a/doc/telegps-docinfo.xml +++ b/doc/telegps-docinfo.xml @@ -37,6 +37,15 @@ + + 1.8.3 + 11 Dec 2017 + + New graphing features. Improve reliability of data + download. Update KML export to satisfy Tripoli Records board + requirements. + + 1.6.4 10 May 2016 -- cgit v1.2.3 From 9adf8b23aac8256f230b10adcab9dd323266caaa Mon Sep 17 00:00:00 2001 From: Bdale Garbee Date: Mon, 11 Dec 2017 21:33:21 -0700 Subject: TeleMega default is now v3.0 --- ao-bringup/test-telemega-v2.0 | 67 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 67 insertions(+) create mode 100755 ao-bringup/test-telemega-v2.0 diff --git a/ao-bringup/test-telemega-v2.0 b/ao-bringup/test-telemega-v2.0 new file mode 100755 index 00000000..0ac475a3 --- /dev/null +++ b/ao-bringup/test-telemega-v2.0 @@ -0,0 +1,67 @@ +#!/bin/sh + +VERSION=2.0 +PRODUCT=TeleMega +BASE=`echo $PRODUCT | tr 'A-Z' 'a-z'` + +echo "$PRODUCT-v$VERSION Test Program" +echo "Copyright 2014 by Keith Packard. Released under GPL v2" +echo +echo "Expectations:" +echo "\t$PRODUCT v$VERSION powered from USB" +echo + +ret=1 +ao-list | while read product serial dev; do + case "$product" in + "$PRODUCT-v$VERSION") + + echo "Testing $product $serial $dev" + + ./test-igniters $dev main drogue 3 0 1 2 + echo"" + + echo "Testing baro sensor" + ../ao-tools/ao-test-baro/ao-test-baro --tty="$dev" + + case $? in + 0) + ;; + *) + echo "failed" + exit 1 + esac + echo"" + + FLASHSIZE=8388608 + + echo "Testing flash" + ../ao-tools/ao-test-flash/ao-test-flash --tty="$dev" "$FLASHSIZE" + + case $? in + 0) + ;; + *) + echo "failed" + exit 1 + esac + echo"" + + echo "Testing GPS" + ../ao-tools/ao-test-gps/ao-test-gps --tty="$dev" + + case $? in + 0) + ;; + *) + echo "failed" + exit 1 + esac + echo"" + + echo "$PRODUCT-v$VERSION" serial "$serial" is ready to ship + echo "\007" + ret=0 + ;; + esac +done -- cgit v1.2.3