From 4ff4e26cd0bd258d880fde949d67b82d5076ceb4 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 28 May 2008 17:27:47 -0400 Subject: [PATCH] Initial commit. Already did some work. u8vector constructor works, it's actually just a parser hack that generates a string and the parse it. Since strings are stored as byte vectors, this gives the result we want. u8vector-ref also works, it's implemented as a library function. I added a primitive, which ended up being unnecessary, I'll get rid of it. --- library.scm | 360 +++++++ picobit-vm.c | 2533 ++++++++++++++++++++++++++++++++++++++++++++++++ picobit.scm | 2945 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ red-green.scm | 18 + robot.scm | 927 ++++++++++++++++++ test-arity.scm | 1 + test-u8.scm | 6 + 7 files changed, 6790 insertions(+) create mode 100644 library.scm create mode 100644 picobit-vm.c create mode 100644 picobit.scm create mode 100644 red-green.scm create mode 100644 robot.scm create mode 100644 test-arity.scm create mode 100644 test-u8.scm diff --git a/library.scm b/library.scm new file mode 100644 index 0000000..416926a --- /dev/null +++ b/library.scm @@ -0,0 +1,360 @@ +; File: "library.scm" + +(define number? + (lambda (x) + (#%number? x))) + +(define + + (lambda (x . rest) + (if (#%pair? rest) + (#%+-aux (#%+ x (#%car rest)) (#%cdr rest)) + x))) + +(define #%+-aux + (lambda (x rest) + (if (#%pair? rest) + (#%+-aux (#%+ x (#%car rest)) (#%cdr rest)) + x))) + +(define - + (lambda (x . rest) + (if (#%pair? rest) + (#%--aux (#%- x (#%car rest)) (#%cdr rest)) + (#%neg x)))) + +(define #%--aux + (lambda (x rest) + (if (#%pair? rest) + (#%--aux (#%- x (#%car rest)) (#%cdr rest)) + x))) + +(define * + (lambda (x . rest) + (if (#%pair? rest) + (#%*-aux (#%* x (#%car rest)) (#%cdr rest)) + x))) + +(define #%*-aux + (lambda (x rest) + (if (#%pair? rest) + (#%*-aux (#%* x (#%car rest)) (#%cdr rest)) + x))) + +(define quotient + (lambda (x y) + (#%quotient x y))) + +(define remainder + (lambda (x y) + (#%remainder x y))) + +(define = + (lambda (x y) + (#%= x y))) + +(define < + (lambda (x y) + (#%< x y))) + +(define <= + (lambda (x y) + (#%<= x y))) + +(define > + (lambda (x y) + (#%> x y))) + +(define >= + (lambda (x y) + (#%>= x y))) + +(define pair? + (lambda (x) + (#%pair? x))) + +(define cons + (lambda (x y) + (#%cons x y))) + +(define car + (lambda (x) + (#%car x))) + +(define cdr + (lambda (x) + (#%cdr x))) + +(define set-car! + (lambda (x y) + (#%set-car! x y))) + +(define set-cdr! + (lambda (x y) + (#%set-cdr! x y))) + +(define null? + (lambda (x) + (#%null? x))) + +(define eq? + (lambda (x y) + (#%eq? x y))) + +(define not + (lambda (x) + (#%not x))) + +(define list + (lambda lst lst)) + +(define length + (lambda (lst) + (#%length-aux lst 0))) + +(define #%length-aux + (lambda (lst n) + (if (#%pair? lst) + (#%length-aux lst (#%+ n 1)) + n))) + +(define append + (lambda (lst1 lst2) + (if (#%pair? lst1) + (#%cons (#%car lst1) (append (#%cdr lst1) lst2)) + lst2))) + +(define reverse + (lambda (lst) + (reverse-aux lst '()))) + +(define reverse-aux + (lambda (lst rev) + (if (#%pair? lst) + (reverse-aux (#%cdr lst) (#%cons (#%car lst) rev)) + rev))) + +(define list-ref + (lambda (lst i) + (if (#%= i 0) + (#%car lst) + (list-ref (#%cdr lst) (#%- i 1))))) + +(define list-set! + (lambda (lst i x) + (if (#%= i 0) + (#%set-car! lst x) + (list-set! (#%cdr lst) (#%- i 1) x)))) + +(define max + (lambda (x y) + (if (#%> x y) x y))) + +(define min + (lambda (x y) + (if (#%< x y) x y))) + +(define abs + (lambda (x) + (if (#%< x 0) (#%neg x) x))) + +(define modulo + (lambda (x y) + (#%remainder x y))) + +(define string + (lambda chars + (#%list->string chars))) + +(define string-length ;; TODO are all these string operations efficient ? they all convert to lists. Since we have the equivalent of a vector, isn't there a way to do better ? + (lambda (str) + (length (#%string->list str)))) + +(define string-append + (lambda (str1 str2) + (#%list->string (append (#%string->list str1) (#%string->list str2))))) + +(define substring + (lambda (str start end) + (#%list->string + (#%substring-aux2 + (#%substring-aux1 (#%string->list str) start) + (#%- end start))))) + +(define #%substring-aux1 + (lambda (lst n) + (if (#%>= n 1) ;; TODO had an off-by-one + (#%substring-aux1 (#%cdr lst) (#%- n 1)) + lst))) + +(define #%substring-aux2 + (lambda (lst n) + (if (#%>= n 1) ;; TODO had an off-by-one + (#%cons (#%car lst) (#%substring-aux2 (#%cdr lst) (#%- n 1))) + '()))) + +(define map + (lambda (f lst) + (if (#%pair? lst) + (#%cons (f (#%car lst)) + (map f (#%cdr lst))) + '()))) + +(define for-each + (lambda (f lst) + (if (#%pair? lst) + (begin + (f (#%car lst)) + (for-each f (#%cdr lst))) + #f))) + +(define call/cc + (lambda (receiver) + (let ((k (#%get-cont))) + (receiver + (lambda (r) + (#%return-to-cont k r)))))) + +(define root-k #f) +(define readyq #f) + +(define start-first-process + (lambda (thunk) + (set! root-k (#%get-cont)) + (set! readyq (#%cons #f #f)) + (#%set-cdr! readyq readyq) + (thunk))) + +(define spawn + (lambda (thunk) + (let* ((k (#%get-cont)) + (next (#%cons k (#%cdr readyq)))) + (#%set-cdr! readyq next) + (#%graft-to-cont root-k thunk)))) + +(define exit + (lambda () + (let ((next (#%cdr readyq))) + (if (#%eq? next readyq) + (#%halt) + (begin + (#%set-cdr! readyq (#%cdr next)) + (#%return-to-cont (#%car next) #f)))))) + +(define yield + (lambda () + (let ((k (#%get-cont))) + (#%set-car! readyq k) + (set! readyq (#%cdr readyq)) + (let ((next-k (#%car readyq))) + (#%set-car! readyq #f) + (#%return-to-cont next-k #f))))) + +(define clock + (lambda () + (#%clock))) + +(define light + (lambda () + (#%light))) + +(define putchar + (lambda (c) + (#%putchar c))) + +(define getchar + (lambda () + (or (#%getchar-wait 0) + (getchar)))) + +(define getchar-wait + (lambda (duration) + (#%getchar-wait duration))) + +(define sleep + (lambda (duration) + (#%sleep-aux (#%+ (#%clock) duration)))) + +(define #%sleep-aux + (lambda (wake-up) + (if (#%< (#%clock) wake-up) + (#%sleep-aux wake-up) + #f))) + +(define motor + (lambda (x y z) + (#%motor x y z))) + +(define led + (lambda (state) + (if (#%eq? state 'red) + (#%led 1) + (if (#%eq? state 'green) + (#%led 2) + (#%led 0))))) + +(define display + (lambda (x) + (if (#%string? x) + (for-each putchar (#%string->list x)) + (write x)))) + +(define write + (lambda (x) + (if (#%string? x) + (begin + (#%putchar #\") + (display x) + (#%putchar #\")) + (if (#%number? x) + (display (number->string x)) + (if (#%pair? x) + (begin + (#%putchar #\() + (write (#%car x)) + (#%write-list (#%cdr x))) + (if (#%symbol? x) + (display "#") + (display "#"))))))) + +(define #%write-list + (lambda (lst) + (if (#%null? lst) + (#%putchar #\)) + (if (#%pair? lst) + (begin + (#%putchar #\space) + (write (#%car lst)) + (#%write-list (#%cdr lst))) + (begin + (display " . ") + (write lst) + (#%putchar #\))))))) + +(define number->string + (lambda (n) + (#%list->string + (if (#%< n 0) + (#%cons #\- (#%number->string-aux (#%neg n) '())) + (#%number->string-aux n '()))))) + +(define #%number->string-aux + (lambda (n lst) + (let ((rest (#%cons (#%+ #\0 (#%remainder n 10)) lst))) + (if (#%< n 10) + rest + (#%number->string-aux (#%quotient n 10) rest))))) + +(define pp + (lambda (x) + (write x) + (#%putchar #\newline))) + +(define u8vector-ref ;; ADDED + (lambda (u8 i) + (#%car (#%substring-aux1 (#%string->list u8) i)))) + +(define u8vector-set! ;; ADDED + (lambda (u8 i val) + )) + +;; TODO u8vector-set! diff --git a/picobit-vm.c b/picobit-vm.c new file mode 100644 index 0000000..e161b97 --- /dev/null +++ b/picobit-vm.c @@ -0,0 +1,2533 @@ +/* file: "picobit-vm.c" */ + +/* + * Copyright 2004 by Marc Feeley, All Rights Reserved. + * + * History: + * + * 15/08/2004 Release of version 1 + */ + +#define DEBUG_not +#define DEBUG_GC_not + +/*---------------------------------------------------------------------------*/ + +typedef char int8; +typedef short int16; +typedef long int32; +typedef unsigned char uint8; +typedef unsigned short uint16; +typedef unsigned long uint32; + +/*---------------------------------------------------------------------------*/ + + +#ifdef __18CXX +#define ROBOT +#endif + +#ifdef HI_TECH_C +#define ROBOT +#endif + +#ifndef ROBOT +#define WORKSTATION +#endif + + +#ifdef __18CXX + +#include + +extern volatile near uint8 IR_TX_BUF[2+(8+2)+2]; +extern volatile near uint8 FW_EVENTS; +extern volatile near uint8 FW_OPS; +extern volatile near uint8 IR_TX_LENGTH; +extern volatile near uint8 IR_TX_LEDS; +extern volatile near uint8 IR_TX_CURRENT_LEDS; +extern volatile near uint8 IR_TX_POWER; +extern volatile near uint8 IR_TX_CURRENT_POWER; +extern volatile near uint8 IR_TX_SHIFT_REG; +extern volatile near uint8 IR_TX_PTR; +extern volatile near uint8 IR_TX_TIMEOUT; +extern volatile near uint8 IR_TX_WAIT_RANGE; +extern volatile near uint8 IR_TX_RETRY_COUNT; +extern volatile near uint8 IR_TX_CRC_HI; +extern volatile near uint8 IR_TX_CRC_LO; +extern volatile near uint8 IR_TX_HI4; +extern volatile near uint8 IR_TX_LO4; +extern volatile near uint8 INT_IR_STATE_HI; +extern volatile near uint8 INT_IR_STATE_LO; +extern volatile near uint8 INT_PCLATH; +extern volatile near uint8 INT_CODE; +extern volatile near uint8 IR_BIT_CLOCK; +extern volatile near uint8 CLOCK_UP; +extern volatile near uint8 CLOCK_HI; +extern volatile near uint8 CLOCK_LO; +extern volatile near uint8 RANDOM; +extern volatile near uint8 NODE_NUM; +extern volatile near uint8 IR_RX_SOURCE; +extern volatile near uint8 IR_RX_LENGTH; +extern volatile near uint8 IR_RX_BUF[2+(2+8)+2]; +extern volatile near uint8 IR_RX_CRC_HI; +extern volatile near uint8 IR_RX_CRC_LO; +extern volatile near uint8 IR_RX_HI4; +extern volatile near uint8 IR_RX_LO4; +extern volatile near uint8 DRIVE_A_MODE; +extern volatile near uint8 DRIVE_A_PWM; +extern volatile near uint8 DRIVE_B_MODE; +extern volatile near uint8 DRIVE_B_PWM; +extern volatile near uint8 DRIVE_C_MODE; +extern volatile near uint8 DRIVE_C_PWM; +extern volatile near uint8 MOTOR_ID; +extern volatile near uint8 FW_VALUE_UP; +extern volatile near uint8 MOTOR_ROT; +extern volatile near uint8 FW_VALUE_HI; +extern volatile near uint8 MOTOR_POW; +extern volatile near uint8 FW_VALUE_LO; +extern volatile near uint8 FW_VALUE_TMP; +extern volatile near uint8 FW_LAST_TX_TIME_LO; +extern volatile near uint8 IR_RX_SAMPLE_TIMER; +extern volatile near uint8 IR_RX_SHIFT_REG; +extern volatile near uint8 IR_RX_PREVIOUS; +extern volatile near uint8 IR_RX_PTR; +extern volatile near uint8 IR_RX_BYTE; +extern volatile near uint8 STDIO_TX_SEQ_NUM; +extern volatile near uint8 STDIO_RX_SEQ_NUM; +extern volatile near uint8 FW_TEMP1; + +extern void fw_clock_read (void); +extern void fw_motor (void); +extern void fw_light_read (void); +extern void fw_ir_tx (void); +extern void fw_ir_rx_stdio_char (void); +extern void fw_ir_tx_wait_ready (void); +extern void fw_ir_tx_stdio (void); +extern void program_mode (void); + +#endif + + +#ifdef HI_TECH_C + +#include + +static volatile near uint8 FW_VALUE_UP @ 0x33; +static volatile near uint8 FW_VALUE_HI @ 0x33; +static volatile near uint8 FW_VALUE_LO @ 0x33; + +#define ACTIVITY_LED1_LAT LATB +#define ACTIVITY_LED1_BIT 5 +#define ACTIVITY_LED2_LAT LATB +#define ACTIVITY_LED2_BIT 4 +static volatile near bit ACTIVITY_LED1 @ ((unsigned)&ACTIVITY_LED1_LAT*8)+ACTIVITY_LED1_BIT; +static volatile near bit ACTIVITY_LED2 @ ((unsigned)&ACTIVITY_LED2_LAT*8)+ACTIVITY_LED2_BIT; + +#endif + + +#ifdef WORKSTATION + +#include +#include + +#ifdef _WIN32 +#include +#include +#include +#else +#include +#endif + +#endif + + +/*---------------------------------------------------------------------------*/ + +#define WORD_BITS 8 + +#define CODE_START 0x2000 + +#define GLOVARS 16 + +#ifdef DEBUG +#define IF_TRACE(x) x +#define IF_GC_TRACE(x) +#else +#define IF_TRACE(x) +#define IF_GC_TRACE(x) +#endif + +/*---------------------------------------------------------------------------*/ + + +#ifdef __18CXX + +#define ERROR(msg) program_mode () +#define TYPE_ERROR(type) program_mode () + +#endif + + +#ifdef WORKSTATION + +#define ERROR(msg) error (msg) +#define TYPE_ERROR(type) type_error (type) + +void error (char *msg) +{ + printf ("ERROR: %s\n", msg); + exit (1); +} + +void type_error (char *type) +{ + printf ("ERROR: An argument of type %s was expected\n", type); + exit (1); +} + +#endif + + +/*---------------------------------------------------------------------------*/ + +#if WORD_BITS <= 8 +typedef uint8 word; +#else +typedef uint16 word; +#endif + +typedef uint16 ram_addr; +typedef uint16 rom_addr; + +typedef word obj; + +/*---------------------------------------------------------------------------*/ + + +#define MIN_RAM_ENCODING 128 +#define MAX_RAM_ENCODING 255 + +#define RAM_BYTES ((MAX_RAM_ENCODING - MIN_RAM_ENCODING + 1)*4) + + +#if WORD_BITS == 8 +#define OBJ_TO_RAM_ADDR(o,f) (((ram_addr)((uint8)(o) - MIN_RAM_ENCODING) << 2) + (f)) +#define OBJ_TO_ROM_ADDR(o,f) (((rom_addr)((uint8)(o) - MIN_ROM_ENCODING) << 2) + (CODE_START + 4 + (f))) +#endif + + +#ifdef __18CXX + +#define ram_get(a) *(uint8*)(a+0x200) +#define ram_set(a,x) *(uint8*)(a+0x200) = (x) + +#endif + + +#ifdef WORKSTATION + +uint8 ram_mem[RAM_BYTES]; + +#define ram_get(a) ram_mem[a] +#define ram_set(a,x) ram_mem[a] = (x) + +#endif + + +/*---------------------------------------------------------------------------*/ + +#ifdef __18CXX + +#if WORD_BITS == 8 +#endif + +uint8 rom_get (rom_addr a) +{ + return *(rom uint8*)a; +} + +#endif + + +#ifdef WORKSTATION + +#define ROM_BYTES 8192 + +uint8 rom_mem[ROM_BYTES] = +{ +#define RED_GREEN +#define PUTCHAR_LIGHT_not + +#ifdef RED_GREEN + 0xFB, 0xD7, 0x03, 0x00, 0x00, 0x00, 0x00, 0x32 +, 0x03, 0x00, 0x00, 0x00, 0x03, 0x00, 0x00, 0x00 +, 0x08, 0x50, 0x80, 0x16, 0xFE, 0xE8, 0x00, 0xFC +, 0x32, 0x80, 0x2D, 0xFE, 0xFC, 0x31, 0x80, 0x43 +, 0xFE, 0xFC, 0x33, 0x80, 0x2D, 0xFE, 0xFC, 0x31 +, 0x80, 0x43, 0xFE, 0x90, 0x16, 0x01, 0x20, 0xFC +, 0x32, 0xE3, 0xB0, 0x37, 0x09, 0xF3, 0xFF, 0x20 +, 0xFC, 0x33, 0xE3, 0xB0, 0x40, 0x0A, 0xF3, 0xFF +, 0x08, 0xF3, 0xFF, 0x01, 0x40, 0x21, 0xD1, 0x00 +, 0x02, 0xC0, 0x4C, 0x71, 0x01, 0x20, 0x50, 0x90 +, 0x51, 0x00, 0xF1, 0x40, 0xD8, 0xB0, 0x59, 0x90 +, 0x51, 0x00, 0xFF +#endif +#ifdef PUTCHAR_LIGHT + 0xFB, 0xD7, 0x00, 0x00, 0x80, 0x08, 0xFE, 0xE8 +, 0x00, 0xF6, 0xF5, 0x90, 0x08 +#endif +}; + +uint8 rom_get (rom_addr a) +{ + return rom_mem[a-CODE_START]; +} + +#endif + +obj globals[GLOVARS]; + +/*---------------------------------------------------------------------------*/ + +/* + OBJECT ENCODING: + + #f 0 + #t 1 + () 2 + fixnum n MIN_FIXNUM -> 3 ... MAX_FIXNUM -> 3 + (MAX_FIXNUM-MIN_FIXNUM) + rom object 4 + (MAX_FIXNUM-MIN_FIXNUM) ... MIN_RAM_ENCODING-1 + ram object MIN_RAM_ENCODING ... 255 + + layout of memory allocated objects: + + bignum n 00000000 uuuuuuuu hhhhhhhh llllllll (24 bit signed integer) + + triplet 00000001 *first** *second* *third** + + pair 00000010 **car*** **cdr*** 00000000 + + symbol 00000011 00000000 00000000 00000000 + + string 00000100 *chars** 00000000 00000000 + + vector 00000101 *elems** 00000000 00000000 + + closure 00aaaaaa xxxxxxxx yyyyyyyy aaaaaaaa 0x5ff procedure has n parameters (no rest parameter) + n = -128 to -1 -> procedure has -n parameters, the last is + a rest parameter +*/ + +#define OBJ_FALSE 0 +#define OBJ_TRUE 1 +#define OBJ_NULL 2 + +#define MIN_FIXNUM_ENCODING 3 +#define MIN_FIXNUM (-5) +#define MAX_FIXNUM 40 +#define MIN_ROM_ENCODING (MIN_FIXNUM_ENCODING+MAX_FIXNUM-MIN_FIXNUM+1) + +#define ENCODE_FIXNUM(n) ((obj)(n) + (MIN_FIXNUM_ENCODING - MIN_FIXNUM)) +#define DECODE_FIXNUM(o) ((int32)(o) - (MIN_FIXNUM_ENCODING - MIN_FIXNUM)) + +#if WORD_BITS == 8 +#define IN_RAM(o) ((o) >= MIN_RAM_ENCODING) +#define IN_ROM(o) ((int8)(o) >= MIN_ROM_ENCODING) +#endif + +#define BIGNUM_FIELD0 0 +#define RAM_BIGNUM(o) (ram_get_field0 (o) == BIGNUM_FIELD0) +#define ROM_BIGNUM(o) (rom_get_field0 (o) == BIGNUM_FIELD0) + +#define TRIPLET_FIELD0 1 +#define RAM_TRIPLET(o) (ram_get_field0 (o) == TRIPLET_FIELD0) +#define ROM_TRIPLET(o) (rom_get_field0 (o) == TRIPLET_FIELD0) + +#define PAIR_FIELD0 2 +#define RAM_PAIR(o) (ram_get_field0 (o) == PAIR_FIELD0) +#define ROM_PAIR(o) (rom_get_field0 (o) == PAIR_FIELD0) + +#define SYMBOL_FIELD0 3 +#define RAM_SYMBOL(o) (ram_get_field0 (o) == SYMBOL_FIELD0) +#define ROM_SYMBOL(o) (rom_get_field0 (o) == SYMBOL_FIELD0) + +#define STRING_FIELD0 4 +#define RAM_STRING(o) (ram_get_field0 (o) == STRING_FIELD0) +#define ROM_STRING(o) (rom_get_field0 (o) == STRING_FIELD0) + +#define VECTOR_FIELD0 5 +#define RAM_VECTOR(o) (ram_get_field0 (o) == VECTOR_FIELD0) +#define ROM_VECTOR(o) (rom_get_field0 (o) == VECTOR_FIELD0) + +#define PROCEDURE_FIELD0 6 +#define RAM_PROCEDURE(o) (ram_get_field0 (o) >= PROCEDURE_FIELD0) +#define ROM_PROCEDURE(o) (rom_get_field0 (o) >= PROCEDURE_FIELD0) + +/*---------------------------------------------------------------------------*/ + +#define RAM_GET_FIELD0_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,0)) +#define RAM_SET_FIELD0_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,0), val) +#define ROM_GET_FIELD0_MACRO(o) rom_get (OBJ_TO_ROM_ADDR(o,0)) + +#define RAM_GET_GC_TAGS_MACRO(o) (RAM_GET_FIELD0_MACRO(o) & 0xc0) +#define RAM_SET_GC_TAGS_MACRO(o,tags) \ +RAM_SET_FIELD0_MACRO(o,(RAM_GET_FIELD0_MACRO(o) & 0x3f) | (tags)) + +#if WORD_BITS == 8 +#define RAM_GET_FIELD1_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,1)) +#define RAM_GET_FIELD2_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,2)) +#define RAM_GET_FIELD3_MACRO(o) ram_get (OBJ_TO_RAM_ADDR(o,3)) +#define RAM_SET_FIELD1_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,1), val) +#define RAM_SET_FIELD2_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,2), val) +#define RAM_SET_FIELD3_MACRO(o,val) ram_set (OBJ_TO_RAM_ADDR(o,3), val) +#define ROM_GET_FIELD1_MACRO(o) rom_get (OBJ_TO_ROM_ADDR(o,1)) +#define ROM_GET_FIELD2_MACRO(o) rom_get (OBJ_TO_ROM_ADDR(o,2)) +#define ROM_GET_FIELD3_MACRO(o) rom_get (OBJ_TO_ROM_ADDR(o,3)) +#endif + +#if WORD_BITS == 10 +#define RAM_GET_FIELD1_MACRO(o) \ +(ram_get (OBJ_TO_RAM_ADDR(o,1)) + ((RAM_GET_FIELD0_MACRO(o) & 0x03)<<8)) +#define RAM_GET_FIELD2_MACRO(o) \ +(ram_get (OBJ_TO_RAM_ADDR(o,2)) + ((RAM_GET_FIELD0_MACRO(o) & 0x0c)<<6)) +#define RAM_GET_FIELD3_MACRO(o) \ +(ram_get (OBJ_TO_RAM_ADDR(o,3)) + ((RAM_GET_FIELD0_MACRO(o) & 0x30)<<4)) +#define RAM_SET_FIELD1_MACRO(o,val) \ +do { \ + ram_set (OBJ_TO_RAM_ADDR(o,1), (val) & 0xff); \ + RAM_SET_FIELD0_MACRO(o,(RAM_GET_FIELD0_MACRO(o) & 0xfc) + (((val) >> 8) & 0x03)); \ + } while (0) +#define RAM_SET_FIELD2_MACRO(o,val) \ +do { \ + ram_set (OBJ_TO_RAM_ADDR(o,2), (val) & 0xff); \ + RAM_SET_FIELD0_MACRO(o,(RAM_GET_FIELD0_MACRO(o) & 0xf3) + (((val) >> 6) & 0x0c)); \ + } while (0) +#define RAM_SET_FIELD3_MACRO(o,val) \ +do { \ + ram_set (OBJ_TO_RAM_ADDR(o,3), (val) & 0xff); \ + RAM_SET_FIELD0_MACRO(o,(RAM_GET_FIELD0_MACRO(o) & 0xcf) + (((val) >> 4) & 0x30)); \ + } while (0) +#define ROM_GET_FIELD1_MACRO(o) \ +(rom_get (OBJ_TO_ROM_ADDR(o,1)) + ((ROM_GET_FIELD0_MACRO(o) & 0x03)<<8)) +#define ROM_GET_FIELD2_MACRO(o) \ +(rom_get (OBJ_TO_ROM_ADDR(o,2)) + ((ROM_GET_FIELD0_MACRO(o) & 0x0c)<<6)) +#define ROM_GET_FIELD3_MACRO(o) \ +(rom_get (OBJ_TO_ROM_ADDR(o,3)) + ((ROM_GET_FIELD0_MACRO(o) & 0x30)<<4)) +#endif + +uint8 ram_get_gc_tags (obj o) { return RAM_GET_GC_TAGS_MACRO(o); } +void ram_set_gc_tags (obj o, uint8 tags) { RAM_SET_GC_TAGS_MACRO(o,tags); } +uint8 ram_get_field0 (obj o) { return RAM_GET_FIELD0_MACRO(o); } +obj ram_get_field1 (obj o) { return RAM_GET_FIELD1_MACRO(o); } +obj ram_get_field2 (obj o) { return RAM_GET_FIELD2_MACRO(o); } +obj ram_get_field3 (obj o) { return RAM_GET_FIELD3_MACRO(o); } +void ram_set_field0 (obj o, uint8 val) { RAM_SET_FIELD0_MACRO(o,val); } +void ram_set_field1 (obj o, word val) { RAM_SET_FIELD1_MACRO(o,val); } +void ram_set_field2 (obj o, word val) { RAM_SET_FIELD2_MACRO(o,val); } +void ram_set_field3 (obj o, word val) { RAM_SET_FIELD3_MACRO(o,val); } +uint8 rom_get_field0 (obj o) { return ROM_GET_FIELD0_MACRO(o); } +obj rom_get_field1 (obj o) { return ROM_GET_FIELD1_MACRO(o); } +obj rom_get_field2 (obj o) { return ROM_GET_FIELD2_MACRO(o); } +obj rom_get_field3 (obj o) { return ROM_GET_FIELD3_MACRO(o); } + +obj get_global (uint8 i) +{ + return globals[i]; +} + +void set_global (uint8 i, obj o) +{ + globals[i] = o; +} + +/*---------------------------------------------------------------------------*/ + +/* Interface to GC */ + +/* GC tags are in the top 2 bits of field 0 */ + +#define GC_TAG_0_LEFT (3<<6) +#define GC_TAG_1_LEFT (2<<6) +#define GC_TAG_2_LEFT (1<<6) +#define GC_TAG_UNMARKED (0<<6) /* must be 0 */ + +/* Number of object fields of objects in ram */ + +#define HAS_3_OBJECT_FIELDS(field0) ((field0) == TRIPLET_FIELD0) +#define HAS_2_OBJECT_FIELDS(field0) ((field0) > TRIPLET_FIELD0) +#define HAS_1_OBJECT_FIELD(field0) 0 + +#define NIL OBJ_FALSE + +/*---------------------------------------------------------------------------*/ + +/* Garbage collector */ + +obj free_list; /* list of unused cells */ + +obj arg1; /* root set */ +obj arg2; +obj arg3; +obj arg4; +obj cont; +obj env; + +uint8 na; /* interpreter variables */ +rom_addr pc; +rom_addr entry; +uint8 bytecode; +uint8 bytecode_hi4; +uint8 bytecode_lo4; +uint8 field0; +int32 a1; +int32 a2; +int32 a3; + +void init_ram_heap (void) +{ + uint8 i; + obj o = MAX_RAM_ENCODING; + + free_list = 0; + + while (o >= MIN_RAM_ENCODING) + { + ram_set_gc_tags (o, GC_TAG_UNMARKED); + ram_set_field1 (o, free_list); + free_list = o; + o--; + } + + for (i=0; i>6, visit, ram_get_gc_tags (visit)>>6)); + + /* + * Four cases are possible: + * + * A) + * stack visit tag F1 F2 F3 + * NIL | +---+---+---+---+ + * +-> | ? | | | | + * +---+---+---+---+ + * + * B) + * tag F1 F2 F3 stack visit tag F1 F2 F3 + * +---+---+---+---+ | | +---+---+---+---+ + * | 1 | | | | <-+ +-> | ? | | | | + * +---+---+---+-|-+ +---+---+---+---+ + * <-----------------+ + * + * C) + * tag F1 F2 F3 stack visit tag F1 F2 F3 + * +---+---+---+---+ | | +---+---+---+---+ + * | 2 | | | | <-+ +-> | ? | | | | + * +---+---+-|-+---+ +---+---+---+---+ + * <-------------+ + * + * D) + * tag F1 F2 F3 stack visit tag F1 F2 F3 + * +---+---+---+---+ | | +---+---+---+---+ + * | 3 | | | | <-+ +-> | ? | | | | + * +---+-|-+---+---+ +---+---+---+---+ + * <---------+ + */ + + if (ram_get_gc_tags (visit) != GC_TAG_UNMARKED) + IF_GC_TRACE(printf ("case 1\n")); + else + { + field0 = ram_get_field0 (visit); + + if (HAS_3_OBJECT_FIELDS(field0)) + { + IF_GC_TRACE(printf ("case 2\n")); + + visit_field3: + + temp = ram_get_field3 (visit); + + if (IN_RAM(temp)) + { + IF_GC_TRACE(printf ("case 3\n")); + ram_set_gc_tags (visit, GC_TAG_2_LEFT); + ram_set_field3 (visit, stack); + goto push; + } + + IF_GC_TRACE(printf ("case 4\n")); + + goto visit_field2; + } + + if (HAS_2_OBJECT_FIELDS(field0)) + { + IF_GC_TRACE(printf ("case 5\n")); + + visit_field2: + + temp = ram_get_field2 (visit); + + if (IN_RAM(temp)) + { + IF_GC_TRACE(printf ("case 6\n")); + ram_set_gc_tags (visit, GC_TAG_1_LEFT); + ram_set_field2 (visit, stack); + goto push; + } + + IF_GC_TRACE(printf ("case 7\n")); + + goto visit_field1; + } + + if (HAS_1_OBJECT_FIELD(field0)) + { + IF_GC_TRACE(printf ("case 8\n")); + + visit_field1: + + temp = ram_get_field1 (visit); + + if (IN_RAM(temp)) + { + IF_GC_TRACE(printf ("case 9\n")); + ram_set_gc_tags (visit, GC_TAG_0_LEFT); + ram_set_field1 (visit, stack); + goto push; + } + + IF_GC_TRACE(printf ("case 10\n")); + } + else + IF_GC_TRACE(printf ("case 11\n")); + + ram_set_gc_tags (visit, GC_TAG_0_LEFT); + } + + pop: + + IF_GC_TRACE(printf ("pop stack=%d (tag=%d) visit=%d (tag=%d)\n", stack, ram_get_gc_tags (stack)>>6, visit, ram_get_gc_tags (visit)>>6)); + + if (stack != NIL) + { + if (ram_get_gc_tags (stack) == GC_TAG_2_LEFT) + { + IF_GC_TRACE(printf ("case 12\n")); + + temp = ram_get_field3 (stack); /* pop through field 3 */ + ram_set_field3 (stack, visit); + visit = stack; + stack = temp; + + goto visit_field2; + } + + if (ram_get_gc_tags (stack) == GC_TAG_1_LEFT) + { + IF_GC_TRACE(printf ("case 13\n")); + + temp = ram_get_field2 (stack); /* pop through field 2 */ + ram_set_field2 (stack, visit); + visit = stack; + stack = temp; + + goto visit_field1; + } + + IF_GC_TRACE(printf ("case 14\n")); + + temp = ram_get_field1 (stack); /* pop through field 1 */ + ram_set_field1 (stack, visit); + visit = stack; + stack = temp; + + goto pop; + } + } +} + +#ifdef DEBUG_GC +int max_live = 0; +#endif + +void sweep (void) +{ + /* sweep phase */ + +#ifdef DEBUG_GC + int n = 0; +#endif + + obj visit = MAX_RAM_ENCODING; + + free_list = 0; + + while (visit >= MIN_RAM_ENCODING) + { + if (ram_get_gc_tags (visit) == GC_TAG_UNMARKED) /* unmarked? */ + { + ram_set_field1 (visit, free_list); + free_list = visit; + } + else + { + ram_set_gc_tags (visit, GC_TAG_UNMARKED); +#ifdef DEBUG_GC + n++; +#endif + } + visit--; + } + +#ifdef DEBUG_GC + if (n > max_live) + { + max_live = n; + printf ("**************** memory needed = %d\n", max_live+1); + fflush (stdout); + } +#endif +} + +void gc (void) +{ + uint8 i; + + mark (arg1); + mark (arg2); + mark (arg3); + mark (arg4); + mark (cont); + mark (env); + + for (i=0; i= 128) + return ((int32)((((int16)u - 256) << 8) + h) << 8) + l; + + return ((int32)(((int16)u << 8) + h) << 8) + l; +} + +obj encode_int (int32 n) +{ + if (n >= MIN_FIXNUM && n <= MAX_FIXNUM) + return ENCODE_FIXNUM(n); + + return alloc_ram_cell_init (BIGNUM_FIELD0, n >> 16, n >> 8, n); +} + +/*---------------------------------------------------------------------------*/ + +#ifdef WORKSTATION + +void show (obj o) +{ +#if 0 + printf ("[%d]", o); +#endif + + if (o == OBJ_FALSE) + printf ("#f"); + else if (o == OBJ_TRUE) + printf ("#t"); + else if (o == OBJ_NULL) + printf ("()"); + else if (o <= (MIN_FIXNUM_ENCODING + (MAX_FIXNUM - MIN_FIXNUM))) + printf ("%d", DECODE_FIXNUM(o)); + else + { + uint8 field0; + + if (IN_RAM(o)) + field0 = ram_get_field0 (o); + else + field0 = rom_get_field0 (o); + + if (field0 == BIGNUM_FIELD0) + printf ("%d", decode_int (o)); + else if (field0 == TRIPLET_FIELD0) + printf ("#"); + else if (field0 == PAIR_FIELD0) + { + obj car; + obj cdr; + + if (IN_RAM(o)) + car = ram_get_field1 (o); + else + car = rom_get_field1 (o); + + if (IN_RAM(o)) + cdr = ram_get_field2 (o); + else + cdr = rom_get_field2 (o); + + printf ("("); + + loop: + + show (car); + + if (cdr == OBJ_NULL) + printf (")"); + else if ((IN_RAM(cdr) ? ram_get_field0 (cdr) : rom_get_field0 (cdr)) + == PAIR_FIELD0) + { + if (IN_RAM(cdr)) + car = ram_get_field1 (cdr); + else + car = rom_get_field1 (cdr); + + if (IN_RAM(cdr)) + cdr = ram_get_field2 (cdr); + else + cdr = rom_get_field2 (cdr); + + printf (" "); + goto loop; + } + else + { + printf (" . "); + show (cdr); + printf (")"); + } + } + else if (field0 == SYMBOL_FIELD0) + printf ("#"); + else if (field0 == STRING_FIELD0) + printf ("#"); + else if (field0 == VECTOR_FIELD0) + printf ("#"); + else + { + obj env; + obj parent_cont; + rom_addr pc; + + if (IN_RAM(o)) + env = ram_get_field1 (o); + else + env = rom_get_field1 (o); + + if (IN_RAM(o)) + parent_cont = ram_get_field2 (o); + else + parent_cont = rom_get_field2 (o); + + if (IN_RAM(o)) + pc = ((rom_addr)(field0 + ((CODE_START>>8) - PROCEDURE_FIELD0)) << 8) + ram_get_field3 (o); + else + pc = ((rom_addr)(field0 + ((CODE_START>>8) - PROCEDURE_FIELD0)) << 8) + rom_get_field3 (o); + + printf ("{0x%04x ", pc); + show (env); + printf (" "); + show (parent_cont); + printf ("}"); + } + } + + fflush (stdout); +} + +void show_state (rom_addr pc) +{ + printf ("pc=0x%04x bytecode=0x%02x env=", pc, rom_get (pc)); + show (env); + printf (" cont="); + show (cont); + printf ("\n"); + fflush (stdout); +} + +void print (obj o) +{ + show (o); + printf ("\n"); + fflush (stdout); +} + +#endif + +/*---------------------------------------------------------------------------*/ + +/* Integer operations */ + +#define encode_bool(x) ((obj)(x)) + +void prim_numberp (void) +{ + if (arg1 >= MIN_FIXNUM_ENCODING + && arg1 <= (MIN_FIXNUM_ENCODING + (MAX_FIXNUM - MIN_FIXNUM))) + arg1 = OBJ_TRUE; + else + { + if (IN_RAM(arg1)) + arg1 = encode_bool (RAM_BIGNUM(arg1)); + else if (IN_ROM(arg1)) + arg1 = encode_bool (ROM_BIGNUM(arg1)); + else + arg1 = OBJ_FALSE; + } +} + +void decode_2_int_args (void) +{ + a1 = decode_int (arg1); + a2 = decode_int (arg2); +} + +void prim_add (void) +{ + decode_2_int_args (); + arg1 = encode_int (a1 + a2); + arg2 = OBJ_FALSE; +} + +void prim_sub (void) +{ + decode_2_int_args (); + arg1 = encode_int (a1 - a2); + arg2 = OBJ_FALSE; +} + +void prim_mul (void) +{ + decode_2_int_args (); + arg1 = encode_int (a1 * a2); + arg2 = OBJ_FALSE; +} + +void prim_div (void) +{ + decode_2_int_args (); + if (a2 == 0) + ERROR("divide by 0"); + arg1 = encode_int (a1 / a2); + arg2 = OBJ_FALSE; +} + +void prim_rem (void) +{ + decode_2_int_args (); + if (a2 == 0) + ERROR("divide by 0"); + arg1 = encode_int (a1 % a2); + arg2 = OBJ_FALSE; +} + +void prim_neg (void) +{ + a1 = decode_int (arg1); + arg1 = encode_int (- a1); +} + +void prim_eq (void) +{ + decode_2_int_args (); + arg1 = encode_bool (a1 == a2); + arg2 = OBJ_FALSE; +} + +void prim_lt (void) +{ + decode_2_int_args (); + arg1 = encode_bool (a1 < a2); + arg2 = OBJ_FALSE; +} + +void prim_le (void) +{ + decode_2_int_args (); + arg1 = encode_bool (a1 <= a2); + arg2 = OBJ_FALSE; +} + +void prim_gt (void) +{ + decode_2_int_args (); + arg1 = encode_bool (a1 > a2); + arg2 = OBJ_FALSE; +} + +void prim_ge (void) +{ + decode_2_int_args (); + arg1 = encode_bool (a1 >= a2); + arg2 = OBJ_FALSE; +} + +/*---------------------------------------------------------------------------*/ + +/* List operations */ + +void prim_pairp (void) +{ + if (IN_RAM(arg1)) + arg1 = encode_bool (RAM_PAIR(arg1)); + else if (IN_ROM(arg1)) + arg1 = encode_bool (ROM_PAIR(arg1)); + else + arg1 = OBJ_FALSE; +} + +obj cons (obj car, obj cdr) +{ + return alloc_ram_cell_init (PAIR_FIELD0, car, cdr, 0); +} + +void prim_cons (void) +{ + arg1 = cons (arg1, arg2); + arg2 = OBJ_FALSE; +} + +void prim_car (void) +{ + if (IN_RAM(arg1)) + { + if (!RAM_PAIR(arg1)) + TYPE_ERROR("pair"); + + arg1 = ram_get_field1 (arg1); + } + else if (IN_ROM(arg1)) + { + if (!ROM_PAIR(arg1)) + TYPE_ERROR("pair"); + + arg1 = rom_get_field1 (arg1); + } + else + TYPE_ERROR("pair"); +} + +void prim_cdr (void) +{ + if (IN_RAM(arg1)) + { + if (!RAM_PAIR(arg1)) + TYPE_ERROR("pair"); + + arg1 = ram_get_field2 (arg1); + } + else if (IN_ROM(arg1)) + { + if (!ROM_PAIR(arg1)) + TYPE_ERROR("pair"); + + arg1 = rom_get_field2 (arg1); + } + else + TYPE_ERROR("pair"); +} + +void prim_set_car (void) +{ + if (IN_RAM(arg1)) + { + if (!RAM_PAIR(arg1)) + TYPE_ERROR("pair"); + + ram_set_field1 (arg1, arg2); + arg1 = OBJ_FALSE; + arg2 = OBJ_FALSE; + } + else + TYPE_ERROR("pair"); +} + +void prim_set_cdr (void) +{ + if (IN_RAM(arg1)) + { + if (!RAM_PAIR(arg1)) + TYPE_ERROR("pair"); + + ram_set_field2 (arg1, arg2); + arg1 = OBJ_FALSE; + arg2 = OBJ_FALSE; + } + else + TYPE_ERROR("pair"); +} + +void prim_nullp (void) +{ + arg1 = encode_bool (arg1 == OBJ_NULL); +} + +/*---------------------------------------------------------------------------*/ + +/* Miscellaneous operations */ + +void prim_eqp (void) +{ + arg1 = encode_bool (arg1 == arg2); + arg2 = OBJ_FALSE; +} + +void prim_not (void) +{ + arg1 = encode_bool (arg1 == OBJ_FALSE); +} + +void prim_symbolp (void) +{ + if (IN_RAM(arg1)) + arg1 = encode_bool (RAM_SYMBOL(arg1)); + else if (IN_ROM(arg1)) + arg1 = encode_bool (ROM_SYMBOL(arg1)); + else + arg1 = OBJ_FALSE; +} + +void prim_stringp (void) +{ + if (IN_RAM(arg1)) + arg1 = encode_bool (RAM_STRING(arg1)); + else if (IN_ROM(arg1)) + arg1 = encode_bool (ROM_STRING(arg1)); + else + arg1 = OBJ_FALSE; +} + +void prim_string2list (void) +{ + if (IN_RAM(arg1)) + { + if (!RAM_STRING(arg1)) + TYPE_ERROR("string"); + + arg1 = ram_get_field1 (arg1); + } + else if (IN_ROM(arg1)) + { + if (!ROM_STRING(arg1)) + TYPE_ERROR("string"); + + arg1 = rom_get_field1 (arg1); + } + else + TYPE_ERROR("string"); +} + +void prim_list2string (void) +{ + arg1 = alloc_ram_cell_init (STRING_FIELD0, arg1, 0, 0); +} + +void prim_cast_int (void) /* ADDED */ +{ + arg1 = encode_int (arg1); +} + + +/*---------------------------------------------------------------------------*/ + +/* Robot specific operations */ + + +void prim_print (void) +{ +#ifdef __18CXX +#endif + +#ifdef WORKSTATION + + print (arg1); + +#endif + + arg1 = OBJ_FALSE; +} + + +int32 read_clock (void) +{ + int32 now = 0; + +#ifdef __18CXX + + fw_clock_read (); + + now = ((int32)(((int16)FW_VALUE_UP << 8) + FW_VALUE_HI) << 8) + FW_VALUE_LO; + +#endif + +#ifdef WORKSTATION + +#ifdef _WIN32 + + static int32 start = 0; + struct timeb tb; + + ftime (&tb); + + now = tb.time * 100 + tb.millitm / 10; + if (start == 0) + start = now; + now -= start; + +#else + + static int32 start = 0; + struct timeval tv; + + if (gettimeofday (&tv, NULL) == 0) + { + now = tv.tv_sec * 100 + tv.tv_usec / 10000; + if (start == 0) + start = now; + now -= start; + } + +#endif + +#endif + + return now; +} + + +void prim_clock (void) +{ + arg1 = encode_int (read_clock ()); +} + + +void prim_motor (void) +{ + decode_2_int_args (); + a3 = decode_int (arg3); + + if (a1 < 0 || a1 > 2 || a2 < -1 || a2 > 1 || a3 < -4 || a3 > 4) + ERROR("argument out of range to procedure \"motor\""); + +#ifdef __18CXX + + MOTOR_ID = a1; + MOTOR_ROT = a2; + MOTOR_POW = a3; + + fw_motor (); + +#endif + +#ifdef WORKSTATION + + printf ("motor %d -> rotation=%d power=%d\n", a1, a2, a3); + fflush (stdout); + +#endif + + arg1 = OBJ_FALSE; + arg2 = OBJ_FALSE; + arg3 = OBJ_FALSE; +} + + +void prim_led (void) +{ + a1 = decode_int (arg1); + + if (a1 < 0 || a1 > 2) + ERROR("argument out of range to procedure \"led\""); + +#ifdef __18CXX + + LATBbits.LATB5 = (a1 == 1); + LATBbits.LATB4 = (a1 == 2); + +#endif + +#ifdef HI_TECH_C + + ACTIVITY_LED1 = (a1 == 1); + ACTIVITY_LED2 = (a1 == 2); + +#endif + +#ifdef WORKSTATION + + printf ("led -> %s\n", (a1==1)?"red":(a1==2)?"green":"off"); + fflush (stdout); + +#endif + + arg1 = OBJ_FALSE; +} + + +void prim_getchar_wait (void) +{ + a1 = decode_int (arg1); + a1 = read_clock () + a1; + +#ifdef __18CXX + + arg1 = OBJ_FALSE; + + do + { + uint8 seq_num = STDIO_RX_SEQ_NUM; + + fw_ir_rx_stdio_char (); + + if (seq_num != STDIO_RX_SEQ_NUM) + { + arg1 = encode_int (FW_VALUE_LO); + break; + } + } while (read_clock () < a1); + +#endif + +#ifdef WORKSTATION + +#ifdef _WIN32 + + arg1 = OBJ_FALSE; + + do + { + if (_kbhit ()) + { + arg1 = encode_int (_getch ()); + break; + } + } while (read_clock () < a1); + + +#else + + arg1 = encode_int (getchar ()); + +#endif + +#endif +} + + +void prim_putchar (void) +{ + a1 = decode_int (arg1); + + if (a1 < 0 || a1 > 255) + ERROR("argument out of range to procedure \"putchar\""); + +#ifdef __18CXX + + fw_ir_tx_wait_ready (); + + IR_TX_BUF[2] = a1; + IR_TX_LENGTH = 1; + + fw_ir_tx_stdio (); + +#endif + +#ifdef WORKSTATION + + putchar (a1); + fflush (stdout); + +#endif + + arg1 = OBJ_FALSE; +} + + +void prim_light (void) +{ + uint8 light; + +#ifdef __18CXX + + fw_light_read (); + + light = FW_VALUE_LO; + +#endif + +#ifdef WORKSTATION + + light = read_clock () & 31; + + if (light > 15) light = 32 - light; + + light += 40; + +#endif + + arg1 = encode_int (light); +} + + +/*---------------------------------------------------------------------------*/ + +#ifdef WORKSTATION + +int hidden_fgetc (FILE *f) +{ + int c = fgetc (f); +#if 0 + printf ("{%d}",c); + fflush (stdout); +#endif + return c; +} + +#define fgetc(f) hidden_fgetc(f) + +void write_hex_nibble (int n) +{ + putchar ("0123456789ABCDEF"[n]); +} + +void write_hex (uint8 n) +{ + write_hex_nibble (n >> 4); + write_hex_nibble (n & 0x0f); +} + +int hex (int c) +{ + if (c >= '0' && c <= '9') + return (c - '0'); + + if (c >= 'A' && c <= 'F') + return (c - 'A' + 10); + + if (c >= 'a' && c <= 'f') + return (c - 'a' + 10); + + return -1; +} + +int read_hex_byte (FILE *f) +{ + int h1 = hex (fgetc (f)); + int h2 = hex (fgetc (f)); + + if (h1 >= 0 && h2 >= 0) + return (h1<<4) + h2; + + return -1; +} + +int read_hex_file (char *filename) +{ + int c; + FILE *f = fopen (filename, "r"); + int result = 0; + int len; + int a, a1, a2; + int t; + int b; + int i; + uint8 sum; + int hi16 = 0; + + for (i=0; i= 0 && adr < ROM_BYTES) + rom_mem[adr] = b; + + a = (a + 1) & 0xffff; + i++; + sum += b; + + goto next0; + } + } + else if (t == 1) + { + if (len != 0) + break; + } + else if (t == 4) + { + if (len != 2) + break; + + if ((a1 = read_hex_byte (f)) < 0 || + (a2 = read_hex_byte (f)) < 0) + break; + + sum += a1 + a2; + + hi16 = (a1<<8) + a2; + } + else + break; + + if ((b = read_hex_byte (f)) < 0) + break; + + sum = -sum; + + if (sum != b) + { + printf ("*** HEX file checksum error (expected 0x%02x)\n", sum); + break; + } + + c = fgetc (f); + + if ((c != '\r') && (c != '\n')) + break; + + if (t == 1) + { + result = 1; + break; + } + } + + if (result == 0) + printf ("*** HEX file syntax error\n"); + + fclose (f); + } + + return result; +} + +#endif + +/*---------------------------------------------------------------------------*/ + +#define FETCH_NEXT_BYTECODE() bytecode = rom_get (pc++) + +#define BEGIN_DISPATCH() \ +dispatch: \ + IF_TRACE(show_state (pc)); \ + FETCH_NEXT_BYTECODE(); \ + bytecode_hi4 = bytecode & 0xf0; \ + bytecode_lo4 = bytecode & 0x0f; \ + switch (bytecode_hi4 >> 4) { + +#define END_DISPATCH() } + +#define CASE(opcode) case (opcode>>4):; + +#define DISPATCH(); goto dispatch; + +#if 0 +#define pc FSR1 +#define sp FSR2 +#define bytecode TABLAT +#define bytecode_hi4 WREG +#endif + +#define PUSH_CONSTANT1 0x00 +#define PUSH_CONSTANT2 0x10 +#define PUSH_STACK1 0x20 +#define PUSH_STACK2 0x30 +#define PUSH_GLOBAL 0x40 +#define SET_GLOBAL 0x50 +#define CALL 0x60 +#define JUMP 0x70 +#define CALL_TOPLEVEL 0x80 +#define JUMP_TOPLEVEL 0x90 +#define GOTO 0xa0 +#define GOTO_IF_FALSE 0xb0 +#define CLOSURE 0xc0 +#define PRIM1 0xd0 +#define PRIM2 0xe0 +#define PRIM3 0xf0 + +#ifdef WORKSTATION + +char *prim_name[48] = +{ + "prim #%number?", + "prim #%+", + "prim #%-", + "prim #%*", + "prim #%quotient", + "prim #%remainder", + "prim #%neg", + "prim #%=", + "prim #%<", + "prim #%<=", + "prim #%>", + "prim #%>=", + "prim #%pair?", + "prim #%cons", + "prim #%car", + "prim #%cdr", + "prim #%set-car!", + "prim #%set-cdr!", + "prim #%null?", + "prim #%eq?", + "prim #%not", + "prim #%get-cont", + "prim #%graft-to-cont", + "prim #%return-to-cont", + "prim #%halt", + "prim #%symbol?", + "prim #%string?", + "prim #%string->list", + "prim #%list->string", + "prim #%cast-int", /* ADDED, was "prim #%prim29", */ + "prim #%prim30", + "prim #%prim31", + "prim #%print", + "prim #%clock", + "prim #%motor", + "prim #%led", + "prim #%getchar-wait", + "prim #%putchar", + "prim #%light", + "prim #%prim39", + "prim #%prim40", + "prim #%prim41", + "prim #%prim42", + "prim #%prim43", + "push-constant [long]", + "shift", + "pop", + "return", +}; + +#endif + +#define PUSH_ARG1() push_arg1 () +#define POP() pop() + +void push_arg1 (void) +{ + env = cons (arg1, env); + arg1 = OBJ_FALSE; +} + +obj pop (void) +{ + obj o = ram_get_field1 (env); + env = ram_get_field2 (env); + return o; +} + +void pop_procedure (void) +{ + arg1 = POP(); + + if (IN_RAM(arg1)) + { + field0 = ram_get_field0 (arg1); + + if (field0 < PROCEDURE_FIELD0) + TYPE_ERROR("procedure"); + + entry = ((rom_addr)(field0 + ((CODE_START>>8) - PROCEDURE_FIELD0)) << 8) + ram_get_field3 (arg1); + } + else if (IN_ROM(arg1)) + { + field0 = rom_get_field0 (arg1); + + if (field0 < PROCEDURE_FIELD0) + TYPE_ERROR("procedure"); + + entry = ((rom_addr)(field0 + ((CODE_START>>8) - PROCEDURE_FIELD0)) << 8) + rom_get_field3 (arg1); + } + else + TYPE_ERROR("procedure"); +} + +void handle_arity_and_rest_param (void) +{ + uint8 np; + + np = rom_get (entry++); + + if ((np & 0x80) == 0) + { + if (na != np) + ERROR("wrong number of arguments"); + } + else + { + np = ~np; + + if (na < np) + ERROR("wrong number of arguments"); + + arg3 = OBJ_NULL; + + while (na > np) + { + arg4 = POP(); + + arg3 = cons (arg4, arg3); + arg4 = OBJ_FALSE; + + na--; + } + + arg1 = cons (arg3, arg1); + arg3 = OBJ_FALSE; + } +} + +void build_env (void) +{ + while (na != 0) + { + arg3 = POP(); + + arg1 = cons (arg3, arg1); + + na--; + } + + arg3 = OBJ_FALSE; +} + +void save_cont (void) +{ + cont = alloc_ram_cell_init ((uint8)(pc >> 8) - ((CODE_START>>8)-PROCEDURE_FIELD0), + env, + cont, + (uint8)pc); +} + +void interpreter (void) +{ + init_ram_heap (); + + pc = (CODE_START + 4) + ((rom_addr)rom_get (CODE_START+2) << 2); + + BEGIN_DISPATCH(); + + /***************************************************************************/ + CASE(PUSH_CONSTANT1); + + IF_TRACE(printf(" (push-constant "); show (bytecode_lo4); printf (")\n")); + + arg1 = bytecode_lo4; + + PUSH_ARG1(); + + DISPATCH(); + + /***************************************************************************/ + CASE(PUSH_CONSTANT2); + + IF_TRACE(printf(" (push-constant "); show (bytecode_lo4+16); printf (")\n")); + + arg1 = bytecode_lo4+16; + + PUSH_ARG1(); + + DISPATCH(); + + /***************************************************************************/ + CASE(PUSH_STACK1); + + IF_TRACE(printf(" (push-stack %d)\n", bytecode_lo4)); + + arg1 = env; + + while (bytecode_lo4 != 0) + { + arg1 = ram_get_field2 (arg1); + bytecode_lo4--; + } + + arg1 = ram_get_field1 (arg1); + + PUSH_ARG1(); + + DISPATCH(); + + /***************************************************************************/ + CASE(PUSH_STACK2); + + IF_TRACE(printf(" (push-stack %d)\n", bytecode_lo4+16)); + + bytecode_lo4 += 16; + + arg1 = env; + + while (bytecode_lo4 != 0) + { + arg1 = ram_get_field2 (arg1); + bytecode_lo4--; + } + + arg1 = ram_get_field1 (arg1); + + PUSH_ARG1(); + + DISPATCH(); + + /***************************************************************************/ + CASE(PUSH_GLOBAL); + + IF_TRACE(printf(" (push-global %d)\n", bytecode_lo4)); + + arg1 = get_global (bytecode_lo4); + + PUSH_ARG1(); + + DISPATCH(); + + /***************************************************************************/ + CASE(SET_GLOBAL); + + IF_TRACE(printf(" (set-global %d)\n", bytecode_lo4)); + + set_global (bytecode_lo4, POP()); + + DISPATCH(); + + /***************************************************************************/ + CASE(CALL); + + IF_TRACE(printf(" (call %d)\n", bytecode_lo4)); + + na = bytecode_lo4; + + pop_procedure (); + handle_arity_and_rest_param (); + build_env (); + save_cont (); + + env = arg1; + pc = entry; + + arg1 = OBJ_FALSE; + + DISPATCH(); + + /***************************************************************************/ + CASE(JUMP); + + IF_TRACE(printf(" (jump %d)\n", bytecode_lo4)); + + na = bytecode_lo4; + + pop_procedure (); + handle_arity_and_rest_param (); + build_env (); + + env = arg1; + pc = entry; + + arg1 = OBJ_FALSE; + + DISPATCH(); + + /***************************************************************************/ + CASE(CALL_TOPLEVEL); + + FETCH_NEXT_BYTECODE(); + + IF_TRACE(printf(" (call-toplevel 0x%04x)\n", ((rom_addr)(bytecode_lo4 + (CODE_START >> 8)) << 8) + bytecode)); + + entry = ((rom_addr)(bytecode_lo4 + (CODE_START >> 8)) << 8) + bytecode; + arg1 = OBJ_NULL; + + na = rom_get (entry++); + + build_env (); + save_cont (); + + env = arg1; + pc = entry; + + arg1 = OBJ_FALSE; + + DISPATCH(); + + /***************************************************************************/ + CASE(JUMP_TOPLEVEL); + + FETCH_NEXT_BYTECODE(); + + IF_TRACE(printf(" (jump-toplevel 0x%04x)\n", ((rom_addr)(bytecode_lo4 + (CODE_START >> 8)) << 8) + bytecode)); + + entry = ((rom_addr)(bytecode_lo4 + (CODE_START >> 8)) << 8) + bytecode; + arg1 = OBJ_NULL; + + na = rom_get (entry++); + + build_env (); + + env = arg1; + pc = entry; + + arg1 = OBJ_FALSE; + + DISPATCH(); + + /***************************************************************************/ + CASE(GOTO); + + FETCH_NEXT_BYTECODE(); + + IF_TRACE(printf(" (goto 0x%04x)\n", ((rom_addr)(bytecode_lo4 + (CODE_START >> 8)) << 8) + bytecode)); + + pc = ((rom_addr)(bytecode_lo4 + (CODE_START >> 8)) << 8) + bytecode; + + DISPATCH(); + + /***************************************************************************/ + CASE(GOTO_IF_FALSE); + + FETCH_NEXT_BYTECODE(); + + IF_TRACE(printf(" (goto-if-false 0x%04x)\n", ((rom_addr)(bytecode_lo4 + (CODE_START >> 8)) << 8) + bytecode)); + + if (POP() == OBJ_FALSE) + pc = ((rom_addr)(bytecode_lo4 + (CODE_START >> 8)) << 8) + bytecode; + + DISPATCH(); + + /***************************************************************************/ + CASE(CLOSURE); + + FETCH_NEXT_BYTECODE(); + + IF_TRACE(printf(" (closure 0x%04x)\n", ((rom_addr)(bytecode_lo4 + (CODE_START >> 8)) << 8) + bytecode)); + + arg2 = POP(); + arg3 = POP(); + + entry = ((rom_addr)bytecode_lo4 << 8) + bytecode; + + arg1 = alloc_ram_cell_init ((uint8)(entry >> 8) + PROCEDURE_FIELD0, + arg3, + arg2, + (uint8)entry); + + PUSH_ARG1(); + + arg2 = OBJ_FALSE; + arg3 = OBJ_FALSE; + + DISPATCH(); + + /***************************************************************************/ + CASE(PRIM1); + + IF_TRACE(printf(" (%s)\n", prim_name[bytecode_lo4])); + + switch (bytecode_lo4) + { + case 0: + arg1 = POP(); prim_numberp (); PUSH_ARG1(); break; + case 1: + arg2 = POP(); arg1 = POP(); prim_add (); PUSH_ARG1(); break; + case 2: + arg2 = POP(); arg1 = POP(); prim_sub (); PUSH_ARG1(); break; + case 3: + arg2 = POP(); arg1 = POP(); prim_mul (); PUSH_ARG1(); break; + case 4: + arg2 = POP(); arg1 = POP(); prim_div (); PUSH_ARG1(); break; + case 5: + arg2 = POP(); arg1 = POP(); prim_rem (); PUSH_ARG1(); break; + case 6: + arg1 = POP(); prim_neg (); PUSH_ARG1(); break; + case 7: + arg2 = POP(); arg1 = POP(); prim_eq (); PUSH_ARG1(); break; + case 8: + arg2 = POP(); arg1 = POP(); prim_lt (); PUSH_ARG1(); break; + case 9: + arg2 = POP(); arg1 = POP(); prim_le (); PUSH_ARG1(); break; + case 10: + arg2 = POP(); arg1 = POP(); prim_gt (); PUSH_ARG1(); break; + case 11: + arg2 = POP(); arg1 = POP(); prim_ge (); PUSH_ARG1(); break; + case 12: + arg1 = POP(); prim_pairp (); PUSH_ARG1(); break; + case 13: + arg2 = POP(); arg1 = POP(); prim_cons (); PUSH_ARG1(); break; + case 14: + arg1 = POP(); prim_car (); PUSH_ARG1(); break; + case 15: + arg1 = POP(); prim_cdr (); PUSH_ARG1(); break; + } + + DISPATCH(); + + /***************************************************************************/ + CASE(PRIM2); + + IF_TRACE(printf(" (%s)\n", prim_name[bytecode_lo4+16])); + + switch (bytecode_lo4) + { + case 0: + arg2 = POP(); arg1 = POP(); prim_set_car (); break; + case 1: + arg2 = POP(); arg1 = POP(); prim_set_cdr (); break; + case 2: + arg1 = POP(); prim_nullp (); PUSH_ARG1(); break; + case 3: + arg2 = POP(); arg1 = POP(); prim_eqp (); PUSH_ARG1(); break; + case 4: + arg1 = POP(); prim_not (); PUSH_ARG1(); break; + case 5: + /* prim #%get-cont */ + arg1 = cont; + PUSH_ARG1(); + break; + case 6: + /* prim #%graft-to-cont */ + + arg1 = POP(); /* thunk to call */ + cont = POP(); /* continuation */ + + PUSH_ARG1(); + + na = 0; + + pop_procedure (); + handle_arity_and_rest_param (); + build_env (); + + env = arg1; + pc = entry; + + arg1 = OBJ_FALSE; + + break; + case 7: + /* prim #%return-to-cont */ + + arg1 = POP(); /* value to return */ + cont = POP(); /* continuation */ + + pc = ((rom_addr)(ram_get_field0 (cont) + ((CODE_START>>8) - PROCEDURE_FIELD0)) << 8) + ram_get_field3 (cont); + env = ram_get_field1 (cont); + cont = ram_get_field2 (cont); + + PUSH_ARG1(); + + break; + case 8: + /* prim #%halt */ + return; + case 9: + /* prim #%symbol? */ + arg1 = POP(); prim_symbolp (); PUSH_ARG1(); break; + case 10: + /* prim #%string? */ + arg1 = POP(); prim_stringp (); PUSH_ARG1(); break; + case 11: + /* prim #%string->list */ + arg1 = POP(); prim_string2list (); PUSH_ARG1(); break; + case 12: + /* prim #%list->string */ + arg1 = POP(); prim_list2string (); PUSH_ARG1(); break; + case 13: + /* prim #%cast-int ADDED */ + arg1 = POP(); prim_cast_int (); PUSH_ARG1(); break; + break; +#if 0 + case 14: + /* prim #%prim30 */ + break; + case 15: + /* prim #%prim31 */ + break; +#endif + } + + DISPATCH(); + + /***************************************************************************/ + CASE(PRIM3); + + IF_TRACE(printf(" (%s)\n", prim_name[bytecode_lo4+32])); + + switch (bytecode_lo4) + { + case 0: + /* prim #%print */ + arg1 = POP(); + prim_print (); + break; + case 1: + /* prim #%clock */ + prim_clock (); PUSH_ARG1(); break; + case 2: + /* prim #%motor */ + arg3 = POP(); arg2 = POP(); arg1 = POP(); prim_motor (); break; + case 3: + /* prim #%led */ + arg1 = POP(); prim_led (); ;break; + case 4: + /* prim #%getchar-wait */ + arg1 = POP(); prim_getchar_wait (); PUSH_ARG1(); break; + case 5: + /* prim #%putchar */ + arg1 = POP(); prim_putchar (); break; + case 6: + /* prim #%light */ + prim_light (); PUSH_ARG1(); break; +#if 0 + case 7: + break; + case 8: + break; + case 9: + break; + case 10: + break; + case 11: + break; +#endif + case 12: + /* push-constant [long] */ + FETCH_NEXT_BYTECODE(); + arg1 = bytecode; + PUSH_ARG1(); + break; + case 13: + /* shift */ + arg1 = POP(); + POP(); + PUSH_ARG1(); + break; + case 14: + /* pop */ + POP(); + break; + case 15: + /* return */ + arg1 = POP(); + pc = ((rom_addr)(ram_get_field0 (cont) + ((CODE_START>>8) - PROCEDURE_FIELD0)) << 8) + ram_get_field3 (cont); + env = ram_get_field1 (cont); + cont = ram_get_field2 (cont); + PUSH_ARG1(); + break; + } + + DISPATCH(); + + /***************************************************************************/ + + END_DISPATCH(); +} + +/*---------------------------------------------------------------------------*/ + +#ifdef WORKSTATION + +void usage (void) +{ + printf ("usage: sim file.hex\n"); + exit (1); +} + +int main (int argc, char *argv[]) +{ + int errcode = 1; + rom_addr rom_start_addr = 0; + + if (argc > 1 && argv[1][0] == '-' && argv[1][1] == 's') + { + int h1; + int h2; + int h3; + int h4; + + if ((h1 = hex (argv[1][2])) < 0 || + (h2 = hex (argv[1][3])) < 0 || + (h3 = hex (argv[1][4])) != 0 || + (h4 = hex (argv[1][5])) != 0 || + argv[1][6] != '\0') + usage (); + + rom_start_addr = (h1 << 12) | (h2 << 8) | (h3 << 4) | h4; + + argv++; + argc--; + } + +#ifdef DEBUG + printf ("Start address = 0x%04x\n", rom_start_addr); +#endif + + if (argc != 2) + usage (); + + if (!read_hex_file (argv[1])) + printf ("*** Could not read hex file \"%s\"\n", argv[1]); + else + { + int i; + + if (rom_get (CODE_START+0) != 0xfb || + rom_get (CODE_START+1) != 0xd7) + printf ("*** The hex file was not compiled with PICOBIT\n"); + else + { +#if 0 + for (i=0; i<8192; i++) + if (rom_get (i) != 0xff) + printf ("rom_mem[0x%04x] = 0x%02x\n", i, rom_get (i)); +#endif + + interpreter (); + +#ifdef DEBUG_GC + printf ("**************** memory needed = %d\n", max_live+1); +#endif + } + } + + return errcode; +} + +#endif + +/*---------------------------------------------------------------------------*/ + +#ifdef __18CXX + +/* $Id: c018i.c,v 1.1.2.1 2004/03/09 16:47:01 sealep Exp $ */ + +/* Copyright (c)1999 Microchip Technology */ + +/* MPLAB-C18 startup code, including initialized data */ + +#if 0 +/* external reference to the user's main routine */ +extern void main (void); +/* prototype for the startup function */ +void _entry (void); +#endif +void _startup (void); +/* prototype for the initialized data setup */ +void _do_cinit (void); + +extern volatile near unsigned long short TBLPTR; +extern near unsigned FSR0; +extern near char FPFLAGS; +#define RND 6 + +#if 0 +#pragma code _entry_scn=0x000000 +void +_entry (void) +{ +_asm goto _startup _endasm + +} +#pragma code _startup_scn +#endif + +void +_startup (void) +{ + _asm + // Initialize the stack pointer + lfsr 1, _stack lfsr 2, _stack clrf TBLPTRU, 0 // 1st silicon doesn't do this on POR + bcf FPFLAGS,RND,0 // Initialize rounding flag for floating point libs + + _endasm + _do_cinit (); + + // Call the user's main routine + interpreter (); + + ERROR("halted"); +} /* end _startup() */ + +/* MPLAB-C18 initialized data memory support */ +/* The linker will populate the _cinit table */ +extern far rom struct +{ + unsigned short num_init; + struct _init_entry + { + unsigned long from; + unsigned long to; + unsigned long size; + } + entries[]; +} +_cinit; + +#pragma code _cinit_scn +void +_do_cinit (void) +{ + /* we'll make the assumption in the following code that these statics + * will be allocated into the same bank. + */ + static short long prom; + static unsigned short curr_byte; + static unsigned short curr_entry; + static short long data_ptr; + + // Initialized data... + TBLPTR = (short long)&_cinit; + _asm + movlb data_ptr + tblrdpostinc + movf TABLAT, 0, 0 + movwf curr_entry, 1 + tblrdpostinc + movf TABLAT, 0, 0 + movwf curr_entry+1, 1 + _endasm + //while (curr_entry) + //{ + test: + _asm + bnz 3 + tstfsz curr_entry, 1 + bra 1 + _endasm + goto done; + /* Count down so we only have to look up the data in _cinit + * once. + * + * At this point we know that TBLPTR points to the top of the current + * entry in _cinit, so we can just start reading the from, to, and + * size values. + */ + _asm + /* read the source address */ + tblrdpostinc + movf TABLAT, 0, 0 + movwf prom, 1 + tblrdpostinc + movf TABLAT, 0, 0 + movwf prom+1, 1 + tblrdpostinc + movf TABLAT, 0, 0 + movwf prom+2, 1 + /* skip a byte since it's stored as a 32bit int */ + tblrdpostinc + /* read the destination address directly into FSR0 */ + tblrdpostinc + movf TABLAT, 0, 0 + movwf FSR0L, 0 + tblrdpostinc + movf TABLAT, 0, 0 + movwf FSR0H, 0 + /* skip two bytes since it's stored as a 32bit int */ + tblrdpostinc + tblrdpostinc + /* read the destination address directly into FSR0 */ + tblrdpostinc + movf TABLAT, 0, 0 + movwf curr_byte, 1 + tblrdpostinc + movf TABLAT, 0, 0 + movwf curr_byte+1, 1 + /* skip two bytes since it's stored as a 32bit int */ + tblrdpostinc + tblrdpostinc + _endasm + //prom = data_ptr->from; + //FSR0 = data_ptr->to; + //curr_byte = (unsigned short) data_ptr->size; + /* the table pointer now points to the next entry. Save it + * off since we'll be using the table pointer to do the copying + * for the entry. + */ + data_ptr = TBLPTR; + + /* now assign the source address to the table pointer */ + TBLPTR = prom; + + /* do the copy loop */ + _asm + // determine if we have any more bytes to copy + movlb curr_byte + movf curr_byte, 1, 1 +copy_loop: + bnz 2 // copy_one_byte + movf curr_byte + 1, 1, 1 + bz 7 // done_copying + +copy_one_byte: + tblrdpostinc + movf TABLAT, 0, 0 + movwf POSTINC0, 0 + + // decrement byte counter + decf curr_byte, 1, 1 + bc -8 // copy_loop + decf curr_byte + 1, 1, 1 + bra -7 // copy_one_byte + +done_copying: + + _endasm + /* restore the table pointer for the next entry */ + TBLPTR = data_ptr; + /* next entry... */ + curr_entry--; + goto test; +done: +; +} + +#pragma code picobit_boot=0x001ffa +void _picobit_boot (void) +{ +_asm goto _startup _endasm +} + +#endif + +/*---------------------------------------------------------------------------*/ diff --git a/picobit.scm b/picobit.scm new file mode 100644 index 0000000..5a17f91 --- /dev/null +++ b/picobit.scm @@ -0,0 +1,2945 @@ +; File: "picobit.scm", Time-stamp: <2006-05-08 16:04:37 feeley> + +; Copyright (C) 2006 by Marc Feeley, All Rights Reserved. + +(define-macro (dummy) + (proper-tail-calls-set! #f) + #f) +;(dummy) + +;----------------------------------------------------------------------------- + +(define compiler-error + (lambda (msg . others) + (display "*** ERROR -- ") + (display msg) + (for-each (lambda (x) (display " ") (write x)) others) + (newline) + (exit 1))) + +;----------------------------------------------------------------------------- + +(define keep + (lambda (keep? lst) + (cond ((null? lst) '()) + ((keep? (car lst)) (cons (car lst) (keep keep? (cdr lst)))) + (else (keep keep? (cdr lst)))))) + +(define take + (lambda (n lst) + (if (> n 0) + (cons (car lst) (take (- n 1) (cdr lst))) + '()))) + +(define drop + (lambda (n lst) + (if (> n 0) + (drop (- n 1) (cdr lst)) + lst))) + +(define repeat + (lambda (n x) + (if (> n 0) + (cons x (repeat (- n 1) x)) + '()))) + +(define pos-in-list + (lambda (x lst) + (let loop ((lst lst) (i 0)) + (cond ((not (pair? lst)) #f) + ((eq? (car lst) x) i) + (else (loop (cdr lst) (+ i 1))))))) + +(define every + (lambda (pred? lst) + (or (null? lst) + (and (pred? (car lst)) + (every pred? (cdr lst)))))) + +;----------------------------------------------------------------------------- + +; Syntax-tree node representation. + +(define-type node + extender: define-type-of-node + parent + children +) + +(define-type-of-node cst + val +) + +(define-type-of-node ref + var +) + +(define-type-of-node def + var +) + +(define-type-of-node set + var +) + +(define-type-of-node if +) + +(define-type-of-node prc + params + rest? + entry-label +) + +(define-type-of-node call +) + +(define-type-of-node seq +) + +(define-type-of-node fix + vars +) + +(define node->expr + (lambda (node) + (cond ((cst? node) + (let ((val (cst-val node))) + (if (self-eval? val) + val + (list 'quote val)))) + ((ref? node) + (var-id (ref-var node))) + ((def? node) + (list 'define + (var-id (def-var node)) + (node->expr (child1 node)))) + ((set? node) + (list 'set! + (var-id (set-var node)) + (node->expr (child1 node)))) + ((if? node) + (list 'if + (node->expr (child1 node)) + (node->expr (child2 node)) + (node->expr (child3 node)))) + ((prc? node) + (if (seq? (child1 node)) + (cons 'lambda + (cons (build-pattern (prc-params node) (prc-rest? node)) + (nodes->exprs (node-children (child1 node))))) + (list 'lambda + (build-pattern (prc-params node) (prc-rest? node)) + (node->expr (child1 node))))) + ((call? node) + (map node->expr (node-children node))) + ((seq? node) + (let ((children (node-children node))) + (cond ((null? children) + '(void)) + ((null? (cdr children)) + (node->expr (car children))) + (else + (cons 'begin + (nodes->exprs children)))))) + ((fix? node) + (let ((children (node-children node))) + (list 'letrec + (map (lambda (var val) + (list (var-id var) + (node->expr val))) + (fix-vars node) + (take (- (length children) 1) children)) + (node->expr (list-ref children (- (length children) 1)))))) + (else + (compiler-error "unknown expression type" node))))) + +(define nodes->exprs + (lambda (nodes) + (if (null? nodes) + '() + (if (seq? (car nodes)) + (append (nodes->exprs (node-children (car nodes))) + (nodes->exprs (cdr nodes))) + (cons (node->expr (car nodes)) + (nodes->exprs (cdr nodes))))))) + +(define build-pattern + (lambda (params rest?) + (cond ((null? params) + '()) + ((null? (cdr params)) + (if rest? + (var-id (car params)) + (list (var-id (car params))))) + (else + (cons (var-id (car params)) + (build-pattern (cdr params) rest?)))))) + +;----------------------------------------------------------------------------- + +; Environment representation. + +(define-type var + id + global? + refs + sets + defs + needed? + primitive +) + +(define-type primitive + nargs + inliner + unspecified-result? +) + +(define-type renaming + renamings +) + +(define make-global-env + (lambda () + (list (make-var '#%number? #t '() '() '() #f (make-primitive 1 #f #f)) + (make-var '#%+ #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%- #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%* #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%quotient #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%remainder #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%neg #t '() '() '() #f (make-primitive 1 #f #f)) + (make-var '#%= #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%< #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%<= #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%> #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%>= #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%pair? #t '() '() '() #f (make-primitive 1 #f #f)) + (make-var '#%cons #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%car #t '() '() '() #f (make-primitive 1 #f #f)) + (make-var '#%cdr #t '() '() '() #f (make-primitive 1 #f #f)) + (make-var '#%set-car! #t '() '() '() #f (make-primitive 2 #f #t)) + (make-var '#%set-cdr! #t '() '() '() #f (make-primitive 2 #f #t)) + (make-var '#%null? #t '() '() '() #f (make-primitive 1 #f #f)) + (make-var '#%eq? #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%not #t '() '() '() #f (make-primitive 1 #f #f)) + (make-var '#%get-cont #t '() '() '() #f (make-primitive 0 #f #f)) + (make-var '#%graft-to-cont #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%return-to-cont #t '() '() '() #f (make-primitive 2 #f #f)) + (make-var '#%halt #t '() '() '() #f (make-primitive 0 #f #t)) + (make-var '#%symbol? #t '() '() '() #f (make-primitive 1 #f #f)) + (make-var '#%string? #t '() '() '() #f (make-primitive 1 #f #f)) + (make-var '#%string->list #t '() '() '() #f (make-primitive 1 #f #f)) + (make-var '#%list->string #t '() '() '() #f (make-primitive 1 #f #f)) + (make-var '#%cast-int #t '() '() '() #f (make-primitive 1 #f #f)) ;; ADDED + + (make-var '#%print #t '() '() '() #f (make-primitive 1 #f #t)) + (make-var '#%clock #t '() '() '() #f (make-primitive 0 #f #f)) + (make-var '#%motor #t '() '() '() #f (make-primitive 3 #f #t)) + (make-var '#%led #t '() '() '() #f (make-primitive 1 #f #t)) + (make-var '#%getchar-wait #t '() '() '() #f (make-primitive 1 #f #f)) + (make-var '#%putchar #t '() '() '() #f (make-primitive 1 #f #t)) + (make-var '#%light #t '() '() '() #f (make-primitive 0 #f #f)) + + (make-var '#%readyq #t '() '() '() #f #f) + + ))) + +(define env-lookup + (lambda (env id) + (let loop ((lst env) (id id)) + (let ((b (car lst))) + (cond ((and (renaming? b) + (assq id (renaming-renamings b))) + => + (lambda (x) + (loop (cdr lst) (cadr x)))) + ((and (var? b) + (eq? (var-id b) id)) + b) + ((null? (cdr lst)) + (let ((x (make-var id #t '() '() '() #f #f))) + (set-cdr! lst (cons x '())) + x)) + (else + (loop (cdr lst) id))))))) + +(define env-extend + (lambda (env ids def) + (append (map (lambda (id) + (make-var id #f '() '() (list def) #f #f)) + ids) + env))) + +(define env-extend-renamings + (lambda (env renamings) + (cons (make-renaming renamings) env))) + +;----------------------------------------------------------------------------- + +; Parsing. + +(define parse-program + (lambda (expr env) + (let ((x (parse-top expr env))) + (cond ((null? x) + (parse 'value #f env)) + ((null? (cdr x)) + (car x)) + (else + (let ((r (make-seq #f x))) + (for-each (lambda (y) (node-parent-set! y r)) x) + r)))))) + +(define parse-top + (lambda (expr env) + (cond ((and (pair? expr) + (eq? (car expr) 'begin)) + (parse-top-list (cdr expr) env)) + ((and (pair? expr) + (eq? (car expr) 'hide)) + (parse-top-hide (cadr expr) (cddr expr) env)) + ((and (pair? expr) + (eq? (car expr) 'rename)) + (parse-top-rename (cadr expr) (cddr expr) env)) + ((and (pair? expr) + (eq? (car expr) 'define)) + (let ((var + (if (pair? (cadr expr)) + (car (cadr expr)) + (cadr expr))) + (val + (if (pair? (cadr expr)) + (cons 'lambda (cons (cdr (cadr expr)) (cddr expr))) + (caddr expr)))) + (let* ((var2 (env-lookup env var)) + (val2 (parse 'value val env)) + (r (make-def #f (list val2) var2))) + (node-parent-set! val2 r) + (var-defs-set! var2 (cons r (var-defs var2))) + (list r)))) + (else + (list (parse 'value expr env)))))) + +(define parse-top-list + (lambda (lst env) + (if (pair? lst) + (append (parse-top (car lst) env) + (parse-top-list (cdr lst) env)) + '()))) + +(define parse-top-hide + (lambda (renamings body env) + (append + (parse-top-list body + (env-extend-renamings env renamings)) +#| + (parse-top-list + (map (lambda (x) (list 'define (car x) (cadr x))) renamings) + env) +|# +))) + +(define parse-top-rename + (lambda (renamings body env) + (parse-top-list body + (env-extend-renamings env renamings)))) + +(define parse + (lambda (use expr env) + (cond ((self-eval? expr) + (make-cst #f '() expr)) + ((symbol? expr) + (let* ((var (env-lookup env expr)) + (r (make-ref #f '() var))) + (var-refs-set! var (cons r (var-refs var))) + r)) + ((and (pair? expr) ;; ADDED + (eq? (car expr) 'u8vector)) + (parse use ; call string + (list->string (map integer->char (cdr expr))) + env)) + ((and (pair? expr) + (eq? (car expr) 'set!)) + (let ((var (env-lookup env (cadr expr)))) + (if (var-global? var) + (let* ((val (parse 'value (caddr expr) env)) + (r (make-set #f (list val) var))) + (node-parent-set! val r) + (var-sets-set! var (cons r (var-sets var))) + r) + (compiler-error "set! is only permitted on global variables")))) + ((and (pair? expr) + (eq? (car expr) 'quote)) + (make-cst #f '() (cadr expr))) + ((and (pair? expr) + (eq? (car expr) 'if)) + (let* ((a (parse 'test (cadr expr) env)) + (b (parse use (caddr expr) env)) + (c (if (null? (cdddr expr)) + (make-cst #f '() #f) + (parse use (cadddr expr) env))) + (r (make-if #f (list a b c)))) + (node-parent-set! a r) + (node-parent-set! b r) + (node-parent-set! c r) + r)) + ((and (pair? expr) + (eq? (car expr) 'lambda)) + (let* ((pattern (cadr expr)) + (ids (extract-ids pattern)) + (r (make-prc #f '() #f (has-rest-param? pattern) #f)) + (new-env (env-extend env ids r)) + (body (parse-body (cddr expr) new-env))) + (prc-params-set! r (map (lambda (id) (env-lookup new-env id)) ids)) + (node-children-set! r (list body)) + (node-parent-set! body r) + r)) + ((and (pair? expr) + (eq? (car expr) 'begin)) + (let* ((exprs (map (lambda (x) (parse 'value x env)) (cdr expr))) + (r (make-seq #f exprs))) + (for-each (lambda (x) (node-parent-set! x r)) exprs) + r)) + ((and (pair? expr) + (eq? (car expr) 'let)) + (if (symbol? (cadr expr)) + (compiler-error "named let is not implemented") + (parse use + (cons (cons 'lambda + (cons (map car (cadr expr)) + (cddr expr))) + (map cadr (cadr expr))) + env))) + ((and (pair? expr) + (eq? (car expr) 'let*)) + (if (null? (cadr expr)) + (parse use + (cons 'let (cdr expr)) + env) + (parse use + (list 'let + (list (list (caar (cadr expr)) + (cadar (cadr expr)))) + (cons 'let* + (cons (cdr (cadr expr)) + (cddr expr)))) + env))) + ((and (pair? expr) + (eq? (car expr) 'and)) + (cond ((null? (cdr expr)) + (parse use + #t + env)) + ((null? (cddr expr)) + (parse use + (cadr expr) + env)) + (else + (parse use + (list 'if + (cadr expr) + (cons 'and (cddr expr)) + #f) + env)))) + ((and (pair? expr) + (eq? (car expr) 'or)) + (cond ((null? (cdr expr)) + (parse use + #f + env)) + ((null? (cddr expr)) + (parse use + (cadr expr) + env)) + ((eq? use 'test) + (parse use + (list 'if + (cadr expr) + #t + (cons 'or (cddr expr))) + env)) + (else + (parse use + (let ((v (gensym))) + (list 'let + (list (list v (cadr expr))) + (list 'if + v + v + (cons 'or (cddr expr))))) + env)))) + ((and (pair? expr) + (memq (car expr) + '(quote quasiquote unquote unquote-splicing lambda if + set! cond and or case let let* letrec begin do define + delay))) + (compiler-error "the compiler does not implement the special form" (car expr))) + ((pair? expr) + (let* ((exprs (map (lambda (x) (parse 'value x env)) expr)) + (r (make-call #f exprs))) + (for-each (lambda (x) (node-parent-set! x r)) exprs) + r)) + (else + (compiler-error "unknown expression" expr))))) + +(define parse-body + (lambda (exprs env) + (parse 'value (cons 'begin exprs) env))) + +(define self-eval? + (lambda (expr) + (or (number? expr) + (char? expr) + (boolean? expr) + (string? expr)))) + +(define extract-ids + (lambda (pattern) + (if (pair? pattern) + (cons (car pattern) (extract-ids (cdr pattern))) + (if (symbol? pattern) + (cons pattern '()) + '())))) + +(define has-rest-param? + (lambda (pattern) + (if (pair? pattern) + (has-rest-param? (cdr pattern)) + (symbol? pattern)))) + +;----------------------------------------------------------------------------- + +; Compilation context representation. + +(define-type context + code + env + env2 +) + +(define context-change-code + (lambda (ctx code) + (make-context code + (context-env ctx) + (context-env2 ctx)))) + +(define context-change-env + (lambda (ctx env) + (make-context (context-code ctx) + env + (context-env2 ctx)))) + +(define context-change-env2 + (lambda (ctx env2) + (make-context (context-code ctx) + (context-env ctx) + env2))) + +(define make-init-context + (lambda () + (make-context (make-init-code) + (make-init-env) + #f))) + +(define context-make-label + (lambda (ctx) + (context-change-code ctx (code-make-label (context-code ctx))))) + +(define context-last-label + (lambda (ctx) + (code-last-label (context-code ctx)))) + +(define context-add-bb + (lambda (ctx label) + (context-change-code ctx (code-add-bb (context-code ctx) label)))) + +(define context-add-instr + (lambda (ctx instr) + (context-change-code ctx (code-add-instr (context-code ctx) instr)))) + +; Representation of code. + +(define-type code + last-label + rev-bbs +) + +(define-type bb + label + rev-instrs +) + +(define make-init-code + (lambda () + (make-code 0 + (list (make-bb 0 (list)))))) + +(define code-make-label + (lambda (code) + (let ((label (+ (code-last-label code) 1))) + (make-code label + (code-rev-bbs code))))) + +(define code-add-bb + (lambda (code label) + (make-code + (code-last-label code) + (cons (make-bb label '()) + (code-rev-bbs code))))) + +(define code-add-instr + (lambda (code instr) + (let* ((rev-bbs (code-rev-bbs code)) + (bb (car rev-bbs)) + (rev-instrs (bb-rev-instrs bb))) + (make-code + (code-last-label code) + (cons (make-bb (bb-label bb) + (cons instr rev-instrs)) + (cdr rev-bbs)))))) + +; Representation of compile-time stack. + +(define-type stack + size ; number of slots + slots ; for each slot, the variable (or #f) contained in the slot +) + +(define make-init-stack + (lambda () + (make-stack 0 '()))) + +(define stack-extend + (lambda (x nb-slots stk) + (let ((size (stack-size stk))) + (make-stack + (+ size nb-slots) + (append (repeat nb-slots x) (stack-slots stk)))))) + +(define stack-discard + (lambda (nb-slots stk) + (let ((size (stack-size stk))) + (make-stack + (- size nb-slots) + (list-tail (stack-slots stk) nb-slots))))) + +; Representation of compile-time environment. + +(define-type env + local + closed +) + +(define make-init-env + (lambda () + (make-env (make-init-stack) + '()))) + +(define env-change-local + (lambda (env local) + (make-env local + (env-closed env)))) + +(define env-change-closed + (lambda (env closed) + (make-env (env-local env) + closed))) + +(define find-local-var + (lambda (var env) + (let ((i (pos-in-list var (stack-slots (env-local env))))) + (or i + (- (+ (pos-in-list var (env-closed env)) 1)))))) + +(define prc->env + (lambda (prc) + (make-env + (let ((params (prc-params prc))) + (make-stack (length params) + (append (map var-id params) '()))) + (let ((vars (varset->list (non-global-fv prc)))) +; (pp (map var-id vars)) + (map var-id vars)))));;;;;;;;;;;;; + +;----------------------------------------------------------------------------- + +(define gen-instruction + (lambda (instr nb-pop nb-push ctx) + (let* ((env + (context-env ctx)) + (stk + (stack-extend #f + nb-push + (stack-discard nb-pop + (env-local env))))) + (context-add-instr (context-change-env ctx (env-change-local env stk)) + instr)))) + +(define gen-entry + (lambda (nparams rest? ctx) + (gen-instruction (list 'entry nparams rest?) 0 0 ctx))) + +(define gen-push-constant + (lambda (val ctx) + (gen-instruction (list 'push-constant val) 0 1 ctx))) + +(define gen-push-unspecified + (lambda (ctx) + (gen-push-constant #f ctx))) + +(define gen-push-local-var + (lambda (var ctx) +; (pp (list var: var local: (stack-slots (env-local (context-env ctx))) (env-closed (context-env ctx)))) + (let ((i (find-local-var var (context-env ctx)))) + (if (>= i 0) + (gen-push-stack i ctx) + (gen-push-stack (+ (- -1 i) (length (stack-slots (env-local (context-env ctx))))) ctx))))) + +(define gen-push-stack + (lambda (pos ctx) + (gen-instruction (list 'push-stack pos) 0 1 ctx))) + +(define gen-push-global + (lambda (var ctx) + (gen-instruction (list 'push-global var) 0 1 ctx))) + +(define gen-set-global + (lambda (var ctx) + (gen-instruction (list 'set-global var) 1 0 ctx))) + +(define gen-call + (lambda (nargs ctx) + (gen-instruction (list 'call nargs) (+ nargs 1) 1 ctx))) + +(define gen-jump + (lambda (nargs ctx) + (gen-instruction (list 'jump nargs) (+ nargs 1) 1 ctx))) + +(define gen-call-toplevel + (lambda (nargs id ctx) + (gen-instruction (list 'call-toplevel id) nargs 1 ctx))) + +(define gen-jump-toplevel + (lambda (nargs id ctx) + (gen-instruction (list 'jump-toplevel id) nargs 1 ctx))) + +(define gen-goto + (lambda (label ctx) + (gen-instruction (list 'goto label) 0 0 ctx))) + +(define gen-goto-if-false + (lambda (label-false label-true ctx) + (gen-instruction (list 'goto-if-false label-false label-true) 1 0 ctx))) + +(define gen-closure + (lambda (label-entry ctx) + (gen-instruction (list 'closure label-entry) 2 1 ctx))) + +(define gen-prim + (lambda (id nargs unspec-result? ctx) + (gen-instruction + (list 'prim id) + nargs + (if unspec-result? 0 1) + ctx))) + +(define gen-shift + (lambda (n ctx) + (if (> n 0) + (gen-instruction (list 'shift) 1 0 (gen-shift (- n 1) ctx)) + ctx))) + +(define gen-pop + (lambda (ctx) + (gen-instruction (list 'pop) 1 0 ctx))) + +(define gen-return + (lambda (ctx) + (let ((ss (stack-size (env-local (context-env ctx))))) + (gen-instruction (list 'return) ss 0 ctx)))) + +;----------------------------------------------------------------------------- + +(define child1 + (lambda (node) + (car (node-children node)))) + +(define child2 + (lambda (node) + (cadr (node-children node)))) + +(define child3 + (lambda (node) + (caddr (node-children node)))) + +(define comp-none + (lambda (node ctx) + + (cond ((or (cst? node) + (ref? node) + (prc? node)) + ctx) + + ((def? node) + (let ((var (def-var node))) + (if (toplevel-prc-with-non-rest-correct-calls? var) + (comp-prc (child1 node) #f ctx) + (if (var-needed? var) + (let ((ctx2 (comp-push (child1 node) ctx))) + (gen-set-global (var-id var) ctx2)) + (comp-none (child1 node) ctx))))) + + ((set? node) + (let ((var (set-var node))) + (if (var-needed? var) + (let ((ctx2 (comp-push (child1 node) ctx))) + (gen-set-global (var-id var) ctx2)) + (comp-none (child1 node) ctx)))) + + ((if? node) + (let* ((ctx2 + (context-make-label ctx)) + (label-then + (context-last-label ctx2)) + (ctx3 + (context-make-label ctx2)) + (label-else + (context-last-label ctx3)) + (ctx4 + (context-make-label ctx3)) + (label-then-join + (context-last-label ctx4)) + (ctx5 + (context-make-label ctx4)) + (label-else-join + (context-last-label ctx5)) + (ctx6 + (context-make-label ctx5)) + (label-join + (context-last-label ctx6)) + (ctx7 + (comp-test (child1 node) label-then label-else ctx6)) + (ctx8 + (gen-goto + label-else-join + (comp-none (child3 node) + (context-change-env2 + (context-add-bb ctx7 label-else) + #f)))) + (ctx9 + (gen-goto + label-then-join + (comp-none (child2 node) + (context-change-env + (context-add-bb ctx8 label-then) + (context-env2 ctx7))))) + (ctx10 + (gen-goto + label-join + (context-add-bb ctx9 label-else-join))) + (ctx11 + (gen-goto + label-join + (context-add-bb ctx10 label-then-join))) + (ctx12 + (context-add-bb ctx11 label-join))) + ctx12)) + + ((call? node) + (comp-call node 'none ctx)) + + ((seq? node) + (let ((children (node-children node))) + (if (null? children) + ctx + (let loop ((lst children) + (ctx ctx)) + (if (null? (cdr lst)) + (comp-none (car lst) ctx) + (loop (cdr lst) + (comp-none (car lst) ctx))))))) + + (else + (compiler-error "unknown expression type" node))))) + +(define comp-tail + (lambda (node ctx) + + (cond ((or (cst? node) + (ref? node) + (def? node) + (set? node) + (prc? node) +; (call? node);;;;;;;;;;;;;;;; + ) + (gen-return (comp-push node ctx))) + + ((if? node) + (let* ((ctx2 + (context-make-label ctx)) + (label-then + (context-last-label ctx2)) + (ctx3 + (context-make-label ctx2)) + (label-else + (context-last-label ctx3)) + (ctx4 + (comp-test (child1 node) label-then label-else ctx3)) + (ctx5 + (comp-tail (child3 node) + (context-change-env2 + (context-add-bb ctx4 label-else) + #f))) + (ctx6 + (comp-tail (child2 node) + (context-change-env + (context-add-bb ctx5 label-then) + (context-env2 ctx4))))) + ctx6)) + + ((call? node) + (comp-call node 'tail ctx)) + + ((seq? node) + (let ((children (node-children node))) + (if (null? children) + (gen-return (gen-push-unspecified ctx)) + (let loop ((lst children) + (ctx ctx)) + (if (null? (cdr lst)) + (comp-tail (car lst) ctx) + (loop (cdr lst) + (comp-none (car lst) ctx))))))) + + (else + (compiler-error "unknown expression type" node))))) + +(define comp-push + (lambda (node ctx) + + '( + (display "--------------\n") + (pp (node->expr node)) + (pp env) + (pp stk) + ) + + (cond ((cst? node) + (let ((val (cst-val node))) + (gen-push-constant val ctx))) + + ((ref? node) + (let ((var (ref-var node))) + (if (var-global? var) + (if (null? (var-defs var)) + (compiler-error "undefined variable:" (var-id var)) + (gen-push-global (var-id var) ctx)) + (gen-push-local-var (var-id var) ctx))));;;;;;;;;;;;; + + ((or (def? node) + (set? node)) + (gen-push-unspecified (comp-none node ctx))) + + ((if? node) + (let* ((ctx2 + (context-make-label ctx)) + (label-then + (context-last-label ctx2)) + (ctx3 + (context-make-label ctx2)) + (label-else + (context-last-label ctx3)) + (ctx4 + (context-make-label ctx3)) + (label-then-join + (context-last-label ctx4)) + (ctx5 + (context-make-label ctx4)) + (label-else-join + (context-last-label ctx5)) + (ctx6 + (context-make-label ctx5)) + (label-join + (context-last-label ctx6)) + (ctx7 + (comp-test (child1 node) label-then label-else ctx6)) + (ctx8 + (gen-goto + label-else-join + (comp-push (child3 node) + (context-change-env2 + (context-add-bb ctx7 label-else) + #f)))) + (ctx9 + (gen-goto + label-then-join + (comp-push (child2 node) + (context-change-env + (context-add-bb ctx8 label-then) + (context-env2 ctx7))))) + (ctx10 + (gen-goto + label-join + (context-add-bb ctx9 label-else-join))) + (ctx11 + (gen-goto + label-join + (context-add-bb ctx10 label-then-join))) + (ctx12 + (context-add-bb ctx11 label-join))) + ctx12)) + + ((prc? node) + (comp-prc node #t ctx)) + + ((call? node) + (comp-call node 'push ctx)) + + ((seq? node) + (let ((children (node-children node))) + (if (null? children) + (gen-push-unspecified ctx) + (let loop ((lst children) + (ctx ctx)) + (if (null? (cdr lst)) + (comp-push (car lst) ctx) + (loop (cdr lst) + (comp-none (car lst) ctx))))))) + + (else + (compiler-error "unknown expression type" node))))) + +(define (build-closure label-entry vars ctx) + + (define (build vars ctx) + (if (null? vars) + (gen-push-constant '() ctx) + (gen-prim '#%cons + 2 + #f + (build (cdr vars) + (gen-push-local-var (car vars) ctx))))) + + (if (null? vars) + (gen-closure label-entry + (gen-push-constant '() + (gen-push-constant #f ctx))) + (gen-closure label-entry + (build (cdr vars) + (gen-push-local-var (car vars) ctx))))) + +(define comp-prc + (lambda (node closure? ctx) + (let* ((ctx2 + (context-make-label ctx)) + (label-entry + (context-last-label ctx2)) + (ctx3 + (context-make-label ctx2)) + (label-continue + (context-last-label ctx3)) + (body-env + (prc->env node)) + (ctx4 + (if closure? + (build-closure label-entry (env-closed body-env) ctx3) + ctx3)) + (ctx5 + (gen-goto label-continue ctx4)) + (ctx6 + (gen-entry (length (prc-params node)) + (prc-rest? node) + (context-add-bb (context-change-env ctx5 + body-env) + label-entry))) + (ctx7 + (comp-tail (child1 node) ctx6))) + (prc-entry-label-set! node label-entry) + (context-add-bb (context-change-env ctx7 (context-env ctx5)) + label-continue)))) + +(define comp-call + (lambda (node reason ctx) + (let* ((op (child1 node)) + (args (cdr (node-children node))) + (nargs (length args))) + (let loop ((lst args) + (ctx ctx)) + (if (pair? lst) + + (let ((arg (car lst))) + (loop (cdr lst) + (comp-push arg ctx))) + + (cond ((and (ref? op) + (var-primitive (ref-var op))) + (let* ((var (ref-var op)) + (id (var-id var)) + (primitive (var-primitive var)) + (prim-nargs (primitive-nargs primitive))) + + (define use-result + (lambda (ctx2) + (cond ((eq? reason 'tail) + (gen-return + (if (primitive-unspecified-result? primitive) + (gen-push-unspecified ctx2) + ctx2))) + ((eq? reason 'push) + (if (primitive-unspecified-result? primitive) + (gen-push-unspecified ctx2) + ctx2)) + (else + (if (primitive-unspecified-result? primitive) + ctx2 + (gen-pop ctx2)))))) + + (use-result + (if (primitive-inliner primitive) + ((primitive-inliner primitive) ctx) + (if (not (= nargs prim-nargs)) + (compiler-error "primitive called with wrong number of arguments" id) + (gen-prim + id + prim-nargs + (primitive-unspecified-result? primitive) + ctx)))))) + + + ((and (ref? op) + (toplevel-prc-with-non-rest-correct-calls? (ref-var op))) + => + (lambda (prc) + (cond ((eq? reason 'tail) + (gen-jump-toplevel nargs prc ctx)) + ((eq? reason 'push) + (gen-call-toplevel nargs prc ctx)) + (else + (gen-pop (gen-call-toplevel nargs prc ctx)))))) + + (else + (let ((ctx2 (comp-push op ctx))) + (cond ((eq? reason 'tail) + (gen-jump nargs ctx2)) + ((eq? reason 'push) + (gen-call nargs ctx2)) + (else + (gen-pop (gen-call nargs ctx2)))))))))))) + +(define comp-test + (lambda (node label-true label-false ctx) + (cond ((cst? node) + (let ((ctx2 + (gen-goto + (let ((val (cst-val node))) + (if val + label-true + label-false)) + ctx))) + (context-change-env2 ctx2 (context-env ctx2)))) + + ((or (ref? node) + (def? node) + (set? node) + (if? node) + (call? node) + (seq? node)) + (let* ((ctx2 + (comp-push node ctx)) + (ctx3 + (gen-goto-if-false label-false label-true ctx2))) + (context-change-env2 ctx3 (context-env ctx3)))) + + ((prc? node) + (let ((ctx2 + (gen-goto label-true ctx))) + (context-change-env2 ctx2 (context-env ctx2)))) + + (else + (compiler-error "unknown expression type" node))))) + +;----------------------------------------------------------------------------- + +(define toplevel-prc? + (lambda (var) + (and (not (mutable-var? var)) + (let ((d (var-defs var))) + (and (pair? d) + (null? (cdr d)) + (let ((val (child1 (car d)))) + (and (prc? val) + val))))))) + +(define toplevel-prc-with-non-rest-correct-calls? + (lambda (var) + (let ((prc (toplevel-prc? var))) + (and prc + (not (prc-rest? prc)) + (every (lambda (r) + (let ((parent (node-parent r))) + (and (call? parent) + (eq? (child1 parent) r) + (= (length (prc-params prc)) + (- (length (node-children parent)) 1))))) + (var-refs var)) + prc)))) + +(define mutable-var? + (lambda (var) + (not (null? (var-sets var))))) + +(define global-fv + (lambda (node) + (list->varset + (keep var-global? + (varset->list (fv node)))))) + +(define non-global-fv + (lambda (node) + (list->varset + (keep (lambda (x) (not (var-global? x))) + (varset->list (fv node)))))) + +(define fv + (lambda (node) + (cond ((cst? node) + (varset-empty)) + ((ref? node) + (let ((var (ref-var node))) + (varset-singleton var))) + ((def? node) + (let ((var (def-var node)) + (val (child1 node))) + (varset-union + (varset-singleton var) + (fv val)))) + ((set? node) + (let ((var (set-var node)) + (val (child1 node))) + (varset-union + (varset-singleton var) + (fv val)))) + ((if? node) + (let ((a (list-ref (node-children node) 0)) + (b (list-ref (node-children node) 1)) + (c (list-ref (node-children node) 2))) + (varset-union-multi (list (fv a) (fv b) (fv c))))) + ((prc? node) + (let ((body (list-ref (node-children node) 0))) + (varset-difference + (fv body) + (build-params-varset (prc-params node))))) + ((call? node) + (varset-union-multi (map fv (node-children node)))) + ((seq? node) + (varset-union-multi (map fv (node-children node)))) + (else + (compiler-error "unknown expression type" node))))) + +(define build-params-varset + (lambda (params) + (list->varset params))) + +(define mark-needed-global-vars! + (lambda (global-env node) + + (define readyq + (env-lookup global-env '#%readyq)) + + (define mark-var! + (lambda (var) + (if (and (var-global? var) + (not (var-needed? var))) + (begin + (var-needed?-set! var #t) + (for-each + (lambda (def) + (let ((val (child1 def))) + (if (side-effect-less? val) + (mark! val)))) + (var-defs var)) + (if (eq? var readyq) + (begin + (mark-var! + (env-lookup global-env '#%start-first-process)) + (mark-var! + (env-lookup global-env '#%exit)))))))) + + (define side-effect-less? + (lambda (node) + (or (cst? node) + (ref? node) + (prc? node)))) + + (define mark! + (lambda (node) + (cond ((cst? node)) + ((ref? node) + (let ((var (ref-var node))) + (mark-var! var))) + ((def? node) + (let ((var (def-var node)) + (val (child1 node))) + (if (not (side-effect-less? val)) + (mark! val)))) + ((set? node) + (let ((var (set-var node)) + (val (child1 node))) + (mark! val))) + ((if? node) + (let ((a (list-ref (node-children node) 0)) + (b (list-ref (node-children node) 1)) + (c (list-ref (node-children node) 2))) + (mark! a) + (mark! b) + (mark! c))) + ((prc? node) + (let ((body (list-ref (node-children node) 0))) + (mark! body))) + ((call? node) + (for-each mark! (node-children node))) + ((seq? node) + (for-each mark! (node-children node))) + (else + (compiler-error "unknown expression type" node))))) + + (mark! node) +)) + +;----------------------------------------------------------------------------- + +; Variable sets + +(define (varset-empty) ; return the empty set + '()) + +(define (varset-singleton x) ; create a set containing only 'x' + (list x)) + +(define (list->varset lst) ; convert list to set + lst) + +(define (varset->list set) ; convert set to list + set) + +(define (varset-size set) ; return cardinality of set + (list-length set)) + +(define (varset-empty? set) ; is 'x' the empty set? + (null? set)) + +(define (varset-member? x set) ; is 'x' a member of the 'set'? + (and (not (null? set)) + (or (eq? x (car set)) + (varset-member? x (cdr set))))) + +(define (varset-adjoin set x) ; add the element 'x' to the 'set' + (if (varset-member? x set) set (cons x set))) + +(define (varset-remove set x) ; remove the element 'x' from 'set' + (cond ((null? set) + '()) + ((eq? (car set) x) + (cdr set)) + (else + (cons (car set) (varset-remove (cdr set) x))))) + +(define (varset-equal? s1 s2) ; are 's1' and 's2' equal sets? + (and (varset-subset? s1 s2) + (varset-subset? s2 s1))) + +(define (varset-subset? s1 s2) ; is 's1' a subset of 's2'? + (cond ((null? s1) + #t) + ((varset-member? (car s1) s2) + (varset-subset? (cdr s1) s2)) + (else + #f))) + +(define (varset-difference set1 set2) ; return difference of sets + (cond ((null? set1) + '()) + ((varset-member? (car set1) set2) + (varset-difference (cdr set1) set2)) + (else + (cons (car set1) (varset-difference (cdr set1) set2))))) + +(define (varset-union set1 set2) ; return union of sets + (define (union s1 s2) + (cond ((null? s1) + s2) + ((varset-member? (car s1) s2) + (union (cdr s1) s2)) + (else + (cons (car s1) (union (cdr s1) s2))))) + (if (varset-smaller? set1 set2) + (union set1 set2) + (union set2 set1))) + +(define (varset-intersection set1 set2) ; return intersection of sets + (define (intersection s1 s2) + (cond ((null? s1) + '()) + ((varset-member? (car s1) s2) + (cons (car s1) (intersection (cdr s1) s2))) + (else + (intersection (cdr s1) s2)))) + (if (varset-smaller? set1 set2) + (intersection set1 set2) + (intersection set2 set1))) + +(define (varset-intersects? set1 set2) ; do sets 'set1' and 'set2' intersect? + (not (varset-empty? (varset-intersection set1 set2)))) + +(define (varset-smaller? set1 set2) + (if (null? set1) + (not (null? set2)) + (if (null? set2) + #f + (varset-smaller? (cdr set1) (cdr set2))))) + +(define (varset-union-multi sets) + (if (null? sets) + (varset-empty) + (n-ary varset-union (car sets) (cdr sets)))) + +(define (n-ary function first rest) + (if (null? rest) + first + (n-ary function (function first (car rest)) (cdr rest)))) + +;------------------------------------------------------------------------------ + +(define code->vector + (lambda (code) + (let ((v (make-vector (+ (code-last-label code) 1)))) + (for-each + (lambda (bb) + (vector-set! v (bb-label bb) bb)) + (code-rev-bbs code)) + v))) + +(define bbs->ref-counts + (lambda (bbs) + (let ((ref-counts (make-vector (vector-length bbs) 0))) + + (define visit + (lambda (label) + (let ((ref-count (vector-ref ref-counts label))) + (vector-set! ref-counts label (+ ref-count 1)) + (if (= ref-count 0) + (let* ((bb (vector-ref bbs label)) + (rev-instrs (bb-rev-instrs bb))) + (for-each + (lambda (instr) + (let ((opcode (car instr))) + (cond ((eq? opcode 'goto) + (visit (cadr instr))) + ((eq? opcode 'goto-if-false) + (visit (cadr instr)) + (visit (caddr instr))) + ((or (eq? opcode 'closure) + (eq? opcode 'call-toplevel) + (eq? opcode 'jump-toplevel)) + (visit (cadr instr)))))) + rev-instrs)))))) + + (visit 0) + + ref-counts))) + +(define resolve-toplevel-labels! + (lambda (bbs) + (let loop ((i 0)) + (if (< i (vector-length bbs)) + (let* ((bb (vector-ref bbs i)) + (rev-instrs (bb-rev-instrs bb))) + (bb-rev-instrs-set! + bb + (map (lambda (instr) + (let ((opcode (car instr))) + (cond ((eq? opcode 'call-toplevel) + (list opcode + (prc-entry-label (cadr instr)))) + ((eq? opcode 'jump-toplevel) + (list opcode + (prc-entry-label (cadr instr)))) + (else + instr)))) + rev-instrs)) + (loop (+ i 1))))))) + +(define tighten-jump-cascades! + (lambda (bbs) + (let ((ref-counts (bbs->ref-counts bbs))) + + (define resolve + (lambda (label) + (let* ((bb (vector-ref bbs label)) + (rev-instrs (bb-rev-instrs bb))) + (and (or (null? (cdr rev-instrs)) + (= (vector-ref ref-counts label) 1)) + rev-instrs)))) + + (let loop1 () + (let loop2 ((i 0) + (changed? #f)) + (if (< i (vector-length bbs)) + (if (> (vector-ref ref-counts i) 0) + (let* ((bb (vector-ref bbs i)) + (rev-instrs (bb-rev-instrs bb)) + (jump (car rev-instrs)) + (opcode (car jump))) + (cond ((eq? opcode 'goto) + (let* ((label (cadr jump)) + (jump-replacement (resolve label))) + (if jump-replacement + (begin + (vector-set! + bbs + i + (make-bb (bb-label bb) + (append jump-replacement + (cdr rev-instrs)))) + (loop2 (+ i 1) + #t)) + (loop2 (+ i 1) + changed?)))) + ((eq? opcode 'goto-if-false) + (let* ((label-then (cadr jump)) + (label-else (caddr jump)) + (jump-then-replacement (resolve label-then)) + (jump-else-replacement (resolve label-else))) + (if (and jump-then-replacement + (null? (cdr jump-then-replacement)) + jump-else-replacement + (null? (cdr jump-else-replacement)) + (or (eq? (caar jump-then-replacement) 'goto) + (eq? (caar jump-else-replacement) 'goto))) + (begin + (vector-set! + bbs + i + (make-bb (bb-label bb) + (cons (list 'goto-if-false + (if (eq? (caar jump-then-replacement) 'goto) + (cadar jump-then-replacement) + label-then) + (if (eq? (caar jump-else-replacement) 'goto) + (cadar jump-else-replacement) + label-else)) + (cdr rev-instrs)))) + (loop2 (+ i 1) + #t)) + (loop2 (+ i 1) + changed?)))) + (else + (loop2 (+ i 1) + changed?)))) + (loop2 (+ i 1) + changed?)) + (if changed? + (loop1)))))))) + +(define remove-useless-bbs! + (lambda (bbs) + (let ((ref-counts (bbs->ref-counts bbs))) + (let loop1 ((label 0) (new-label 0)) + (if (< label (vector-length bbs)) + (if (> (vector-ref ref-counts label) 0) + (let ((bb (vector-ref bbs label))) + (vector-set! + bbs + label + (make-bb new-label (bb-rev-instrs bb))) + (loop1 (+ label 1) (+ new-label 1))) + (loop1 (+ label 1) new-label)) + (renumber-labels bbs ref-counts new-label)))))) + +(define renumber-labels + (lambda (bbs ref-counts n) + (let ((new-bbs (make-vector n))) + (let loop2 ((label 0)) + (if (< label (vector-length bbs)) + (if (> (vector-ref ref-counts label) 0) + (let* ((bb (vector-ref bbs label)) + (new-label (bb-label bb)) + (rev-instrs (bb-rev-instrs bb))) + + (define fix + (lambda (instr) + + (define new-label + (lambda (label) + (bb-label (vector-ref bbs label)))) + + (let ((opcode (car instr))) + (cond ((eq? opcode 'closure) + (list 'closure + (new-label (cadr instr)))) + ((eq? opcode 'call-toplevel) + (list 'call-toplevel + (new-label (cadr instr)))) + ((eq? opcode 'jump-toplevel) + (list 'jump-toplevel + (new-label (cadr instr)))) + ((eq? opcode 'goto) + (list 'goto + (new-label (cadr instr)))) + ((eq? opcode 'goto-if-false) + (list 'goto-if-false + (new-label (cadr instr)) + (new-label (caddr instr)))) + (else + instr))))) + + (vector-set! + new-bbs + new-label + (make-bb new-label (map fix rev-instrs))) + (loop2 (+ label 1))) + (loop2 (+ label 1))) + new-bbs))))) + +(define reorder! + (lambda (bbs) + (let* ((done (make-vector (vector-length bbs) #f))) + + (define unscheduled? + (lambda (label) + (not (vector-ref done label)))) + + (define label-refs + (lambda (instrs todo) + (if (pair? instrs) + (let* ((instr (car instrs)) + (opcode (car instr))) + (cond ((or (eq? opcode 'closure) + (eq? opcode 'call-toplevel) + (eq? opcode 'jump-toplevel)) + (label-refs (cdr instrs) (cons (cadr instr) todo))) + (else + (label-refs (cdr instrs) todo)))) + todo))) + + (define schedule-here + (lambda (label new-label todo cont) + (let* ((bb (vector-ref bbs label)) + (rev-instrs (bb-rev-instrs bb)) + (jump (car rev-instrs)) + (opcode (car jump)) + (new-todo (label-refs rev-instrs todo))) + (vector-set! bbs label (make-bb new-label rev-instrs)) + (vector-set! done label #t) + (cond ((eq? opcode 'goto) + (let ((label (cadr jump))) + (if (unscheduled? label) + (schedule-here label + (+ new-label 1) + new-todo + cont) + (cont (+ new-label 1) + new-todo)))) + ((eq? opcode 'goto-if-false) + (let ((label-then (cadr jump)) + (label-else (caddr jump))) + (cond ((unscheduled? label-else) + (schedule-here label-else + (+ new-label 1) + (cons label-then new-todo) + cont)) + ((unscheduled? label-then) + (schedule-here label-then + (+ new-label 1) + new-todo + cont)) + (else + (cont (+ new-label 1) + new-todo))))) + (else + (cont (+ new-label 1) + new-todo)))))) + + (define schedule-somewhere + (lambda (label new-label todo cont) + (schedule-here label new-label todo cont))) + + (define schedule-todo + (lambda (new-label todo) + (if (pair? todo) + (let ((label (car todo))) + (if (unscheduled? label) + (schedule-somewhere label + new-label + (cdr todo) + schedule-todo) + (schedule-todo new-label + (cdr todo))))))) + + + (schedule-here 0 0 '() schedule-todo) + + (renumber-labels bbs + (make-vector (vector-length bbs) 1) + (vector-length bbs))))) + +(define linearize + (lambda (bbs) + (let loop ((label (- (vector-length bbs) 1)) + (lst '())) + (if (>= label 0) + (let* ((bb (vector-ref bbs label)) + (rev-instrs (bb-rev-instrs bb)) + (jump (car rev-instrs)) + (opcode (car jump))) + (loop (- label 1) + (append + (list label) + (reverse + (cond ((eq? opcode 'goto) + (if (= (cadr jump) (+ label 1)) + (cdr rev-instrs) + rev-instrs)) + ((eq? opcode 'goto-if-false) + (cond ((= (caddr jump) (+ label 1)) + (cons (list 'goto-if-false (cadr jump)) + (cdr rev-instrs))) + ((= (cadr jump) (+ label 1)) + (cons (list 'goto-if-not-false (caddr jump)) + (cdr rev-instrs))) + (else + (cons (list 'goto (caddr jump)) + (cons (list 'goto-if-false (cadr jump)) + (cdr rev-instrs)))))) + (else + rev-instrs))) + lst))) + lst)))) + +(define optimize-code + (lambda (code) + (let ((bbs (code->vector code))) + (resolve-toplevel-labels! bbs) + (tighten-jump-cascades! bbs) + (let ((bbs (remove-useless-bbs! bbs))) + (reorder! bbs))))) + +(define parse-file + (lambda (filename) + (let* ((library + (with-input-from-file "library.scm" read-all)) + (toplevel-exprs + (append library + (with-input-from-file filename read-all))) + (global-env + (make-global-env)) + (parsed-prog + (parse-top (cons 'begin toplevel-exprs) global-env))) + + (for-each + (lambda (node) + (mark-needed-global-vars! global-env node)) + parsed-prog) + + (extract-parts + parsed-prog + (lambda (defs after-defs) + + (define make-seq-preparsed + (lambda (exprs) + (let ((r (make-seq #f exprs))) + (for-each (lambda (x) (node-parent-set! x r)) exprs) + r))) + + (define make-call-preparsed + (lambda (exprs) + (let ((r (make-call #f exprs))) + (for-each (lambda (x) (node-parent-set! x r)) exprs) + r))) + + (if (var-needed? + (env-lookup global-env '#%readyq)) + (make-seq-preparsed + (list (make-seq-preparsed defs) + (make-call-preparsed + (list (parse 'value '#%start-first-process global-env) + (let* ((pattern + '()) + (ids + (extract-ids pattern)) + (r + (make-prc #f '() #f (has-rest-param? pattern) #f)) + (new-env + (env-extend global-env ids r)) + (body + (make-seq-preparsed after-defs))) + (prc-params-set! + r + (map (lambda (id) (env-lookup new-env id)) + ids)) + (node-children-set! r (list body)) + (node-parent-set! body r) + r))) + (parse 'value + '(#%exit) + global-env))) + (make-seq-preparsed + (append defs + after-defs + (list (parse 'value + '(#%halt) + global-env)))))))))) + +(define extract-parts + (lambda (lst cont) + (if (or (null? lst) + (not (def? (car lst)))) + (cont '() lst) + (extract-parts + (cdr lst) + (lambda (d ad) + (cont (cons (car lst) d) ad)))))) + +;------------------------------------------------------------------------------ + +;(include "asm.scm") + +;;; File: "asm.scm" +;;; +;;; This module implements the generic assembler. + +;(##declare (standard-bindings) (fixnum) (block)) + +(define compiler-internal-error error) + +;; (asm-begin! start-pos big-endian?) initializes the assembler and +;; starts a new empty code stream at address "start-pos". It must be +;; called every time a new code stream is to be built. The argument +;; "big-endian?" indicates the byte ordering to use for 16, 32 and 64 +;; bit values. After a call to "asm-begin!" the code stream is built +;; by calling the following procedures: +;; +;; asm-8 to add an 8 bit integer to the code stream +;; asm-16 to add a 16 bit integer to the code stream +;; asm-32 to add a 32 bit integer to the code stream +;; asm-64 to add a 64 bit integer to the code stream +;; asm-float64 to add a 64 bit IEEE float to the code stream +;; asm-string to add a null terminated string to the code stream +;; asm-label to set a label to the current position in the code stream +;; asm-align to add enough zero bytes to force alignment +;; asm-origin to add enough zero bytes to move to a particular address +;; asm-at-assembly to defer code production to assembly time +;; asm-listing to add textual information to the listing + +(define (asm-begin! start-pos big-endian?) + (set! asm-start-pos start-pos) + (set! asm-big-endian? big-endian?) + (set! asm-code-stream (asm-make-stream)) + #f) + +;; (asm-end!) must be called to finalize the assembler. + +(define (asm-end!) + (set! asm-code-stream #f) + #f) + +;; (asm-8 n) adds an 8 bit signed or unsigned integer to the code stream. + +(define (asm-8 n) + (asm-code-extend (asm-bits-0-to-7 n))) + +;; (asm-16 n) adds a 16 bit signed or unsigned integer to the code stream. + +(define (asm-16 n) + (if asm-big-endian? + (begin (asm-8 (asm-bits-8-and-up n)) (asm-8 n)) + (begin (asm-8 n) (asm-8 (asm-bits-8-and-up n))))) + +;; (asm-32 n) adds a 32 bit signed or unsigned integer to the code stream. + +(define (asm-32 n) + (if asm-big-endian? + (begin (asm-16 (asm-bits-16-and-up n)) (asm-16 n)) + (begin (asm-16 n) (asm-16 (asm-bits-16-and-up n))))) + +;; (asm-64 n) adds a 64 bit signed or unsigned integer to the code stream. + +(define (asm-64 n) + (if asm-big-endian? + (begin (asm-32 (asm-bits-32-and-up n)) (asm-32 n)) + (begin (asm-32 n) (asm-32 (asm-bits-32-and-up n))))) + +;; (asm-float64 n) adds a 64 bit IEEE floating point number to the code stream. + +(define (asm-float64 n) + (asm-64 (asm-float->bits n))) + +;; (asm-string str) adds a null terminated string to the code stream. + +(define (asm-string str) + (let ((len (string-length str))) + (let loop ((i 0)) + (if (< i len) + (begin + (asm-8 (char->integer (string-ref str i))) + (loop (+ i 1))) + (asm-8 0))))) + +(define (asm-u8vector u8) ;; ADDED, pretty much the same as strings + (let ((len (u8vector-length u8))) + (let loop ((i 0)) + (if (< i len) + (begin + (asm-8 (u8vector-ref u8 i)) + (loop (+ i 1))) + (asm-8 0))))) + +;; (asm-make-label id) creates a new label object. A label can +;; be queried with "asm-label-pos" to obtain the label's position +;; relative to the start of the code stream (i.e. "start-pos"). +;; The argument "id" gives a name to the label (not necessarily +;; unique) and is only needed for debugging purposes. + +(define (asm-make-label id) + (vector 'LABEL #f id)) + +;; (asm-label label-obj) sets the label to the current position in the +;; code stream. + +(define (asm-label label-obj) + (if (vector-ref label-obj 1) + (compiler-internal-error + "asm-label, label multiply defined" (asm-label-id label-obj)) + (begin + (vector-set! label-obj 1 0) + (asm-code-extend label-obj)))) + +;; (asm-label-id label-obj) returns the identifier of the label object. + +(define (asm-label-id label-obj) + (vector-ref label-obj 2)) + +;; (asm-label-pos label-obj) returns the position of the label +;; relative to the start of the code stream (i.e. "start-pos"). +;; This procedure can only be called at assembly time (i.e. +;; within the call to "asm-assemble") or after assembly time +;; for labels declared prior to assembly time with "asm-label". +;; A label declared at assembly time can only be queried after +;; assembly time. Moreover, at assembly time the position of a +;; label may vary from one call to the next due to the actions +;; of the assembler. + +(define (asm-label-pos label-obj) + (let ((pos (vector-ref label-obj 1))) + (if pos + pos + (compiler-internal-error + "asm-label-pos, undefined label" (asm-label-id label-obj))))) + +;; (asm-align multiple offset) adds enough zero bytes to the code +;; stream to force alignment to the next address congruent to +;; "offset" modulo "multiple". + +(define (asm-align multiple offset) + (asm-at-assembly + (lambda (self) + (modulo (- multiple (- self offset)) multiple)) + (lambda (self) + (let loop ((n (modulo (- multiple (- self offset)) multiple))) + (if (> n 0) + (begin + (asm-8 0) + (loop (- n 1)))))))) + +;; (asm-origin address) adds enough zero bytes to the code stream to move +;; to the address "address". + +(define (asm-origin address) + (asm-at-assembly + (lambda (self) + (- address self)) + (lambda (self) + (let ((len (- address self))) + (if (< len 0) + (compiler-internal-error "asm-origin, can't move back") + (let loop ((n len)) + (if (> n 0) + (begin + (asm-8 0) + (loop (- n 1)))))))))) + +;; (asm-at-assembly . procs) makes it possible to defer code +;; production to assembly time. A useful application is to generate +;; position dependent and span dependent code sequences. This +;; procedure must be passed an even number of procedures. All odd +;; indexed procedures (including the first procedure) are called "check" +;; procedures. The even indexed procedures are the "production" +;; procedures which, when called, produce a particular code sequence. +;; A check procedure decides if, given the current state of assembly +;; (in particular the current positioning of the labels), the code +;; produced by the corresponding production procedure is valid. +;; If the code is not valid, the check procedure must return #f. +;; If the code is valid, the check procedure must return the length +;; of the code sequence in bytes. The assembler will try each check +;; procedure in order until it finds one that does not return #f +;; (the last check procedure must never return #f). For convenience, +;; the current position in the code sequence is passed as the single +;; argument of check and production procedures. +;; +;; Here is a sample call of "asm-at-assembly" to produce the +;; shortest branch instruction to branch to label "x" for a +;; hypothetical processor: +;; +;; (asm-at-assembly +;; +;; (lambda (self) ; first check procedure +;; (let ((dist (- (asm-label-pos x) self))) +;; (if (and (>= dist -128) (<= dist 127)) ; short branch possible? +;; 2 +;; #f))) +;; +;; (lambda (self) ; first production procedure +;; (asm-8 #x34) ; branch opcode for 8 bit displacement +;; (asm-8 (- (asm-label-pos x) self))) +;; +;; (lambda (self) 5) ; second check procedure +;; +;; (lambda (self) ; second production procedure +;; (asm-8 #x35) ; branch opcode for 32 bit displacement +;; (asm-32 (- (asm-label-pos x) self)))) + +(define (asm-at-assembly . procs) + (asm-code-extend (vector 'DEFERRED procs))) + +;; (asm-listing text) adds text to the right side of the listing. +;; The atoms in "text" will be output using "display" (lists are +;; traversed recursively). The listing is generated by calling +;; "asm-display-listing". + +(define (asm-listing text) + (asm-code-extend (vector 'LISTING text))) + +;; (asm-assemble) assembles the code stream. After assembly, the +;; label objects will be set to their final position and the +;; alignment bytes and the deferred code will have been produced. It +;; is possible to extend the code stream after assembly. However, if +;; any of the procedures "asm-label", "asm-align", and +;; "asm-at-assembly" are called, the code stream will have to be +;; assembled once more. + +(define (asm-assemble) + (let ((fixup-lst (asm-pass1))) + + (let loop1 () + (let loop2 ((lst fixup-lst) + (changed? #f) + (pos asm-start-pos)) + (if (null? lst) + (if changed? (loop1)) + (let* ((fixup (car lst)) + (pos (+ pos (car fixup))) + (curr (cdr fixup)) + (x (car curr))) + (if (eq? (vector-ref x 0) 'LABEL) + ; LABEL + (if (= (vector-ref x 1) pos) + (loop2 (cdr lst) changed? pos) + (begin + (vector-set! x 1 pos) + (loop2 (cdr lst) #t pos))) + ; DEFERRED + (let loop3 () + (let ((n ((car (vector-ref x 1)) pos))) + (if n + (loop2 (cdr lst) changed? (+ pos n)) + (begin + (vector-set! x 1 (cddr (vector-ref x 1))) + (loop3)))))))))) + + (let loop4 ((prev asm-code-stream) + (curr (cdr asm-code-stream)) + (pos asm-start-pos)) + (if (null? curr) + (set-car! asm-code-stream prev) + (let ((x (car curr)) + (next (cdr curr))) + (if (vector? x) + (let ((kind (vector-ref x 0))) + (cond ((eq? kind 'LABEL) + (let ((final-pos (vector-ref x 1))) + (if final-pos + (if (not (= pos final-pos)) + (compiler-internal-error + "asm-assemble, inconsistency detected")) + (vector-set! x 1 pos)) + (set-cdr! prev next) + (loop4 prev next pos))) + ((eq? kind 'DEFERRED) + (let ((temp asm-code-stream)) + (set! asm-code-stream (asm-make-stream)) + ((cadr (vector-ref x 1)) pos) + (let ((tail (car asm-code-stream))) + (set-cdr! tail next) + (let ((head (cdr asm-code-stream))) + (set-cdr! prev head) + (set! asm-code-stream temp) + (loop4 prev head pos))))) + (else + (loop4 curr next pos)))) + (loop4 curr next (+ pos 1)))))))) + +;; (asm-display-listing port) produces a listing of the code stream +;; on the given output port. The bytes generated are shown in +;; hexadecimal on the left side of the listing and the right side +;; of the listing contains the text inserted by "asm-listing". + +(define (asm-display-listing port) + + (define text-col 24) + (define pos-width 6) + (define byte-width 2) + + (define (output text) + (cond ((null? text)) + ((pair? text) + (output (car text)) + (output (cdr text))) + (else + (display text port)))) + + (define (print-hex n) + (display (string-ref "0123456789ABCDEF" n) port)) + + (define (print-byte n) + (print-hex (quotient n 16)) + (print-hex (modulo n 16))) + + (define (print-pos n) + (if (< n 0) + (display " " port) + (begin + (print-byte (quotient n #x10000)) + (print-byte (modulo (quotient n #x100) #x100)) + (print-byte (modulo n #x100))))) + + (let loop1 ((lst (cdr asm-code-stream)) (pos asm-start-pos) (col 0)) + (if (null? lst) + (if (> col 0) + (newline port)) + (let ((x (car lst))) + (if (vector? x) + (let ((kind (vector-ref x 0))) + (cond ((eq? kind 'LISTING) + (let loop2 ((col col)) + (if (< col text-col) + (begin + (display (integer->char 9) port) + (loop2 (* 8 (+ (quotient col 8) 1)))))) + (output (vector-ref x 1)) + (newline port) + (loop1 (cdr lst) pos 0)) + (else + (compiler-internal-error + "asm-display-listing, code stream not assembled")))) + (if (or (= col 0) (>= col (- text-col byte-width))) + (begin + (if (not (= col 0)) (newline port)) + (print-pos pos) + (display " " port) + (print-byte x) + (loop1 (cdr lst) (+ pos 1) (+ (+ pos-width 1) byte-width))) + (begin + (print-byte x) + (loop1 (cdr lst) (+ pos 1) (+ col byte-width))))))))) + +;; (asm-write-code filename) outputs the code stream (i.e. the sequence +;; of bytes produced) on the named file. + +(define (asm-write-code filename) + (with-output-to-file filename + (lambda () + (let loop ((lst (cdr asm-code-stream))) + (if (not (null? lst)) + (let ((x (car lst))) + (if (vector? x) + (let ((kind (vector-ref x 0))) + (if (not (eq? kind 'LISTING)) + (compiler-internal-error + "asm-write-code, code stream not assembled")) + (loop (cdr lst))) + (begin + (write-char (integer->char x)) + (loop (cdr lst)))))))))) + +(define (asm-write-hex-file filename) + (with-output-to-file filename + (lambda () + + (define (print-hex n) + (display (string-ref "0123456789ABCDEF" n))) + + (define (print-byte n) + (print-hex (quotient n 16)) + (print-hex (modulo n 16))) + + (define (print-line type addr bytes) + (let ((n (length bytes)) + (addr-hi (quotient addr 256)) + (addr-lo (modulo addr 256))) + (display ":") + (print-byte n) + (print-byte addr-hi) + (print-byte addr-lo) + (print-byte type) + (for-each print-byte bytes) + (let ((sum + (modulo (- (apply + n addr-hi addr-lo type bytes)) 256))) + (print-byte sum) + (newline)))) + + (let loop ((lst (cdr asm-code-stream)) + (pos asm-start-pos) + (rev-bytes '())) + (if (not (null? lst)) + (let ((x (car lst))) + (if (vector? x) + (let ((kind (vector-ref x 0))) + (if (not (eq? kind 'LISTING)) + (compiler-internal-error + "asm-write-hex-file, code stream not assembled")) + (loop (cdr lst) + pos + rev-bytes)) + (let ((new-pos + (+ pos 1)) + (new-rev-bytes + (cons x + (if (= (modulo pos 16) 0) + (begin + (print-line 0 + (- pos (length rev-bytes)) + (reverse rev-bytes)) + '()) + rev-bytes)))) + (loop (cdr lst) + new-pos + new-rev-bytes)))) + (begin + (if (not (null? rev-bytes)) + (print-line 0 + (- pos (length rev-bytes)) + (reverse rev-bytes))) + (print-line 1 0 '()) + (if #t + (begin + (display (- pos asm-start-pos) ##stderr-port) + (display " bytes\n" ##stderr-port))))))))) + +;; Utilities. + +(define asm-start-pos #f) ; start position of the code stream +(define asm-big-endian? #f) ; endianness to use +(define asm-code-stream #f) ; current code stream + +(define (asm-make-stream) ; create an empty stream + (let ((x (cons '() '()))) + (set-car! x x) + x)) + +(define (asm-code-extend item) ; add an item at the end of current code stream + (let* ((stream asm-code-stream) + (tail (car stream)) + (cell (cons item '()))) + (set-cdr! tail cell) + (set-car! stream cell))) + +(define (asm-pass1) ; construct fixup list and make first label assignment + (let loop ((curr (cdr asm-code-stream)) + (fixup-lst '()) + (span 0) + (pos asm-start-pos)) + (if (null? curr) + (reverse fixup-lst) + (let ((x (car curr))) + (if (vector? x) + (let ((kind (vector-ref x 0))) + (cond ((eq? kind 'LABEL) + (vector-set! x 1 pos) ; first approximation of position + (loop (cdr curr) (cons (cons span curr) fixup-lst) 0 pos)) + ((eq? kind 'DEFERRED) + (loop (cdr curr) (cons (cons span curr) fixup-lst) 0 pos)) + (else + (loop (cdr curr) fixup-lst span pos)))) + (loop (cdr curr) fixup-lst (+ span 1) (+ pos 1))))))) + +;(##declare (generic)) + +(define (asm-bits-0-to-7 n) ; return bits 0 to 7 of a signed integer + (modulo n #x100)) + +(define (asm-bits-8-and-up n) ; return bits 8 and up of a signed integer + (if (>= n 0) + (quotient n #x100) + (- (quotient (+ n 1) #x100) 1))) + +(define (asm-bits-16-and-up n) ; return bits 16 and up of a signed integer + (if (>= n 0) + (quotient n #x10000) + (- (quotient (+ n 1) #x10000) 1))) + +(define (asm-bits-32-and-up n) ; return bits 32 and up of a signed integer + (if (>= n 0) + (quotient n #x100000000) + (- (quotient (+ n 1) #x100000000) 1))) + +; The following procedures convert floating point numbers into their +; machine representation. They perform bignum and flonum arithmetic. + +(define (asm-float->inexact-exponential-format x) + + (define (exp-form-pos x y i) + (let ((i*2 (+ i i))) + (let ((z (if (and (not (< asm-ieee-e-bias i*2)) + (not (< x y))) + (exp-form-pos x (* y y) i*2) + (cons x 0)))) + (let ((a (car z)) (b (cdr z))) + (let ((i+b (+ i b))) + (if (and (not (< asm-ieee-e-bias i+b)) + (not (< a y))) + (begin + (set-car! z (/ a y)) + (set-cdr! z i+b))) + z))))) + + (define (exp-form-neg x y i) + (let ((i*2 (+ i i))) + (let ((z (if (and (< i*2 asm-ieee-e-bias-minus-1) + (< x y)) + (exp-form-neg x (* y y) i*2) + (cons x 0)))) + (let ((a (car z)) (b (cdr z))) + (let ((i+b (+ i b))) + (if (and (< i+b asm-ieee-e-bias-minus-1) + (< a y)) + (begin + (set-car! z (/ a y)) + (set-cdr! z i+b))) + z))))) + + (define (exp-form x) + (if (< x asm-inexact-+1) + (let ((z (exp-form-neg x asm-inexact-+1/2 1))) + (set-car! z (* asm-inexact-+2 (car z))) + (set-cdr! z (- -1 (cdr z))) + z) + (exp-form-pos x asm-inexact-+2 1))) + + (if (negative? x) + (let ((z (exp-form (- asm-inexact-0 x)))) + (set-car! z (- asm-inexact-0 (car z))) + z) + (exp-form x))) + +(define (asm-float->exact-exponential-format x) + (let ((z (asm-float->inexact-exponential-format x))) + (let ((y (car z))) + (cond ((not (< y asm-inexact-+2)) + (set-car! z asm-ieee-+m-min) + (set-cdr! z asm-ieee-e-bias-plus-1)) + ((not (< asm-inexact--2 y)) + (set-car! z asm-ieee--m-min) + (set-cdr! z asm-ieee-e-bias-plus-1)) + (else + (set-car! z + (truncate (inexact->exact (* (car z) asm-inexact-m-min)))))) + (set-cdr! z (- (cdr z) asm-ieee-m-bits)) + z))) + +(define (asm-float->bits x) ; returns the 64 bit integer encoding the float "x" + + (define (bits a b) + (if (< a asm-ieee-+m-min) + a + (+ (- a asm-ieee-+m-min) + (* (+ (+ b asm-ieee-m-bits) asm-ieee-e-bias) + asm-ieee-+m-min)))) + + (let ((z (asm-float->exact-exponential-format x))) + (let ((a (car z)) (b (cdr z))) + (if (negative? a) + (+ asm-ieee-sign-bit (bits (- 0 a) b)) + (bits a b))))) + +; Parameters for ANSI-IEEE Std 754-1985 representation of +; doubles (i.e. 64 bit floating point numbers): + +(define asm-ieee-m-bits 52) +(define asm-ieee-e-bits 11) +(define asm-ieee-+m-min 4503599627370496) ; (expt 2 asm-ieee-m-bits) +(define asm-ieee--m-min -4503599627370496) ; (- asm-ieee-+m-min) +(define asm-ieee-sign-bit #x8000000000000000); (expt 2 (+ asm-ieee-e-bits asm-ieee-m-bits)) + +(define asm-ieee-e-bias 1023) ; (- (expt 2 (- asm-ieee-e-bits 1)) 1) +(define asm-ieee-e-bias-plus-1 1024) ; (+ asm-ieee-e-bias 1) +(define asm-ieee-e-bias-minus-1 1022) ; (- asm-ieee-e-bias 1) + +(define asm-inexact-m-min (exact->inexact asm-ieee-+m-min)) +(define asm-inexact-+2 (exact->inexact 2)) +(define asm-inexact--2 (exact->inexact -2)) +(define asm-inexact-+1 (exact->inexact 1)) +(define asm-inexact-+1/2 (exact->inexact (/ 1 2))) +(define asm-inexact-0 (exact->inexact 0)) + +;------------------------------------------------------------------------------ + +(define min-fixnum-encoding 3) +(define min-fixnum -5) +(define max-fixnum 40) +(define min-rom-encoding (+ min-fixnum-encoding (- max-fixnum min-fixnum) 1)) +(define min-ram-encoding 128) +(define max-ram-encoding 255) + +(define code-start #x2000) + +(define (predef-constants) + (list)) + +(define (predef-globals) + (list)) + +(define (encode-direct obj) + (cond ((eq? obj #f) + 0) + ((eq? obj #t) + 1) + ((eq? obj '()) + 2) + ((and (integer? obj) + (exact? obj) + (>= obj min-fixnum) + (<= obj max-fixnum)) + (+ obj (- min-fixnum-encoding min-fixnum))) + (else + #f))) + +(define (translate-constant obj) + (if (char? obj) + (char->integer obj) + obj)) + +(define (encode-constant obj constants) + (let ((o (translate-constant obj))) + (let ((e (encode-direct o))) + (if e + e + (let ((x (assq o constants))) + (if x + (vector-ref (cdr x) 0) + (compiler-error "unknown object" obj))))))) + +(define (add-constant obj constants from-code? cont) + (let ((o (translate-constant obj))) + (let ((e (encode-direct o))) + (if e + (cont constants) + (let ((x (assq o constants))) + (if x + (begin + (if from-code? + (vector-set! (cdr x) 2 (+ (vector-ref (cdr x) 2) 1))) + (cont constants)) + (let* ((descr + (vector #f + (asm-make-label 'constant) + (if from-code? 1 0) + #f)) + (new-constants + (cons (cons o descr) + constants))) + (cond ((pair? o) + (add-constants (list (car o) (cdr o)) + new-constants + cont)) + ((symbol? o) + (cont new-constants)) + ((string? o) + (let ((chars (map char->integer (string->list o)))) + (vector-set! descr 3 chars) + (add-constant chars + new-constants + #f + cont))) + ((vector? o) + (let ((elems (vector->list o))) + (vector-set! descr 3 elems) + (add-constant elems + new-constants + #f + cont))) + + (else + (cont new-constants)))))))))) + +(define (add-constants objs constants cont) + (if (null? objs) + (cont constants) + (add-constant (car objs) + constants + #f + (lambda (new-constants) + (add-constants (cdr objs) + new-constants + cont))))) + +(define (add-global var globals cont) + (let ((x (assq var globals))) + (if x + (cont globals) + (let ((new-globals + (cons (cons var (length globals)) + globals))) + (cont new-globals))))) + +(define (sort-constants constants) + (let ((csts + (sort-list constants + (lambda (x y) + (> (vector-ref (cdr x) 2) + (vector-ref (cdr y) 2)))))) + (let loop ((i min-rom-encoding) + (lst csts)) + (if (null? lst) + (if (> i min-ram-encoding) + (compiler-error "too many constants") + csts) + (begin + (vector-set! (cdr (car lst)) 0 i) + (loop (+ i 1) + (cdr lst))))))) + +(define assemble + (lambda (code hex-filename) + (let loop1 ((lst code) + (constants (predef-constants)) + (globals (predef-globals)) + (labels (list))) + (if (pair? lst) + + (let ((instr (car lst))) + (cond ((number? instr) + (loop1 (cdr lst) + constants + globals + (cons (cons instr (asm-make-label 'label)) + labels))) + ((eq? (car instr) 'push-constant) + (add-constant (cadr instr) + constants + #t + (lambda (new-constants) + (loop1 (cdr lst) + new-constants + globals + labels)))) + ((memq (car instr) '(push-global set-global)) + (add-global (cadr instr) + globals + (lambda (new-globals) + (loop1 (cdr lst) + constants + new-globals + labels)))) + (else + (loop1 (cdr lst) + constants + globals + labels)))) + + (let ((constants (sort-constants constants))) + + (define (label-instr label opcode) + (asm-at-assembly + (lambda (self) + 2) + (lambda (self) + (let ((pos (- (asm-label-pos label) code-start))) + (asm-8 (+ (quotient pos 256) opcode)) + (asm-8 (modulo pos 256)))))) + + (define (push-constant n) + (if (<= n 31) + (asm-8 (+ #x00 n)) + (begin + (asm-8 #xfc) + (asm-8 n)))) + + (define (push-stack n) + (if (> n 31) + (compiler-error "stack is too deep") + (asm-8 (+ #x20 n)))) + + (define (push-global n) + (if (> n 15) + (compiler-error "too many global variables") + (asm-8 (+ #x40 n)))) + + (define (set-global n) + (if (> n 15) + (compiler-error "too many global variables") + (asm-8 (+ #x50 n)))) + + (define (call n) + (if (> n 15) + (compiler-error "call has too many arguments") + (asm-8 (+ #x60 n)))) + + (define (jump n) + (if (> n 15) + (compiler-error "call has too many arguments") + (asm-8 (+ #x70 n)))) + + (define (call-toplevel label) + (label-instr label #x80)) + + (define (jump-toplevel label) + (label-instr label #x90)) + + (define (goto label) + (label-instr label #xa0)) + + (define (goto-if-false label) + (label-instr label #xb0)) + + (define (closure label) + (label-instr label #xc0)) + + (define (prim n) + (asm-8 (+ #xd0 n))) + + (define (prim.number?) (prim 0)) + (define (prim.+) (prim 1)) + (define (prim.-) (prim 2)) + (define (prim.*) (prim 3)) + (define (prim.quotient) (prim 4)) + (define (prim.remainder) (prim 5)) + (define (prim.neg) (prim 6)) + (define (prim.=) (prim 7)) + (define (prim.<) (prim 8)) + (define (prim.<=) (prim 9)) + (define (prim.>) (prim 10)) + (define (prim.>=) (prim 11)) + (define (prim.pair?) (prim 12)) + (define (prim.cons) (prim 13)) + (define (prim.car) (prim 14)) + (define (prim.cdr) (prim 15)) + (define (prim.set-car!) (prim 16)) + (define (prim.set-cdr!) (prim 17)) + (define (prim.null?) (prim 18)) + (define (prim.eq?) (prim 19)) + (define (prim.not) (prim 20)) + (define (prim.get-cont) (prim 21)) + (define (prim.graft-to-cont) (prim 22)) + (define (prim.return-to-cont) (prim 23)) + (define (prim.halt) (prim 24)) + (define (prim.symbol?) (prim 25)) + (define (prim.string?) (prim 26)) + (define (prim.string->list) (prim 27)) + (define (prim.list->string) (prim 28)) + (define (prim.cast-int) (prim 29)) ;; ADDED + + (define (prim.print) (prim 32)) + (define (prim.clock) (prim 33)) + (define (prim.motor) (prim 34)) + (define (prim.led) (prim 35)) + (define (prim.getchar-wait) (prim 36)) + (define (prim.putchar) (prim 37)) + (define (prim.light) (prim 38)) + + (define (prim.shift) (prim 45)) + (define (prim.pop) (prim 46)) + (define (prim.return) (prim 47)) + + (define big-endian? #f) + + (asm-begin! code-start #f) + + (asm-8 #xfb) + (asm-8 #xd7) + (asm-8 (length constants)) + (asm-8 0) + +; (pp (list constants: constants globals: globals)) + + (for-each + (lambda (x) + (let* ((descr (cdr x)) + (label (vector-ref descr 1)) + (obj (car x))) + (asm-label label) + (cond ((and (integer? obj) (exact? obj)) + (asm-8 0) + (asm-8 (bitwise-and (arithmetic-shift obj -16) 255)) + (asm-8 (bitwise-and (arithmetic-shift obj -8) 255)) + (asm-8 (bitwise-and obj 255))) + ((pair? obj) + (asm-8 2) + (asm-8 (encode-constant (car obj) constants)) + (asm-8 (encode-constant (cdr obj) constants)) + (asm-8 0)) + ((symbol? obj) + (asm-8 3) + (asm-8 0) + (asm-8 0) + (asm-8 0)) + ((string? obj) + (asm-8 4) + (asm-8 (encode-constant (vector-ref descr 3) constants)) + (asm-8 0) + (asm-8 0)) + ((vector? obj) + (asm-8 5) + (asm-8 (encode-constant (vector-ref descr 3) constants)) + (asm-8 0) + (asm-8 0)) + (else + (compiler-error "unknown object type" obj))))) + constants) + + (let loop2 ((lst code)) + (if (pair? lst) + (let ((instr (car lst))) + + (cond ((number? instr) + (let ((label (cdr (assq instr labels)))) + (asm-label label))) + + ((eq? (car instr) 'entry) + (let ((np (cadr instr)) + (rest? (caddr instr))) + (asm-8 (if rest? (- np) np)))) + + ((eq? (car instr) 'push-constant) + (let ((n (encode-constant (cadr instr) constants))) + (push-constant n))) + + ((eq? (car instr) 'push-stack) + (push-stack (cadr instr))) + + ((eq? (car instr) 'push-global) + (push-global (cdr (assq (cadr instr) globals)))) + + ((eq? (car instr) 'set-global) + (set-global (cdr (assq (cadr instr) globals)))) + + ((eq? (car instr) 'call) + (call (cadr instr))) + + ((eq? (car instr) 'jump) + (jump (cadr instr))) + + ((eq? (car instr) 'call-toplevel) + (let ((label (cdr (assq (cadr instr) labels)))) + (call-toplevel label))) + + ((eq? (car instr) 'jump-toplevel) + (let ((label (cdr (assq (cadr instr) labels)))) + (jump-toplevel label))) + + ((eq? (car instr) 'goto) + (let ((label (cdr (assq (cadr instr) labels)))) + (goto label))) + + ((eq? (car instr) 'goto-if-false) + (let ((label (cdr (assq (cadr instr) labels)))) + (goto-if-false label))) + + ((eq? (car instr) 'closure) + (let ((label (cdr (assq (cadr instr) labels)))) + (closure label))) + + ((eq? (car instr) 'prim) + (case (cadr instr) + ((#%number?) (prim.number?)) + ((#%+) (prim.+)) + ((#%-) (prim.-)) + ((#%*) (prim.*)) + ((#%quotient) (prim.quotient)) + ((#%remainder) (prim.remainder)) + ((#%neg) (prim.neg)) + ((#%=) (prim.=)) + ((#%<) (prim.<)) + ((#%<=) (prim.<=)) + ((#%>) (prim.>)) + ((#%>=) (prim.>=)) + ((#%pair?) (prim.pair?)) + ((#%cons) (prim.cons)) + ((#%car) (prim.car)) + ((#%cdr) (prim.cdr)) + ((#%set-car!) (prim.set-car!)) + ((#%set-cdr!) (prim.set-cdr!)) + ((#%null?) (prim.null?)) + ((#%eq?) (prim.eq?)) + ((#%not) (prim.not)) + ((#%get-cont) (prim.get-cont)) + ((#%graft-to-cont) (prim.graft-to-cont)) + ((#%return-to-cont) (prim.return-to-cont)) + ((#%halt) (prim.halt)) + ((#%symbol?) (prim.symbol?)) + ((#%string?) (prim.string?)) + ((#%string->list) (prim.string->list)) + ((#%list->string) (prim.list->string)) + ((#%cast-int) (prim.cast-int)) ;; ADDED + + ((#%print) (prim.print)) + ((#%clock) (prim.clock)) + ((#%motor) (prim.motor)) + ((#%led) (prim.led)) + ((#%getchar-wait) (prim.getchar-wait)) + ((#%putchar) (prim.putchar)) + ((#%light) (prim.light)) + (else + (compiler-error "unknown primitive" (cadr instr))))) + + ((eq? (car instr) 'return) + (prim.return)) + + ((eq? (car instr) 'pop) + (prim.pop)) + + ((eq? (car instr) 'shift) + (prim.shift)) + + (else + (compiler-error "unknown instruction" instr))) + + (loop2 (cdr lst))))) + + (asm-assemble) + + (asm-write-hex-file hex-filename) + + (asm-end!)))))) + +(define execute + (lambda (hex-filename) +' + (if #f + (begin + (shell-command "gcc -o picobit-vm picobit-vm.c") + (shell-command (string-append "./picobit-vm " hex-filename))) + (shell-command (string-append "./robot . 1 " hex-filename))))) + +(define (sort-list l expr node)) + + (let ((ctx (comp-none node (make-init-context)))) + (let ((prog (linearize (optimize-code (context-code ctx))))) +; (pp (list code: prog env: (context-env ctx))) + (assemble prog hex-filename) + (execute hex-filename)))))) + + +(define main + (lambda (filename) + (compile filename))) + +;------------------------------------------------------------------------------ + +' +(define (asm-write-hex-file filename) + (with-output-to-file filename + (lambda () + + (define (print-hex n) + (display (string-ref "0123456789ABCDEF" n))) + + (define (print-byte n) + (display ", 0x") + (print-hex (quotient n 16)) + (print-hex (modulo n 16))) + + (define (print-line type addr bytes) + (let ((n (length bytes)) + (addr-hi (quotient addr 256)) + (addr-lo (modulo addr 256))) +; (display ":") +; (print-byte n) +; (print-byte addr-hi) +; (print-byte addr-lo) +; (print-byte type) + (for-each print-byte bytes) + (let ((sum + (modulo (- (apply + n addr-hi addr-lo type bytes)) 256))) +; (print-byte sum) + (newline)))) + + (let loop ((lst (cdr asm-code-stream)) + (pos asm-start-pos) + (rev-bytes '())) + (if (not (null? lst)) + (let ((x (car lst))) + (if (vector? x) + (let ((kind (vector-ref x 0))) + (if (not (eq? kind 'LISTING)) + (compiler-internal-error + "asm-write-hex-file, code stream not assembled")) + (loop (cdr lst) + pos + rev-bytes)) + (let ((new-pos + (+ pos 1)) + (new-rev-bytes + (cons x + (if (= (modulo pos 8) 0) + (begin + (print-line 0 + (- pos (length rev-bytes)) + (reverse rev-bytes)) + '()) + rev-bytes)))) + (loop (cdr lst) + new-pos + new-rev-bytes)))) + (begin + (if (not (null? rev-bytes)) + (print-line 0 + (- pos (length rev-bytes)) + (reverse rev-bytes))) + (print-line 1 0 '()))))))) diff --git a/red-green.scm b/red-green.scm new file mode 100644 index 0000000..e615e57 --- /dev/null +++ b/red-green.scm @@ -0,0 +1,18 @@ +; File: "red-green.scm" + +(define loop + (lambda () + + (led 'green) ; set LED to green + (putchar #\G) ; send a "G" to the console + (led 'off) ; turn off LED + (sleep 100) ; wait 1 second + + (led 'red) ; set LED to red + (putchar #\R) ; send an "R" to the console + (led 'off) ; turn off LED + (sleep 100) ; wait 1 second + + (loop))) ; repeat + +(loop) diff --git a/robot.scm b/robot.scm new file mode 100644 index 0000000..4fedae0 --- /dev/null +++ b/robot.scm @@ -0,0 +1,927 @@ +; File: "robot.scm", Time-stamp: <2006-03-01 15:57:44 feeley> + +; Copyright (C) 2006 by Marc Feeley, All Rights Reserved. + +; usage: usage: robot [[BASE_HOSTNAME|.] ID [HEX_FILE]] + +(define debug? #f) + +;------------------------------------------------------------------------------ + +(define default-base "localhost") ; internet address of base-station server +(define port-number 12345) + +;------------------------------------------------------------------------------ + +(define version-addr 6) +(define program-filename "robot.hex") +(define program-start-addr #x2000) + +(define serial-port-name "com1") ; default, works for Windows + +(let loop ((lst '("/dev/cu.USA28X181P1.1" + "/dev/cu.USA28X181P2.2" + "/dev/cu.USA28X191P1.1" + "/dev/cu.USA28X191P2.2" + "/dev/ttyS0" + "/dev/ttyS1"))) + (if (not (null? lst)) + (let ((name (car lst))) + (if (file-exists? name) + (set! serial-port-name name) + (loop (cdr lst)))))) + +;------------------------------------------------------------------------------ + +(define log-file + (and debug? + (with-exception-catcher + (lambda (exc) + #f) + (lambda () + (open-output-file (list path: "robot.log" buffering: 'line)))))) + +;------------------------------------------------------------------------------ + +(current-user-interrupt-handler exit) + +(define (main . args) + + (define (usage) + (display "usage: robot [[BASE_HOSTNAME|.] ID [HEX_FILE]]\n")) + + (define (parse-arg1 args) + (if (null? args) + (parse-arg4 #f #f #f) + (let ((arg (car args))) + (if (exact-int? (string->number arg)) + (parse-arg2 default-base args) + (parse-arg2 arg (cdr args)))))) + + (define (parse-arg2 base args) + (if (null? args) + (usage) + (let ((arg (string->number (car args)))) + (if (and (exact-int? arg) + (>= arg 0) + (< arg nb-ids)) + (parse-arg3 base arg (cdr args)) + (usage))))) + + (define (parse-arg3 base id args) + (if (null? args) + (parse-arg4 base id #f) + (let ((arg (car args))) + (if (null? (cdr args)) + (parse-arg4 base id arg) + (usage))))) + + (define (parse-arg4 base id filename) + (if id + (start-client base id filename program-start-addr) + (start-base))) + + (parse-arg1 args)) + +(define (exact-int? x) + (and (integer? x) (exact? x))) + +(define (start-base) + (multiplex) + (let ((connection-queue + (open-tcp-server + (list port-number: port-number + reuse-address: #t + eol-encoding: 'cr-lf)))) + (let loop () + (serve (read connection-queue)) + (loop)))) + +(define (start-client base id filename start-addr) + (set! program-start-addr start-addr) + (let ((connection + (if (string=? base ".") + (receive (client server) (open-string-pipe) + (multiplex) + (serve server) + client) + (open-tcp-client + (list server-address: base + port-number: port-number + eol-encoding: 'cr-lf))))) + (send (list id + (with-exception-catcher + (lambda (exc) + "???") + (lambda () + (host-info-name (host-info ""))))) + connection) + (let ((ack (read connection))) + (if (equal? ack '(ok)) + (begin + (if filename + (begin + (set! program-filename filename) + (start-client-upload connection id))) + (start-client-console connection id)) + (display + (list "Another client is already connected to robot " id "\n")))) + (close-port connection))) + +(define (start-client-upload connection id) + (let ((mem (read-hex-file program-filename))) + (if mem + (upload connection id mem program-start-addr)))) + +(define (start-client-console connection id) + + (define (restart-robot) + (restart connection id) + (start-client-console connection id)) + + (define (upload-again) + (start-client-upload connection id) + (start-client-console connection id)) + + (define (stop-robot) + (stop connection id) + (start-client-console connection id)) + + (display + (list "###\n### Console:\n")) + (let ((input (repl-input-port))) + (if (tty? input) + (tty-mode-set! input #t #t #t #f 0))) + (let ((input (repl-input-port)) + (can-send-key #t) + (tx-seq-num 0) + (rx-seq-num 0)) + (let loop1 ((state 0)) + (input-port-timeout-set! connection 0.01) + (let ((x (read connection))) + (if (not (eof-object? x)) + (cond ((or (eq? x 'err) + (eq? x 'noerr)) + (set! can-send-key #t)) + (else + (if debug? (pp x)) + (if (u8vector? x) + (if (and (>= (u8vector-length x) 3) + (= (quotient (u8vector-ref x 0) nb-ids) + MSG_TYPE_STDIO)) + (let ((seq-num (u8vector-ref x 1))) + (if (not (= seq-num rx-seq-num)) + (begin + (set! rx-seq-num seq-num) + (let loop2 ((i 2)) + (if (< i (u8vector-length x)) + (let ((n (u8vector-ref x i))) + (cond ((= n 10) + (display "\n")) + ;((= n 13) + ;(display "\n")) + ((or (< n 32) (> n 126)) + (display + (list "<" n ">"))) + (else + (write-char (integer->char n)))) + (loop2 (+ i 1)))))))) + (write (u8vector->list x)))))))) + (if can-send-key + (begin + (input-port-timeout-set! input 0.01) + (let ((x (read-char input))) + + (define (got x) + (send + (vector 'send-message + (+ id (* nb-ids MSG_TYPE_STDIO)) + (u8vector tx-seq-num + (char->integer x))) + connection) + (set! can-send-key #f) + (set! tx-seq-num (modulo (+ tx-seq-num 1) 256)) + (loop1 0)) + + (if (char? x) + (cond ((char=? x #\tab) + (upload-again)) + (else + (cond ((= state 0) + (cond ((char=? x #\u001b) + (loop1 1)) + (else + (got x)))) + ((= state 1) + (cond ;((char=? x #\u001b)) + ((char=? x #\[) + (loop1 3)) + ((char=? x #\O) + (loop1 2)) + (else + (got x)))) + ((= state 2) + (cond ((char=? x #\P) ; F1 + (stop-robot)) + ((char=? x #\Q) ; F2 + (restart-robot)) + ((char=? x #\R) ; F3 + (upload-again)) + ((char=? x #\S) ; F4 + ) + (else + #f))) + (else + (cond ((char=? x #\A) + (got #\u008d)) + ((char=? x #\B) + (got #\u008f)) + ((char=? x #\C) + (got #\u008e)) + ((char=? x #\D) + (got #\u008c)) + (else + (got x))))))) + (loop1 state)))) + (loop1 state))))) + +;------------------------------------------------------------------------------ + +(define (read-hex-file filename) + + (define addr-width 32) + + (define (syntax-error) + (error "Improper HEX file")) + + (let ((f + (with-exception-catcher + (lambda (exc) + #f) + (lambda () + (open-input-file filename))))) + + (define mem (make-vector 16 #f)) + + (define (mem-store! a b) + (let loop ((m mem) + (a a) + (x (- addr-width 4))) + (if (= x 0) + (vector-set! m a b) + (let ((i (arithmetic-shift a (- x)))) + (let ((v (vector-ref m i))) + (loop (or v + (let ((v (make-vector 16 #f))) + (vector-set! m i v) + v)) + (- a (arithmetic-shift i x)) + (- x 4))))))) + + (define (mem->list) + + (define (f m a n tail) + + (define (g i a n tail) + (if (>= i 0) + (g (- i 1) (- a n) n (f (vector-ref m i) a n tail)) + tail)) + + (if m + (if (= n 1) + (cons (cons (- a 1) m) tail) + (g 15 a (quotient n 16) tail)) + tail)) + + (f mem (expt 2 addr-width) (expt 2 addr-width) '())) + + (define hi16 + 0) + + (define (read-hex-nibble) + (let ((c (read-char f))) + (cond ((and (char>=? c #\0) (char<=? c #\9)) + (- (char->integer c) (char->integer #\0))) + ((and (char>=? c #\A) (char<=? c #\F)) + (+ 10 (- (char->integer c) (char->integer #\A)))) + ((and (char>=? c #\a) (char<=? c #\f)) + (+ 10 (- (char->integer c) (char->integer #\a)))) + (else + (syntax-error))))) + + (define (read-hex-byte) + (let* ((a (read-hex-nibble)) + (b (read-hex-nibble))) + (+ b (* a 16)))) + + (if f + (begin + (let loop1 () + (let ((c (read-char f))) + (cond ((not (char? c))) + ((or (char=? c #\linefeed) + (char=? c #\return)) + (loop1)) + ((not (char=? c #\:)) + (syntax-error)) + (else + (let* ((len (read-hex-byte)) + (a1 (read-hex-byte)) + (a2 (read-hex-byte)) + (type (read-hex-byte))) + (let* ((adr (+ a2 (* 256 a1))) + (sum (+ len a1 a2 type))) + (cond ((= type 0) + (let loop2 ((i 0)) + (if (< i len) + (let ((a (+ adr (* hi16 65536))) + (b (read-hex-byte))) + (mem-store! a b) + (set! adr (modulo (+ adr 1) 65536)) + (set! sum (+ sum b)) + (loop2 (+ i 1)))))) + ((= type 1) + (if (not (= len 0)) + (syntax-error))) + ((= type 4) + (if (not (= len 2)) + (syntax-error)) + (let* ((a1 (read-hex-byte)) + (a2 (read-hex-byte))) + (set! sum (+ sum a1 a2)) + (set! hi16 (+ a2 (* 256 a1))))) + (else + (syntax-error))) + (let ((check (read-hex-byte))) + (if (not (= (modulo (- sum) 256) check)) + (syntax-error))) + (let ((c (read-char f))) + (if (or (not (or (char=? c #\linefeed) + (char=? c #\return))) + (not (= type 1))) + (loop1))))))))) + + (close-input-port f) + + (mem->list)) + (begin + (display + (list "\n### The file " filename " does not exist\n")) + #f)))) + +(define (upload connection id mem start-addr) + + (define max-programmable-address 65535) + + (define bp 8) ; program block size + (define be 64) ; erase block size + + (if (start-programming connection id) + (begin + (let loop1 ((last-erased-be -1) + (lst mem)) + (if (pair? lst) + (let* ((x (car lst)) + (a (car x)) + (a-bp (quotient a bp)) + (a-be (quotient a be)) + (bp-bytes (make-u8vector bp 255))) + (if (<= a max-programmable-address) + (if (or (= a-be last-erased-be) + (let ((a (* a-be be))) + (or (< a start-addr) + (erase-block connection id a)))) + (begin + (u8vector-set! bp-bytes (modulo a bp) (cdr x)) + (let loop2 ((lst2 (cdr lst))) + (if (and (pair? lst2) + (let ((a (car (car lst2)))) + (and (<= a max-programmable-address) + (= (quotient a bp) a-bp)))) + (begin + (u8vector-set! bp-bytes + (modulo (car (car lst2)) bp) + (cdr (car lst2))) + (loop2 (cdr lst2))) + (if (let ((a (* a-bp bp))) + (or (< a start-addr) + (program-block connection id a bp-bytes))) + (loop1 a-be + lst2)))))) + (reboot connection id))) + (reboot connection id)))))) + +(define (request cmd connection) + (let loop ((n 10)) + (if (> n 0) + (begin + (display ".") + (let ((x (request-once cmd connection))) + (if (eq? x 'err) + (begin + (thread-sleep! 2) + (loop (- n 1))) + (begin + (display "\n") + #t)))) + (begin + (display " ERROR!\n") + #f)))) + +(define (request-once cmd connection) + (send cmd connection) + (let loop () + (let ((x (read connection))) + (cond ((or (eq? x 'err) + (eq? x 'noerr)) + x) + (else + (loop)))))) + +(define (request-version connection id) + + (define (version-msg? version) + (and (u8vector? version) + (= (u8vector-length version) 5) + (= (u8vector-ref version 1) + (quotient version-addr 256)) + (= (u8vector-ref version 2) + (modulo version-addr 256)))) + + (define (return x) + (input-port-timeout-set! connection #f) + x) + + (request-once (vector 'set-program-mode id) connection) + (send + (vector 'send-message + (+ id (* nb-ids MSG_TYPE_PROGRAM)) + (u8vector (quotient version-addr 256) + (modulo version-addr 256) + 1)) + connection) + (input-port-timeout-set! connection 1) + (let loop ((ack #f) + (version #f)) + (let ((x (read connection))) + (cond ((eof-object? x) + (if ack + (return #f) + (loop ack version))) + ((or (eq? x 'err) + (eq? x 'noerr)) + (if version + (return version) + (loop #t #f))) + (else + (if (version-msg? x) + (if ack + (return x) + (loop #f x)) + (loop ack version))))))) + +(define (send obj port) + (write obj port) + (newline port) + (force-output port)) + +(define (start-programming connection id) + (display + (list "\n### Programming robot " id " with " program-filename)) + (enter-program-mode connection id)) + +(define (stop connection id) + (display + (list "\n### Stopping robot " id)) + (enter-program-mode connection id)) + +(define (restart connection id) + (display + (list "###\n### Connecting to robot " id)) + (enter-program-mode connection id) + (reboot connection id)) + +(define (enter-program-mode connection id) + (let loop ((n 5)) + (if (> n 0) + (begin + (display ".") + (let ((version (request-version connection id))) + (if version + (let ((version-major (u8vector-ref version 3)) + (version-minor (u8vector-ref version 4))) + (if (and (= version-major 1) + (= version-minor 0)) + (begin + (display "\n") + #t) + (begin + (display " INCOMPATIBLE FIRMWARE!\n") + #f))) + (loop (- n 1))))) + (begin + (display " THE ROBOT IS NOT RESPONDING!\n") + #f)))) + +(define (erase-block connection id addr) +; (set! addr (+ addr #x2000)) + (display + (list "###\n### Erasing block 0x" + (number->string addr 16))) + (request + (vector 'send-message + (+ id (* nb-ids MSG_TYPE_PROGRAM)) + (u8vector (quotient addr 256) + (modulo addr 256))) + connection)) + +(define (program-block connection id addr bytes) +; (set! addr (+ addr #x2000)) + (display + (list "### Programming block 0x" + (number->string addr 16))) + (request + (vector 'send-message + (+ id (* nb-ids MSG_TYPE_PROGRAM)) + (u8vector-append + (u8vector (quotient addr 256) + (modulo addr 256)) + bytes)) + connection)) + +(define (reboot connection id) + (display + (list "###\n### Restarting robot")) + (request + (vector 'send-message + (+ id (* nb-ids MSG_TYPE_PROGRAM)) + (u8vector 0 0)) + connection)) + +;------------------------------------------------------------------------------ + +; Server side. + +(define nb-ids 32) +(define mutex #f) +(define clients #f) +(define multiplexer #f) +(define rs232 #f) + +(define (multiplex) + + (set! mutex (make-mutex)) + (set! clients (make-vector nb-ids #f)) + (set! multiplexer (open-vector)) + + (set! rs232 + (open-file + (list path: serial-port-name + eol-encoding: 'cr-lf))) + (if (tty? rs232) + (tty-mode-set! rs232 #f #f #t #t 38400)) + + (thread-sleep! 0.1) + (rs232-flush-input) + + (thread-start! + (make-thread + (lambda () + (let loop1 () + (input-port-timeout-set! multiplexer 0.01) + (let loop2 () + (let ((x (read multiplexer))) + (if (vector? x) + (let* ((id (vector-ref x 0)) + (cmd (vector-ref x 1)) + (cmd-type (vector-ref cmd 0))) + (cond ((eq? cmd-type 'send-message) + (let ((dest (vector-ref cmd 1)) + (bytes (vector-ref cmd 2))) + (if (send-message dest bytes) + (let ((s (wait-until-end-of-tx))) + (cond ((not s) + (send-to-id 'err id) + (loop2)) + ((not (= (bitwise-and s NOERR_MASK) 0)) + (ir-tx-event-noerr-ack) + (send-to-id 'noerr id) + (loop2)) + ((not (= (bitwise-and s ERR_MASK) 0)) + (ir-tx-event-err-ack) + (send-to-id 'err id) + (loop2)) + (else + (send-to-id 'err id) + (loop2)))) + (begin + (send-to-id 'err id) + (loop2))))) + ((eq? cmd-type 'set-program-mode) + (let ((dest (vector-ref cmd 1))) + (if (set-program-mode dest) + (let ((s (wait-until-end-of-tx))) + (cond ((not s) + (send-to-id 'err id) + (loop2)) + ((not (= (bitwise-and s NOERR_MASK) 0)) + (ir-tx-event-noerr-ack) + (send-to-id 'noerr id) + (loop2)) + ((not (= (bitwise-and s ERR_MASK) 0)) + (ir-tx-event-err-ack) + (send-to-id 'noerr id) + (loop2)) + (else + (send-to-id 'err id) + (loop2)))) + (begin + (send-to-id 'err id) + (loop2))))) + (else + (loop2)))) + (begin + (poll-status-handling-rx) + (loop1)))))))))) + +(define (set-program-mode dest) + (let ((s (prepare-to-tx))) + (and s + (let ((b (+ dest (* nb-ids MSG_TYPE_SET_PROG_MODE)))) + (ir-tx-special (- #xff b) b))))) + +(define (send-message dest bytes) + (let ((s (prepare-to-tx))) + (and s + (begin + (display + (list "sending to " (modulo dest nb-ids) ": ")) + (write (u8vector->list bytes)) + (display "\n") + (ir-tx dest bytes))))) + +(define (prepare-to-tx) + (let loop () + (let ((s (wait-until-end-of-tx))) + (cond ((not s) + #f) + ((not (= (bitwise-and s NOERR_MASK) 0)) + (ir-tx-event-noerr-ack) + (loop)) + ((not (= (bitwise-and s ERR_MASK) 0)) + (ir-tx-event-err-ack) + (loop)) + (else + s))))) + +(define (wait-until-end-of-tx) + (let loop () + (let ((s (poll-status-handling-rx))) + (cond ((not s) + #f) + ((not (= (bitwise-and s TX_MASK) 0)) + (loop)) + (else + s))))) + +(define (poll-status-handling-rx) + (let loop () + (let ((s (poll-status))) + (cond ((not s) + #f) + ((not (= (bitwise-and s RX_MASK) 0)) + (handle-rx-message) + (loop)) + (else + s))))) + +(define (handle-rx-message) + (let ((msg (ir-rx))) + (if msg + (let ((id (modulo (u8vector-ref msg 0) nb-ids))) + (display + (list " received from " id ": ")) + (write (u8vector->list msg)) + (display "\n") + (send-to-id msg id))))) + +(define (send-to-id msg id) + (mutex-lock! mutex) + (let ((client (vector-ref clients id))) + (if client + (with-exception-catcher + (lambda (exc) + (vector-set! clients id #f)) + (lambda () + (send msg client))))) + (mutex-unlock! mutex)) + +(define (ir-tx-event-noerr-ack) (send-command-no-cr "n" #t)) +(define (ir-tx-event-err-ack) (send-command-no-cr "e" #t)) + +(define (send-command-no-cr cmd trace?) + (and (rs232-send-no-cr cmd trace?) + (check-ok trace?))) + +(define (send-command cmd trace?) + (and (rs232-send cmd trace?) + (check-ok trace?))) + +(define (check-ok trace?) + (let ((answer (rs232-read-line trace?))) + (and (string? answer) + (= (string-length answer) 1) + (char=? (string-ref answer 0) #\!)))) + +(define (byte->string n) + (define (hex n) (string-ref "0123456789ABCDEF" (modulo n 16))) + (string (hex (quotient n 16)) + (hex n))) + +(define (ir-tx-special byte1 byte2) + (let ((cmd + (apply string-append + "s" + (map byte->string + (list byte1 byte2))))) + (send-command-no-cr cmd #t))) + +(define (ir-tx dest bytes) + (let ((cmd + (apply string-append + "t" + (map byte->string + (cons dest (u8vector->list bytes)))))) + (send-command cmd #t))) + +(define (poll-status) + (and (rs232-send-no-cr "p" #t) + (let ((answer (rs232-read-line #t))) + (and (string? answer) + (= (string-length answer) 3) + (char=? (string-ref answer 0) #\=) + (string->number (substring answer 1 3) 16))))) + +(define (ir-rx) + (and (rs232-send-no-cr "r" #t) + (let ((answer (rs232-read-line #t))) + (and (string? answer) + (>= (string-length answer) 3) + (odd? (string-length answer)) + (char=? (string-ref answer 0) #\=) + (let ((n (quotient (string-length answer) 2))) + (let ((v (make-u8vector n 0))) + (let loop ((i (- n 1))) + (if (>= i 0) + (let* ((j (+ (* i 2) 1)) + (x (string->number + (substring answer j (+ j 2)) + 16))) + (and x + (begin + (u8vector-set! v i x) + (loop (- i 1))))) + v)))))))) + +(define MSG_TYPE_ACK 0) +(define MSG_TYPE_SET_PROG_MODE 1) +(define MSG_TYPE_NORMAL 0) +(define MSG_TYPE_PROGRAM 1) +(define MSG_TYPE_STDIO 7) + +(define NOERR_MASK 1) +(define ERR_MASK 2) +(define RX_MASK 4) +(define CLOCK_MASK 8) +(define TX_MASK 128) + +(define (rs232-flush-input) + (input-port-timeout-set! rs232 0) + (read-line rs232 #f)) + +(define no-response-count 0) + +(define (rs232-read-line trace?) + (input-port-timeout-set! rs232 0.5) + (let ((x (read-line rs232))) +' + (if (and debug? trace?) + (pp (list '(rs232-read-line) '-> x))) + (if (eof-object? x) + (begin + (set! no-response-count (+ no-response-count 1)) + (if (> no-response-count 100) + (begin + (pp 'base-station-not-responding) + (set! no-response-count 50)))) + (begin + (if (and debug? trace?) + (begin + (display "<- ") + (display x) + (display "\n"))) + (if (>= no-response-count 50) + (pp 'base-station-now-ok)) + (set! no-response-count 0))) + x)) + +(define (rs232-send-no-check str trace?) +' + (if (and debug? trace?) + (pp (list 'rs232-send-no-check str))) + (display str rs232) + (display "\r" rs232) + (force-output rs232) + (if (and debug? trace?) + (begin + (display "-> ") + (display str) + (display "\n")))) + +(define (rs232-send-no-cr-no-check str trace?) +' + (if (and debug? trace?) + (pp (list 'rs232-send-no-cr-no-check str))) + (display str rs232) + (force-output rs232) + (if (and debug? trace?) + (begin + (display "-> ") + (display str) + (display "\n")))) + +(define (rs232-send str trace?) + (rs232-send-no-check str trace?) + (let ((echo (rs232-read-line #f))) + (if (and debug? trace? (string? echo)) + (begin + (display "<- ") + (display echo) + (display "\n"))) + (and (string? echo) + (string=? echo str)))) + +(define (rs232-send-no-cr str trace?) + (rs232-send-no-cr-no-check str trace?) + (let ((echo (rs232-read-line trace?))) + (and (string? echo) + (string=? echo str)))) + +(define (serve connection) + (thread-start! + (make-thread + (lambda () + (let ((id-and-hostname (read connection))) + (if (and (pair? id-and-hostname) + (pair? (cdr id-and-hostname)) + (null? (cddr id-and-hostname)) + (exact-int? (car id-and-hostname)) + (>= (car id-and-hostname) 0) + (< (car id-and-hostname) nb-ids)) + (let ((id (car id-and-hostname)) + (hostname (cadr id-and-hostname))) + (mutex-lock! mutex) + (let ((client (vector-ref clients id))) + (if client + (begin + (mutex-unlock! mutex) + (display + (list "============================================= connection to robot " id " from " hostname " **REFUSED**\n")) + (if log-file + (begin + (display + (list "============================================= connection to robot " id " from " hostname " **REFUSED**\n") + log-file) + (force-output log-file))) + (close-port connection)) + (begin + (vector-set! clients id connection) + (mutex-unlock! mutex) + (display + (list "============================================= connection to robot " id " from " hostname "\n")) + (if log-file + (begin + (display + (list "============================================= connection to robot " id " from " hostname "\n") + log-file) + (force-output log-file))) + (send '(ok) connection) + (process-client-commands connection id) + (mutex-lock! mutex) + (vector-set! clients id #f) + (mutex-unlock! mutex) + (close-port connection))))))))))) + +(define (process-client-commands connection id) + (with-exception-catcher + (lambda (exc) + #f) + (lambda () + (let loop () + (let ((cmd (read connection))) + (if (vector? cmd) + (begin + (send (vector id cmd) multiplexer) + (loop)))))))) + +;------------------------------------------------------------------------------ diff --git a/test-arity.scm b/test-arity.scm new file mode 100644 index 0000000..1a9372c --- /dev/null +++ b/test-arity.scm @@ -0,0 +1 @@ +(+ 1 2 3) diff --git a/test-u8.scm b/test-u8.scm new file mode 100644 index 0000000..3427f4b --- /dev/null +++ b/test-u8.scm @@ -0,0 +1,6 @@ +(define x (u8vector 65 67 118 10)) +;; (define x "ACD\n") +;; (display (string-append (substring x 0 2) "\n")) +;; (u8vector-set! x 2 70) +(display (u8vector-ref x 2)) +;; (+ (substring x 0 0) (substring x 3 3)) -- 2.11.4.GIT