├── .gitignore ├── AUTHORS ├── COPYING ├── Makefile ├── README.md ├── Rules.mk ├── calc ├── .gitignore ├── BuildExpressionCFG.lso ├── BuildExpressionDFA.lso ├── Calc.lso ├── ExpressionSyntax.lso ├── Makefile ├── README.md └── TestParse.lso ├── example ├── Makefile ├── README.md ├── Sqrt.lso ├── calc.lso ├── diff.lso ├── fib.lso ├── secd.lso ├── sumn.lso └── yinyang.lso ├── lispkit ├── APENDIX2.LOB ├── APENDIX2.LSO ├── Makefile ├── README.md └── compiler.lso ├── meta ├── Makefile └── secd.lso ├── scheme ├── .gitignore ├── BuildSchemeCFG.lso ├── BuildSchemeDFA.lso ├── LexScheme.lso ├── Makefile ├── README.md ├── SchemeSyntax.lso ├── TestLex.lso └── TestParse.lso ├── secd ├── .gitignore ├── Makefile ├── README.md ├── heap.asm ├── main.asm ├── secd.asm ├── secd.inc ├── string.asm ├── support.asm ├── system-cdecl.inc ├── system-fastcall.inc └── system.inc └── util ├── CallCC.lso ├── Cfg.lso ├── Map.lso ├── Parser.lso ├── Pattern.lso ├── README.md ├── Set.lso ├── StdIn.lso ├── Stream.lso ├── Unicode.lso └── Util.lso /.gitignore: -------------------------------------------------------------------------------- 1 | *.o 2 | *.lob 3 | -------------------------------------------------------------------------------- /AUTHORS: -------------------------------------------------------------------------------- 1 | Brad Kimmel 2 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | Copyright (c) 2009 Bradley W. Kimmel 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS 18 | BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN 19 | ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | include Rules.mk 2 | 3 | SUBDIRS = secd lispkit example scheme calc 4 | 5 | clean-all: clean 6 | for dir in $(SUBDIRS); do \ 7 | $(MAKE) --directory=$$dir clean; \ 8 | done 9 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | SECD Machine 2 | ============ 3 | 4 | This project is an implementation of an [SECD machine](http://en.wikipedia.org/wiki/SECD_machine) 5 | in x86 assembly. For details, please refer to: 6 | 7 | P. Henderson, "Functional Programming: Application and Implementation", 8 | Prentice Hall, 1980. 9 | 10 | 11 | Requirements 12 | ------------ 13 | 14 | - A POSIX-compatible operating system 15 | - [nasm](http://www.nasm.us) 16 | - [GNU make](http://www.gnu.org/software/make/) 17 | - [GNU m4](http://www.gnu.org/software/m4/) 18 | 19 | 20 | 21 | Directory Structure 22 | ------------------- 23 | 24 | The project is split up into the following components: 25 | 26 | - secd: The SECD machine implementation. 27 | - lispkit: The original and extended LispKit Lisp compilers. 28 | - util: A collection of useful LispKit Lisp functions. 29 | - example: Some example LispKit Lisp programs. 30 | - meta: An SECD-machine implementation in (extended) LispKit Lisp. 31 | - calc: A simple calculator pogram 32 | - scheme: A Scheme compiler (incomplete -- see scheme/README.md for details). 33 | 34 | See the README.md files in each component for further details. 35 | 36 | 37 | 38 | File Types 39 | ---------- 40 | 41 | ### Source File (.lso) 42 | 43 | These are LispKit Lisp source files, which may represent a standalone program or 44 | a file to be included. A program file may be distinguished from an include file 45 | in that a program file must contain a single object which has the form: 46 | 47 | (LETREC 48 | ( LAMBDA 49 | ... function body ... 50 | ) 51 | 52 | ... other definitions ... 53 | 54 | ) 55 | 56 | The `` may either be `NIL` or may be a list of variable names. If 57 | `` is non-`NIL`, the parameters will be read by the SECD machine from 58 | stdin. The result of the function indicated by `` will be printed to 59 | stdout. 60 | 61 | 62 | ### Object Files (.lob) 63 | 64 | These are compiled source files that are interpreted by the SECD machine. To 65 | compile a source file, issue the following command: 66 | 67 | make .lob 68 | 69 | To execute `.lob`, issue: 70 | 71 | make run- 72 | 73 | Issuing the above commands will rebuild the SECD-machine and the LispKit Lisp 74 | compiler, if necessary. It is not necessary to manually issue a "make" command 75 | for the SECD machine or compiler prior to building a LispKit Lisp program. 76 | 77 | The arguments to the program are read from stdin and the result is written to 78 | stdout. Some programs may read directly from stdin via the `GET` opcode, rather 79 | than having the SECD machine provide parse the input as arguments to the main 80 | function. Use the string "))" to separate the end of arguments to the main 81 | function from input read by the program itself. 82 | 83 | 84 | License 85 | ------- 86 | 87 | Copyright (c) 2009 Bradley W. Kimmel 88 | 89 | Permission is hereby granted, free of charge, to any person obtaining 90 | a copy of this software and associated documentation files (the 91 | "Software"), to deal in the Software without restriction, including 92 | without limitation the rights to use, copy, modify, merge, publish, 93 | distribute, sublicense, and/or sell copies of the Software, and to 94 | permit persons to whom the Software is furnished to do so, subject to 95 | the following conditions: 96 | 97 | The above copyright notice and this permission notice shall be 98 | included in all copies or substantial portions of the Software. 99 | 100 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 101 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 102 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 103 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS 104 | BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN 105 | ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 106 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 107 | SOFTWARE. 108 | -------------------------------------------------------------------------------- /Rules.mk: -------------------------------------------------------------------------------- 1 | 2 | TOPDIR ?= . 3 | SECDDIR = $(TOPDIR)/secd 4 | LISPKITDIR = $(TOPDIR)/lispkit 5 | SECD = $(SECDDIR)/secd 6 | LISPKIT = $(LISPKITDIR)/compiler.lob 7 | M4INCLUDE = -I$(TOPDIR) -I$(TOPDIR)/util 8 | 9 | CLEANFILES ?= 10 | 11 | DEBUG=0 12 | M4=m4 $(M4INCLUDE) $(M4FLAGS) 13 | CC=gcc 14 | AS=nasm -g 15 | ARCH=elf32 16 | ASFLAGS=-f $(ARCH) -I$(SECDDIR)/ 17 | ifeq ($(DEBUG),1) 18 | ASFLAGS+=-D DEBUG=1 19 | endif 20 | LD=ld 21 | LDFLAGS=-m elf_i386 22 | 23 | $(SECD): $(SECDDIR)/support.o $(SECDDIR)/string.o $(SECDDIR)/heap.o $(SECDDIR)/secd.o $(SECDDIR)/main.o 24 | $(LD) $(LDFLAGS) -o $@ $^ 25 | if (($(DEBUG) == 0)); then strip $@; fi 26 | 27 | clean: 28 | rm -f $(CLEANFILES) 29 | ls -1 *.lob | grep -iv '^APENDIX2\.LOB$$' | xargs rm -f 30 | 31 | $(LISPKITDIR)/primitive-compiler.lob: $(LISPKITDIR)/APENDIX2.LOB $(LISPKITDIR)/APENDIX2.LSO $(SECD) 32 | cat $(LISPKITDIR)/APENDIX2.LOB $(LISPKITDIR)/APENDIX2.LSO | $(SECD) > $@ 33 | 34 | $(LISPKIT): $(LISPKITDIR)/compiler.lso $(LISPKITDIR)/primitive-compiler.lob $(SECD) 35 | $(M4) $< | cat $(LISPKITDIR)/primitive-compiler.lob - | $(SECD) > $@.tmp 36 | $(M4) $< | cat $@.tmp - | $(SECD) > $@ 37 | -rm -f $@.tmp 38 | 39 | %.o : %.asm 40 | $(AS) $(ASFLAGS) -o $@ $< 41 | 42 | %.lob : %.lso $(LISPKIT) $(SECD) 43 | $(M4) $< | cat $(LISPKIT) - | $(SECD) > $@ 44 | @if ( head -n 1 "$@" | grep -q '^\s*(\s*ERROR\b' ); then cat "$@"; rm -f "$@"; exit 1; fi 45 | 46 | run-% : %.lob 47 | @cat $< - | $(SECD) 48 | 49 | -------------------------------------------------------------------------------- /calc/.gitignore: -------------------------------------------------------------------------------- 1 | ExpressionCFG.lso 2 | ExpressionDFA.lso 3 | -------------------------------------------------------------------------------- /calc/BuildExpressionCFG.lso: -------------------------------------------------------------------------------- 1 | dnl --- 2 | (LETREC BuildExpressionCFG 3 | (BuildExpressionCFG LAMBDA NIL 4 | (MAPTOLIST (NEWCFG ExpressionGrammar))) 5 | 6 | include(ExpressionSyntax.lso) 7 | include(Cfg.lso) 8 | 9 | ) 10 | -------------------------------------------------------------------------------- /calc/BuildExpressionDFA.lso: -------------------------------------------------------------------------------- 1 | dnl --- 2 | (LETREC BuildExpressionDFA 3 | (BuildExpressionDFA LAMBDA NIL 4 | (MAPTOLIST (CFGDFA (MAPFROMLIST ExpressionCFG)))) 5 | 6 | include(Map.lso) 7 | include(Cfg.lso) 8 | 9 | (ExpressionCFG QUOTE 10 | include(ExpressionCFG.lso) 11 | ) 12 | 13 | ) 14 | -------------------------------------------------------------------------------- /calc/Calc.lso: -------------------------------------------------------------------------------- 1 | dnl --- Simple Calculator 2 | (LETREC TEST 3 | (TEST LAMBDA (EXPR) 4 | (CFGPARSE 5 | (MAPFROMLIST ExpressionCFG) 6 | (MAPFROMLIST ExpressionDFA) 7 | (LAMBDA (TOKEN) (IF (NUMBER TOKEN) (QUOTE ID) TOKEN)) 8 | (LAMBDA (TOKEN) (STOP (CONS (QUOTE ParseError) TOKEN))) 9 | (FLATTENEXPR EXPR) 10 | EVAL)) 11 | 12 | dnl --- Flattens the list, turning the beginning and end of sub-lists 13 | dnl into OPENP & CLOSEP tokens, respectively. 14 | (FLATTENEXPR LAMBDA (L) 15 | (LETREC 16 | (FLATTENCC L (QUOTE NIL)) 17 | (FLATTENCC LAMBDA (L CC) 18 | (IF (ISNIL L) 19 | (REVERSE CC) 20 | (IF (ATOM (CAR L)) 21 | (FLATTENCC (CDR L) (CONS (CAR L) CC)) 22 | (FLATTENCC 23 | (APPEND 24 | (CONS (QUOTE OPENP) (CAR L)) 25 | (CONS (QUOTE CLOSEP) (CDR L))) 26 | CC)))))) 27 | 28 | dnl --- Recursively descend into the parse tree using pattern matching, 29 | dnl evaluating the expressions as we ascend. 30 | (EVAL LAMBDA (TREE) (LET 31 | (MATCH TREE 32 | (CASE (_ < _) (BINOP LT)) 33 | (CASE (_ > _) (BINOP GT)) 34 | (CASE (_ <= _) (BINOP LEQ)) 35 | (CASE (_ >= _) (BINOP GEQ)) 36 | (CASE (_ == _) (BINOP EQ)) 37 | (CASE (_ != _) (BINOP NEQ)) 38 | (CASE (_ + _) (BINOP ADD)) 39 | (CASE (_ - _) (BINOP SUB)) 40 | (CASE (_ (\ *) _) (BINOP MUL)) 41 | (CASE (_ / _) (BINOP DIV)) 42 | (CASE (* _ *) _1) 43 | (CASE (#_) _1) 44 | (CASE (_) _1) 45 | (CASE _ (STOP (LIST (QUOTE UnexpectedError) _1)))) 46 | (BINOP MACRO (OP) (OP _1 _2)))) 47 | 48 | (ExpressionCFG QUOTE 49 | include(ExpressionCFG.lso) 50 | ) 51 | 52 | (ExpressionDFA QUOTE 53 | include(ExpressionDFA.lso) 54 | ) 55 | 56 | include(Cfg.lso) 57 | include(Util.lso) 58 | include(Pattern.lso) 59 | 60 | ) 61 | -------------------------------------------------------------------------------- /calc/ExpressionSyntax.lso: -------------------------------------------------------------------------------- 1 | dnl =========================================================================== 2 | dnl | Grammar for mathematical expressions 3 | dnl | 4 | dnl | The following grammar is structured as a list of items of the form: 5 | dnl | 6 | dnl | ( () () ... ), or 7 | dnl | () 8 | dnl | 9 | dnl | where is a non-terminal symbol, and is followed by a list 10 | dnl | one or more production rules for that symbol, or where is a 11 | dnl | terminal symbol, and thus has no production rules. Each production rule 12 | dnl | is a list of the symbols on the right hand side of the 13 | dnl | production rule. The production rule NIL denotes a production of the form 14 | dnl | 15 | dnl | --> 16 | dnl | 17 | dnl | There is a special non-terminal symbol "START" which must have exactly one 18 | dnl | production rule. 19 | dnl =========================================================================== 20 | ifdef(`expression_syntax_lso_m4',,`define(`expression_syntax_lso_m4',1)dnl 21 | 22 | (ExpressionGrammar QUOTE ( 23 | 24 | (START (S)) 25 | 26 | (S 27 | (C) dnl --- Comparison 28 | (E)) dnl --- Expression 29 | 30 | dnl --- Comparisons --- 31 | (C 32 | (E < E) 33 | (E > E) 34 | (E <= E) 35 | (E >= E) 36 | (E == E) 37 | (E != E)) 38 | 39 | dnl --- Expression --- 40 | (E 41 | (E + T) 42 | (E - T) 43 | (T)) 44 | 45 | dnl --- Term --- 46 | (T 47 | (T * F) 48 | (T / F) 49 | (F)) 50 | 51 | dnl --- Factor --- 52 | (F 53 | ([ E ]) 54 | ({ E }) 55 | (OPENP E CLOSEP) 56 | (ID)) 57 | 58 | dnl --- Terminals --- 59 | (ID) 60 | (-) 61 | (+) 62 | (*) 63 | (/) 64 | ([) 65 | (]) 66 | ({) 67 | (}) 68 | (OPENP) 69 | (CLOSEP) 70 | (<) 71 | (>) 72 | (<=) 73 | (>=) 74 | (==) 75 | (!=) 76 | 77 | dnl ---------------------------------------------------------------------------- 78 | )) 79 | 80 | ')dnl 81 | -------------------------------------------------------------------------------- /calc/Makefile: -------------------------------------------------------------------------------- 1 | TOPDIR = .. 2 | CLEANFILES = ExpressionCFG.lso ExpressionDFA.lso 3 | 4 | all: TestParse.lob Calc.lob 5 | 6 | TestParse.lob: ExpressionCFG.lso ExpressionDFA.lso ../util/Cfg.lso ../util/Util.lso 7 | 8 | Calc.lob: ExpressionCFG.lso ExpressionDFA.lso ../util/Cfg.lso ../util/Pattern.lso 9 | 10 | BuildExpressionCFG.lob: ExpressionSyntax.lso ../util/Cfg.lso 11 | 12 | BuildExpressionDFA.lob: ExpressionCFG.lso ../util/Cfg.lso 13 | 14 | ExpressionCFG.lso: BuildExpressionCFG.lob 15 | cat $^ | $(SECD) > $@ 16 | 17 | ExpressionDFA.lso: BuildExpressionDFA.lob 18 | cat $^ | $(SECD) > $@ 19 | 20 | run: run-Calc 21 | 22 | include $(TOPDIR)/Rules.mk 23 | -------------------------------------------------------------------------------- /calc/README.md: -------------------------------------------------------------------------------- 1 | Simple Calculator 2 | ================= 3 | 4 | This directory contains an implementation of a simple calculator. It's purpose 5 | is to exercise the context-free grammar processing and pattern matching 6 | functionality. There are two programs in this directory: 7 | 8 | - Calc.lso: The calculator takes a list of tokens as an argument and 9 | evaluates them as a mathematical expression. 10 | - TestParse.lso: TestParse takes the same argument as Calc.lso and prints 11 | out the corresponding parse tree, but does not evaluate 12 | the expression. 13 | 14 | NOTE: The expression read by the calculator must be enclosed in parentheses 15 | (i.e., must be a valid LispKit Lisp "list"). 16 | 17 | To run the calculator, issue the command: 18 | 19 | make run 20 | 21 | To run the parser only, issue the command: 22 | 23 | make run-TestParse 24 | 25 | The grammar for the calculator may be found in ExpressionSyntax.lso. The 26 | calculator evaluates arithmetic and comparison expressions on integers. The 27 | following arithmetic operators are allowed: 28 | 29 | - multiplication (`*`) 30 | - division (`/`) 31 | - addition (`+`) 32 | - subtraction (`-`) 33 | 34 | Additionally, parentheses may be used. Round parentheses (`(`, `)`), square 35 | brackets (`[`, `]`), or curly brackets (`{`, `}`) may be used, as long as they 36 | are properly matched. 37 | 38 | The following comparison operators are allowed: 39 | 40 | - less than (`<`) 41 | - greater than (`>`) 42 | - less than or equal (`<=`) 43 | - greater than or equal (`>=`) 44 | - equal (`==`) 45 | - not equal (`!=`) 46 | 47 | -------------------------------------------------------------------------------- /calc/TestParse.lso: -------------------------------------------------------------------------------- 1 | dnl --- Test expression parsing 2 | (LETREC TEST 3 | (TEST LAMBDA (EXPR) 4 | (CFGPARSE 5 | (MAPFROMLIST ExpressionCFG) 6 | (MAPFROMLIST ExpressionDFA) 7 | (LAMBDA (TOKEN) (IF (NUMBER TOKEN) (QUOTE ID) TOKEN)) 8 | (LAMBDA (TOKEN) (STOP (CONS (QUOTE ParseError) TOKEN))) 9 | (FLATTENEXPR EXPR) 10 | TAGGED)) 11 | 12 | dnl --- Flattens the list, turning the beginning and end of sub-lists 13 | dnl into OPENP & CLOSEP tokens, respectively. 14 | (FLATTENEXPR LAMBDA (L) 15 | (LETREC 16 | (FLATTENCC L (QUOTE NIL)) 17 | (FLATTENCC LAMBDA (L CC) 18 | (IF (ISNIL L) 19 | (REVERSE CC) 20 | (IF (ATOM (CAR L)) 21 | (FLATTENCC (CDR L) (CONS (CAR L) CC)) 22 | (FLATTENCC 23 | (APPEND 24 | (CONS (QUOTE OPENP) (CAR L)) 25 | (CONS (QUOTE CLOSEP) (CDR L))) 26 | CC)))))) 27 | 28 | (TAGGED LAMBDA (X LHS RULENUM) 29 | (CONS (CONS LHS RULENUM) X)) 30 | 31 | (ExpressionCFG QUOTE 32 | include(ExpressionCFG.lso) 33 | ) 34 | 35 | (ExpressionDFA QUOTE 36 | include(ExpressionDFA.lso) 37 | ) 38 | 39 | include(Cfg.lso) 40 | include(Util.lso) 41 | 42 | ) 43 | -------------------------------------------------------------------------------- /example/Makefile: -------------------------------------------------------------------------------- 1 | TOPDIR = .. 2 | include ../Rules.mk 3 | -------------------------------------------------------------------------------- /example/README.md: -------------------------------------------------------------------------------- 1 | Example LispKit Lisp Programs 2 | ============================= 3 | 4 | This directory contains some sample LispKit Lisp programs. 5 | 6 | - sumn: Adds the numbers from 1 to N. 7 | - fib: Computes the Nth number in the Fibonacci sequence. 8 | - diff: Simple differentiation of an argument which is a nesting of 9 | expressions of the form `(ADD )` and `(MUL )`. 10 | Differentiation is performed in the symbol `X` 11 | - Sqrt: Simple square-root calculator. This program tests the MAP data 12 | type. It creates a map from → for from 1 to 1000, and 13 | looks up the input argument in this map. 14 | - calc: A simple calculator that uses parser combinators instead of the 15 | CFG shift/reduce parser-generator. 16 | - yinyang: An implementation of the [yin-yang puzzle](http://en.wikipedia.org/wiki/Call-with-current-continuation) 17 | 18 | -------------------------------------------------------------------------------- /example/Sqrt.lso: -------------------------------------------------------------------------------- 1 | dnl --- Sqrt Test --- 2 | (LETREC SQRT 3 | (SQRT LAMBDA (N) 4 | (MAPGET (BUILDSQRTMAP 1000) N)) 5 | 6 | include(Map.lso) 7 | 8 | (BUILDSQRTMAP LAMBDA (N) 9 | (BUILDSQRTMAPCC N MAPEMPTY)) 10 | 11 | (BUILDSQRTMAPCC LAMBDA (N CC) 12 | (IF (LEQ N 0) 13 | CC 14 | (BUILDSQRTMAPCC (SUB N 1) (MAPPUT CC (MUL N N) N))))) 15 | 16 | -------------------------------------------------------------------------------- /example/calc.lso: -------------------------------------------------------------------------------- 1 | (LETREC TEST 2 | 3 | include(Util.lso) 4 | include(Parser.lso) 5 | include(Pattern.lso) 6 | 7 | (TEST LAMBDA (E) 8 | 9 | (LETREC 10 | (LETREC 11 | 12 | ((START) (APPEND E (QUOTE ($))) (LAMBDA (R OUT) R)) 13 | 14 | (SUBEXPR LAMBDA NIL (PARSE_ANY 15 | (QUOTE (EXPECTED SUBEXPRESSION)) 16 | (LIST 17 | NESTED 18 | (PARSE_DELIM { (PARSE_REC EXPR) }) 19 | (PARSE_DELIM [ (PARSE_REC EXPR) ])))) 20 | 21 | (EXPR$ LAMBDA NIL (PARSE_CONS_L (EXPR) $)) 22 | (NESTED LAMBDA (IN CC) 23 | (IF (ATOM (CAR IN)) 24 | (QUOTE (EXPECTED NESTED EXPRESSION)) 25 | ((EXPR$) (APPEND (CAR IN) (QUOTE ($))) (LAMBDA (R OUT) (CC R (CDR IN)))))) 26 | 27 | (FACTOR LAMBDA NIL (PARSE_OR NUM (SUBEXPR))) 28 | (TERM LAMBDA NIL (PARSE_CHAIN_L1 (FACTOR) (PARSE_OR * /))) 29 | (EXPR LAMBDA NIL (PARSE_CHAIN_L1 (TERM) (PARSE_OR + -))) 30 | 31 | (COMP_OP LAMBDA NIL (PARSE_ANY 32 | (QUOTE (EXPECTED COMPARE OPERATOR)) 33 | (LIST < > <= >= = !=))) 34 | 35 | (COMP LAMBDA NIL 36 | (PARSE_MAP 37 | (PARSE_SEQ (LIST (EXPR) (COMP_OP) (EXPR))) 38 | (LAMBDA (X) (MATCH X ( 39 | (CASE* (L OP R) (_ _ _) (OP L R))))))) 40 | 41 | (START LAMBDA NIL (PARSE_CONS_L (PARSE_OR (COMP) (EXPR)) $)) 42 | 43 | ) 44 | 45 | ($ PARSE_TOKEN (QUOTE $)) 46 | (+ PARSE_TO (PARSE_TOKEN (QUOTE +)) (LAMBDA (A B) (ADD A B))) 47 | (- PARSE_TO (PARSE_TOKEN (QUOTE -)) (LAMBDA (A B) (SUB A B))) 48 | (* PARSE_TO (PARSE_TOKEN (QUOTE *)) (LAMBDA (A B) (MUL A B))) 49 | (/ PARSE_TO (PARSE_TOKEN (QUOTE /)) (LAMBDA (A B) (DIV A B))) 50 | (< PARSE_TO (PARSE_TOKEN (QUOTE <)) (LAMBDA (A B) (LT A B))) 51 | (> PARSE_TO (PARSE_TOKEN (QUOTE >)) (LAMBDA (A B) (GT A B))) 52 | (<= PARSE_TO (PARSE_TOKEN (QUOTE <=)) (LAMBDA (A B) (LEQ A B))) 53 | (>= PARSE_TO (PARSE_TOKEN (QUOTE >=)) (LAMBDA (A B) (GEQ A B))) 54 | (!= PARSE_TO (PARSE_TOKEN (QUOTE !=)) (LAMBDA (A B) (NEQ A B))) 55 | (= PARSE_TO (PARSE_TOKEN (QUOTE =)) (LAMBDA (A B) (EQ A B))) 56 | ([ PARSE_TOKEN (QUOTE [)) 57 | (] PARSE_TOKEN (QUOTE ])) 58 | ({ PARSE_TOKEN (QUOTE {)) 59 | (} PARSE_TOKEN (QUOTE })) 60 | (NUM PARSE_ELEM (QUOTE NUMBER) (LAMBDA (X) (NUMBER X)))) 61 | 62 | )) 63 | 64 | -------------------------------------------------------------------------------- /example/diff.lso: -------------------------------------------------------------------------------- 1 | (LETREC DIFF 2 | (DIFF LAMBDA (E) 3 | (IF (ATOM E) (IF (EQ E (QUOTE X)) 1 4 | 0) 5 | (IF (EQ (CAR E) (QUOTE ADD)) 6 | (LET (SUM (DIFF E1) (DIFF E2)) 7 | (E1 CAR (CDR E)) 8 | (E2 CAR (CDR (CDR E)))) 9 | (IF (EQ (CAR E) (QUOTE MUL)) 10 | (LET (SUM (PROD E1 (DIFF E2)) 11 | (PROD (DIFF E1) E2)) 12 | (E1 CAR (CDR E)) 13 | (E2 CAR (CDR (CDR E)))) 14 | (QUOTE ERROR))))) 15 | (SUM LAMBDA (U V) 16 | (CONS (QUOTE ADD) 17 | (CONS U (CONS V (QUOTE NIL))))) 18 | (PROD LAMBDA (U V) 19 | (CONS (QUOTE MUL) 20 | (CONS U (CONS V (QUOTE NIL )))))) 21 | -------------------------------------------------------------------------------- /example/fib.lso: -------------------------------------------------------------------------------- 1 | (LETREC FIB 2 | (FIB LAMBDA (N) 3 | (CONTINUEFIB N 0 1)) 4 | (CONTINUEFIB LAMBDA (N A1 A2) 5 | (IF (EQ N 0) 6 | A1 7 | (CONTINUEFIB (SUB N 1) (ADD A1 A2) A1)))) 8 | -------------------------------------------------------------------------------- /example/secd.lso: -------------------------------------------------------------------------------- 1 | dnl =========================================================================== 2 | dnl | SECD Machine 3 | dnl | 4 | dnl | An implementation of the SECD machine runs on an underlying SECD machine. 5 | dnl | This implementation does not yet support any of the extended opcodes that 6 | dnl | the underlying machine does. 7 | dnl | 8 | dnl =========================================================================== 9 | (LETREC EXEC 10 | 11 | include(Util.lso) 12 | include(Pattern.lso) 13 | include(CallCC.lso) 14 | 15 | dnl ------------------------------------------------------------------------- 16 | dnl | Applies the next applicable transition to the SECD-machine state. 17 | dnl | 18 | dnl | STATE = A list of the form "(S E C D)" with the contents of the SECD 19 | dnl | machine registers 20 | dnl | STOP = A continuation function to call if the machine halts. The 21 | dnl | function must accept one argument, which is the result computed 22 | dnl | by the SECD-machine 23 | dnl ------------------------------------------------------------------------- 24 | (STEP LAMBDA (STATE STOP) (LETREC 25 | (MATCH STATE ( 26 | 27 | dnl -- Each rule has one of the following forms: 28 | dnl -- (RULE 29 | dnl -- ) 30 | dnl -- (RULE* 31 | dnl -- ) 32 | dnl -- where: 33 | dnl -- = the symbolic name of the opcode 34 | dnl -- = names to refer to the components extracted from 35 | dnl -- the state 36 | dnl -- = the pattern to match against the current state 37 | dnl -- = what to print if __TRACE__ is enabled 38 | dnl -- = what to transform each of the SECD-machine 39 | dnl -- registers into 40 | dnl -- = the result of the transformation 41 | 42 | (RULE LD (S E I₁ I₂ C D) (_ _ (1 (#_ . #_) . _) _) (LIST (CONS I₁ I₂) (ENVSPEC E)) 43 | (CONS (LOCATE I₁ I₂ E) S) E C D) 44 | 45 | (RULE LDC (S E X C D) (_ _ (2 _ . _) _) X 46 | (CONS X S) E C D) 47 | 48 | (RULE CONS (A B S E C D) ((_ _ . _) _ (13 . _) _) (CONS A B) 49 | (CONS (CONS A B) S) E C D) 50 | 51 | dnl -- Short forms for binary operations: (BINOP ) is 52 | dnl -- equivalent to: 53 | dnl -- (RULE (B A S E C D) ((_ _ . _) _ ( . _) _) 54 | dnl -- 55 | dnl -- (CONS ( B A) S) E C D) 56 | (BINOP 14 EQ) 57 | (BINOP 15 ADD) 58 | (BINOP 16 SUB) 59 | (BINOP 17 MUL) 60 | (BINOP 18 DIV) 61 | (BINOP 19 REM) 62 | (BINOP 20 LEQ) 63 | 64 | (RULE CAR (A S E C D) (((_ . *) . _) _ (10 . _) _) A 65 | (CONS A S) E C D) 66 | 67 | (RULE CDR (B S E C D) (((* . _) . _) _ (11 . _) _) B 68 | (CONS B S) E C D) 69 | 70 | (RULE ATOM (A S E C D) ((_ . _) _ (12 . _) _) (LIST A (ATOM A)) 71 | (CONS (ATOM A) S) E C D) 72 | 73 | (RULE SEL (S E Cf C D) ((F . _) _ (8 * _ . _) _) (QUOTE F) 74 | S E Cf (CONS C D)) 75 | 76 | (RULE SEL (S E Cf C D) ((NIL . _) _ (8 * _ . _) _) (QUOTE F) 77 | S E Cf (CONS C D)) 78 | 79 | (RULE SEL (S E Ct C D) ((* . _) _ (8 _ * . _) _) (QUOTE T) 80 | S E Ct (CONS C D)) 81 | 82 | (RULE JOIN (S E C D) (_ _ (9) (_ . _)) (QUOTE NIL) 83 | S E C D) 84 | 85 | (RULE LDF (S E C' C D) (_ _ (3 _ . _) _) (LIST C' (ENVSPEC E)) 86 | (CONS (CONS C' E) S) E C D) 87 | 88 | (RULE AP (C' E' V S E C D) (((_ . _) _ . _) _ (4 . _) _) (LIST C' (ENVSPEC (CONS V E'))) 89 | (QUOTE NIL) (CONS V E') C' (CONS S (CONS E (CONS C D)))) 90 | 91 | (RULE RTN (X S E C D) ((_) * (5) (_ _ _ . _)) (LIST X (ENVSPEC E)) 92 | (CONS X S) E C D) 93 | 94 | (RULE* STOP (X) ((_ . *) * (21) *) X 95 | (STOP X)) 96 | 97 | (RULE* DUM (S E C D) (_ _ (6 . _) _) (ENVSPEC E) 98 | (LETREC 99 | (MATCH V ( 100 | (CASE* (STATE) (* _ . 1) STATE) 101 | (CASE * (LIST S (CONS Ω E) C (CONS V D))))) 102 | (V CALL/CC (LAMBDA (F) F)) 103 | (Ω DELAY (CAR V)))) 104 | 105 | (RULE* RAP (C' E' V S E C F D) (((_ . _) _ . _) (* . _) (7 . _) (_ . _)) (ENVSPEC E') 106 | (F (CONS V (CONS (LIST (QUOTE NIL) E' C' (CONS S (CONS E (CONS C D)))) 1)))) 107 | 108 | (RULE* ERROR (S E C) (_ _ _ *) (LIST S (ENVSPEC E) C) 109 | (STOP (LIST (QUOTE ERROR) S (ENVSPEC E) C))))) 110 | 111 | dnl -- Helper functions 112 | (LOCATE LAMBDA (I₁ I₂ E) 113 | (ELEM I₂ (FORCE (ELEM I₁ E)))) 114 | (ELEM LAMBDA (N L) 115 | (IF (EQ N 0) (CAR L) (ELEM (SUB N 1) (CDR L)))) 116 | 117 | dnl -- Helper macros 118 | (BINOP MACRO (INSTR OP) 119 | (RULE OP (A B S E C D) ((_ _ . _) _ (INSTR . _) _) (LIST B A (OP B A)) 120 | (CONS (OP B A) S) E C D)) 121 | 122 | (RULE MACRO (OP PARAMS PATTERN INFO S E C D) 123 | (RULE* OP PARAMS PATTERN INFO (LIST S E C D))) 124 | 125 | (RULE* MACRO (OP PARAMS PATTERN INFO RESULT) 126 | (CASE* PARAMS PATTERN 127 | (TRACE* OP INFO 128 | RESULT))) 129 | 130 | ifdef(`__TRACE__', 131 | 132 | (TRACE MACRO (OP X) 133 | (BEGIN (PUTEXP (QUOTE OP)) (LET 134 | (BEGIN (PUTEXP (QUOTE OK)) (PUT 10) Y) (Y . X)))) 135 | 136 | (TRACE* MACRO (OP T X) 137 | (BEGIN (PUTEXP (LIST (QUOTE OP) T)) (LET 138 | (BEGIN (PUTEXP (QUOTE OK)) (PUT 10) Y) (Y . X)))) 139 | 140 | (ENVSPEC LAMBDA (E) 141 | (CONS (QUOTE ENV) (ENVSPECREC E))) 142 | 143 | (ENVSPECREC LAMBDA (E) 144 | (MATCH E ( 145 | (CASE NIL (QUOTE NIL)) 146 | (CASE? (_ . _) (RECIPE _1) (CONS (QUOTE ?) (ENVSPECREC _2))) 147 | (CASE (_ . _) (CONS (LENGTH _1) (ENVSPECREC _2)))))) 148 | 149 | ,dnl !__TRACE__ 150 | 151 | (TRACE MACRO (OP X) X) 152 | (TRACE* MACRO (OP T X) X) 153 | 154 | )dnl 155 | 156 | )) 157 | 158 | dnl ------------------------------------------------------------------------- 159 | dnl | Applies SECD-machine transitions repeatedly until the machine halts 160 | dnl | 161 | dnl | STATE = The initial SECD-machine state. A list of the form "(S E C D)" 162 | dnl | with the contents of the SECD machine registers 163 | dnl | STOP = A continuation function to call if the machine halts. The 164 | dnl | function must accept one argument, which is the result computed 165 | dnl | by the SECD-machine 166 | dnl ------------------------------------------------------------------------- 167 | (CYCLE LAMBDA (STATE STOP) 168 | (CYCLE (STEP STATE STOP))) 169 | 170 | dnl ------------------------------------------------------------------------- 171 | dnl | Executes the SECD-machine with the provided code and arguments. 172 | dnl | 173 | dnl | C = The contents of the code (C) register 174 | dnl | S = The contents of the stack (S) register. The list on the top of the 175 | dnl | stack register will be passed as the arguments to the function 176 | dnl | loaded by the code register. 177 | dnl ------------------------------------------------------------------------- 178 | (EXEC LAMBDA (C S) 179 | (CALL/CC 180 | (LAMBDA (STOP) 181 | (CYCLE (LIST S (QUOTE NIL) C (QUOTE NIL)) STOP))))) 182 | -------------------------------------------------------------------------------- /example/sumn.lso: -------------------------------------------------------------------------------- 1 | (LETREC SUMN 2 | (SUMN LAMBDA (N) 3 | (CONTINUESUMN N 0)) 4 | (CONTINUESUMN LAMBDA (N A) 5 | (IF (EQ N 0) 6 | A 7 | (CONTINUESUMN (SUB N 1) (ADD N A))))) 8 | -------------------------------------------------------------------------------- /example/yinyang.lso: -------------------------------------------------------------------------------- 1 | dnl =========================================================================== 2 | dnl | Yin-Yang Puzzle 3 | dnl | --------------- 4 | dnl | 5 | dnl | Implementation of the Yin-Yang puzzle using CALL/CC. 6 | dnl | 7 | dnl | http://en.wikipedia.org/wiki/Call-with-current-continuation 8 | dnl | 9 | dnl =========================================================================== 10 | (LETREC YINYANG 11 | 12 | include(CallCC.lso) 13 | 14 | (YINYANG LAMBDA NIL 15 | (LET 16 | (LET 17 | (YIN YANG) 18 | (YANG (LAMBDA (CC) (BEGIN (PUT 42) CC)) (CALL/CC (LAMBDA (C) C)))) 19 | (YIN (LAMBDA (CC) (BEGIN (PUT 64) CC)) (CALL/CC (LAMBDA (C) C))))) 20 | 21 | ) 22 | -------------------------------------------------------------------------------- /lispkit/APENDIX2.LOB: -------------------------------------------------------------------------------- 1 | ( 6 2 NIL 3 ( 1 ( 0 . 0 ) 2 NIL 14 8 ( 2 NIL 9 )( 2 NIL 1 ( 0 2 | . 0 ) 11 13 1 ( 1 . 5 ) 4 1 ( 0 . 0 ) 10 11 13 9 ) 5 ) 13 3 ( 1 ( 3 | 0 . 0 ) 2 NIL 14 8 ( 2 NIL 9 )( 2 NIL 1 ( 0 . 0 ) 11 13 1 ( 1 4 | . 4 ) 4 1 ( 0 . 0 ) 10 10 13 9 ) 5 ) 13 3 ( 6 2 NIL 3 ( 1 ( 0 . 0 5 | ) 11 2 1 1 ( 0 . 0 ) 10 15 13 5 ) 13 3 ( 1 ( 0 . 0 ) 1 ( 0 . 1 ) 6 | 10 14 8 ( 2 0 9 )( 2 1 2 NIL 1 ( 0 . 1 ) 11 13 1 ( 0 . 0 ) 13 7 | 1 ( 1 . 1 ) 4 15 9 ) 5 ) 13 3 ( 1 ( 0 . 1 ) 2 NIL 14 8 ( 2 NIL 8 | 9 )( 1 ( 0 . 0 ) 1 ( 0 . 1 ) 10 14 8 ( 2 T 9 )( 2 NIL 1 ( 0 . 1 ) 9 | 11 13 1 ( 0 . 0 ) 13 1 ( 1 . 0 ) 4 9 ) 9 ) 5 ) 13 3 ( 2 NIL 1 ( 1 10 | . 1 ) 10 13 1 ( 1 . 0 ) 13 1 ( 0 . 0 ) 4 8 ( 2 NIL 1 ( 1 . 1 ) 10 11 | 13 1 ( 1 . 0 ) 13 1 ( 0 . 1 ) 4 2 0 13 9 )( 2 NIL 2 NIL 1 ( 1 12 | . 1 ) 11 13 1 ( 1 . 0 ) 13 1 ( 2 . 3 ) 4 13 1 ( 0 . 2 ) 4 9 ) 5 ) 13 | 7 5 ) 13 3 ( 1 ( 0 . 0 ) 2 NIL 14 8 ( 1 ( 0 . 2 ) 2 NIL 13 2 2 14 | 13 9 )( 2 NIL 2 NIL 1 ( 0 . 2 ) 2 13 13 13 1 ( 0 . 1 ) 13 1 15 | ( 0 . 0 ) 10 13 1 ( 1 . 1 ) 4 13 1 ( 0 . 1 ) 13 1 ( 0 . 0 ) 11 13 16 | 1 ( 1 . 2 ) 4 9 ) 5 ) 13 3 ( 1 ( 0 . 0 ) 12 8 ( 1 ( 0 . 2 ) 2 NIL 1 17 | ( 0 . 1 ) 13 1 ( 0 . 0 ) 13 1 ( 1 . 3 ) 4 13 2 1 13 9 )( 1 ( 0 . 18 | 0 ) 10 2 QUOTE 14 8 ( 1 ( 0 . 2 ) 1 ( 0 . 0 ) 11 10 13 2 2 13 19 | 9 )( 1 ( 0 . 0 ) 10 2 ADD 14 8 ( 2 NIL 2 NIL 1 ( 0 . 2 ) 2 15 20 | 13 13 1 ( 0 . 1 ) 13 1 ( 0 . 0 ) 11 11 10 13 1 ( 1 . 1 ) 4 13 1 21 | ( 0 . 1 ) 13 1 ( 0 . 0 ) 11 10 13 1 ( 1 . 1 ) 4 9 )( 1 ( 0 . 0 ) 10 22 | 2 SUB 14 8 ( 2 NIL 2 NIL 1 ( 0 . 2 ) 2 16 13 13 1 ( 0 . 1 ) 23 | 13 1 ( 0 . 0 ) 11 11 10 13 1 ( 1 . 1 ) 4 13 1 ( 0 . 1 ) 13 1 ( 0 24 | . 0 ) 11 10 13 1 ( 1 . 1 ) 4 9 )( 1 ( 0 . 0 ) 10 2 MUL 14 8 ( 2 25 | NIL 2 NIL 1 ( 0 . 2 ) 2 17 13 13 1 ( 0 . 1 ) 13 1 ( 0 . 0 ) 11 26 | 11 10 13 1 ( 1 . 1 ) 4 13 1 ( 0 . 1 ) 13 1 ( 0 . 0 ) 11 10 13 27 | 1 ( 1 . 1 ) 4 9 )( 1 ( 0 . 0 ) 10 2 DIV 14 8 ( 2 NIL 2 NIL 1 ( 28 | 0 . 2 ) 2 18 13 13 1 ( 0 . 1 ) 13 1 ( 0 . 0 ) 11 11 10 13 1 ( 1 29 | . 1 ) 4 13 1 ( 0 . 1 ) 13 1 ( 0 . 0 ) 11 10 13 1 ( 1 . 1 ) 4 9 ) 30 | ( 1 ( 0 . 0 ) 10 2 REM 14 8 ( 2 NIL 2 NIL 1 ( 0 . 2 ) 2 19 13 31 | 13 1 ( 0 . 1 ) 13 1 ( 0 . 0 ) 11 11 10 13 1 ( 1 . 1 ) 4 13 1 ( 0 32 | . 1 ) 13 1 ( 0 . 0 ) 11 10 13 1 ( 1 . 1 ) 4 9 )( 1 ( 0 . 0 ) 10 2 33 | LEQ 14 8 ( 2 NIL 2 NIL 1 ( 0 . 2 ) 2 20 13 13 1 ( 0 . 1 ) 13 34 | 1 ( 0 . 0 ) 11 11 10 13 1 ( 1 . 1 ) 4 13 1 ( 0 . 1 ) 13 1 ( 0 . 35 | 0 ) 11 10 13 1 ( 1 . 1 ) 4 9 )( 1 ( 0 . 0 ) 10 2 EQ 14 8 ( 2 NIL 36 | 2 NIL 1 ( 0 . 2 ) 2 14 13 13 1 ( 0 . 1 ) 13 1 ( 0 . 0 ) 11 11 37 | 10 13 1 ( 1 . 1 ) 4 13 1 ( 0 . 1 ) 13 1 ( 0 . 0 ) 11 10 13 1 ( 1 38 | . 1 ) 4 9 )( 1 ( 0 . 0 ) 10 2 CAR 14 8 ( 2 NIL 1 ( 0 . 2 ) 2 10 39 | 13 13 1 ( 0 . 1 ) 13 1 ( 0 . 0 ) 11 10 13 1 ( 1 . 1 ) 4 9 )( 1 40 | ( 0 . 0 ) 10 2 CDR 14 8 ( 2 NIL 1 ( 0 . 2 ) 2 11 13 13 1 ( 0 . 41 | 1 ) 13 1 ( 0 . 0 ) 11 10 13 1 ( 1 . 1 ) 4 9 )( 1 ( 0 . 0 ) 10 2 ATOM 42 | 14 8 ( 2 NIL 1 ( 0 . 2 ) 2 12 13 13 1 ( 0 . 1 ) 13 1 ( 0 . 0 ) 43 | 11 10 13 1 ( 1 . 1 ) 4 9 )( 1 ( 0 . 0 ) 10 2 CONS 14 8 ( 2 NIL 44 | 2 NIL 1 ( 0 . 2 ) 2 13 13 13 1 ( 0 . 1 ) 13 1 ( 0 . 0 ) 11 10 45 | 13 1 ( 1 . 1 ) 4 13 1 ( 0 . 1 ) 13 1 ( 0 . 0 ) 11 11 10 13 1 ( 1 46 | . 1 ) 4 9 )( 1 ( 0 . 0 ) 10 2 IF 14 8 ( 2 NIL 2 NIL 2 ( 9 ) 13 47 | 1 ( 0 . 1 ) 13 1 ( 0 . 0 ) 11 11 11 10 13 1 ( 1 . 1 ) 4 13 2 NIL 48 | 2 ( 9 ) 13 1 ( 0 . 1 ) 13 1 ( 0 . 0 ) 11 11 10 13 1 ( 1 . 1 ) 4 49 | 13 3 ( 2 NIL 1 ( 1 . 2 ) 1 ( 0 . 1 ) 13 1 ( 0 . 0 ) 13 2 8 13 13 50 | 1 ( 1 . 1 ) 13 1 ( 1 . 0 ) 11 10 13 1 ( 2 . 1 ) 4 5 ) 4 9 )( 1 ( 51 | 0 . 0 ) 10 2 LAMBDA 14 8 ( 2 NIL 2 NIL 2 ( 5 ) 13 1 ( 0 . 1 ) 1 52 | ( 0 . 0 ) 11 10 13 13 1 ( 0 . 0 ) 11 11 10 13 1 ( 1 . 1 ) 4 13 53 | 3 ( 1 ( 1 . 2 ) 1 ( 0 . 0 ) 13 2 3 13 5 ) 4 9 )( 1 ( 0 . 0 ) 10 2 54 | LET 14 8 ( 2 NIL 2 NIL 1 ( 0 . 0 ) 11 11 13 1 ( 1 . 5 ) 4 13 55 | 1 ( 0 . 1 ) 2 NIL 1 ( 0 . 0 ) 11 11 13 1 ( 1 . 4 ) 4 13 13 3 ( 56 | 2 NIL 2 NIL 2 ( 5 ) 13 1 ( 0 . 0 ) 13 1 ( 1 . 0 ) 11 10 13 1 ( 57 | 2 . 1 ) 4 13 3 ( 2 NIL 1 ( 2 . 2 ) 2 4 13 1 ( 0 . 0 ) 13 2 3 13 58 | 13 1 ( 2 . 1 ) 13 1 ( 1 . 1 ) 13 1 ( 3 . 2 ) 4 5 ) 4 5 ) 4 9 )( 1 59 | ( 0 . 0 ) 10 2 LETREC 14 8 ( 2 NIL 2 NIL 1 ( 0 . 0 ) 11 11 13 60 | 1 ( 1 . 5 ) 4 13 1 ( 0 . 1 ) 2 NIL 1 ( 0 . 0 ) 11 11 13 1 ( 1 . 61 | 4 ) 4 13 13 3 ( 2 NIL 2 NIL 2 ( 5 ) 13 1 ( 0 . 0 ) 13 1 ( 1 . 0 62 | ) 11 10 13 1 ( 2 . 1 ) 4 13 3 ( 2 NIL 1 ( 2 . 2 ) 2 7 13 1 ( 0 63 | . 0 ) 13 2 3 13 13 1 ( 1 . 0 ) 13 1 ( 1 . 1 ) 13 1 ( 3 . 2 ) 4 2 64 | 6 13 5 ) 4 5 ) 4 9 )( 2 NIL 2 NIL 1 ( 0 . 2 ) 2 4 13 13 1 65 | ( 0 . 1 ) 13 1 ( 0 . 0 ) 10 13 1 ( 1 . 1 ) 4 13 1 ( 0 . 1 ) 13 1 ( 66 | 0 . 0 ) 11 13 1 ( 1 . 2 ) 4 9 ) 9 ) 9 ) 9 ) 9 ) 9 ) 9 ) 9 ) 9 ) 9 ) 9 67 | ) 9 ) 9 ) 9 ) 9 ) 9 ) 9 ) 5 ) 13 3 ( 2 NIL 2 ( 4 21 ) 13 2 NIL 13 68 | 1 ( 0 . 0 ) 13 1 ( 1 . 1 ) 4 5 ) 13 3 ( 1 ( 0 . 0 ) 5 ) 7 4 21 ) 69 | -------------------------------------------------------------------------------- /lispkit/APENDIX2.LSO: -------------------------------------------------------------------------------- 1 | (LETREC COMPILE 2 | (COMPILE LAMBDA (E) 3 | (COMP E (QUOTE NIL) (QUOTE (4 21)))) 4 | (COMP LAMBDA (E N C) 5 | (IF (ATOM E) 6 | (CONS (QUOTE 1) (CONS (LOCATION E N) C)) 7 | (IF (EQ (CAR E) (QUOTE QUOTE)) 8 | (CONS (QUOTE 2) (CONS (CAR (CDR E)) C)) 9 | (IF (EQ (CAR E) (QUOTE ADD)) 10 | (COMP (CAR (CDR E)) N (COMP (CAR (CDR (CDR E))) N (CONS (QUOTE 15) C))) 11 | (IF (EQ (CAR E) (QUOTE SUB)) 12 | (COMP (CAR (CDR E)) N (COMP (CAR (CDR (CDR E))) N (CONS (QUOTE 16) C))) 13 | (IF (EQ (CAR E) (QUOTE MUL)) 14 | (COMP (CAR (CDR E)) N (COMP (CAR (CDR (CDR E))) N (CONS (QUOTE 17) C))) 15 | (IF (EQ (CAR E) (QUOTE DIV)) 16 | (COMP (CAR (CDR E)) N (COMP (CAR (CDR (CDR E))) N (CONS (QUOTE 18) C))) 17 | (IF (EQ (CAR E) (QUOTE REM)) 18 | (COMP (CAR (CDR E)) N (COMP (CAR (CDR (CDR E))) N (CONS (QUOTE 19) C))) 19 | (IF (EQ (CAR E) (QUOTE LEQ)) 20 | (COMP (CAR (CDR E)) N (COMP (CAR (CDR (CDR E))) N (CONS (QUOTE 20) C))) 21 | (IF (EQ (CAR E) (QUOTE EQ)) 22 | (COMP (CAR (CDR E)) N (COMP (CAR (CDR (CDR E))) N (CONS (QUOTE 14) C))) 23 | (IF (EQ (CAR E) (QUOTE CAR)) 24 | (COMP (CAR (CDR E)) N (CONS (QUOTE 10) C)) 25 | (IF (EQ (CAR E) (QUOTE CDR)) 26 | (COMP (CAR (CDR E)) N (CONS (QUOTE 11) C)) 27 | (IF (EQ (CAR E) (QUOTE ATOM)) 28 | (COMP (CAR (CDR E)) N (CONS (QUOTE 12) C)) 29 | (IF (EQ (CAR E) (QUOTE CONS)) 30 | (COMP (CAR (CDR (CDR E))) N (COMP (CAR (CDR E)) N (CONS (QUOTE 13) C))) 31 | (IF (EQ (CAR E) (QUOTE IF)) 32 | (LET (COMP (CAR (CDR E)) N (CONS (QUOTE 8) 33 | (CONS THENPT (CONS ELSEPT C)))) 34 | (THENPT COMP (CAR (CDR (CDR E))) N (QUOTE (9))) 35 | (ELSEPT COMP (CAR (CDR (CDR (CDR E)))) N (QUOTE (9))) ) 36 | (IF (EQ (CAR E) (QUOTE LAMBDA)) 37 | (LET (CONS (QUOTE 3) (CONS BODY C)) 38 | (BODY COMP (CAR (CDR (CDR E))) (CONS (CAR (CDR E)) N) 39 | (QUOTE (5))) ) 40 | (IF (EQ (CAR E) (QUOTE LET)) 41 | (LET (LET (COMPLIS ARGS N (CONS (QUOTE 3) 42 | (CONS BODY (CONS (QUOTE 4) C)))) 43 | (BODY COMP (CAR (CDR E)) M (QUOTE (5)))) 44 | (M CONS (VARS (CDR (CDR E))) N) 45 | (ARGS EXPRS (CDR (CDR E)))) 46 | (IF (EQ (CAR E) (QUOTE LETREC)) 47 | (LET (LET (CONS (QUOTE 6) (COMPLIS ARGS M 48 | (CONS (QUOTE 3) (CONS BODY (CONS (QUOTE 7) C))))) 49 | (BODY COMP (CAR (CDR E)) M (QUOTE (5)))) 50 | (M CONS (VARS (CDR (CDR E))) N) 51 | (ARGS EXPRS (CDR (CDR E)))) 52 | (COMPLIS (CDR E) N (COMP (CAR E) N (CONS (QUOTE 4) C))))))))))))))))))))) 53 | (COMPLIS LAMBDA (E N C) 54 | (IF (EQ E (QUOTE NIL)) (CONS (QUOTE 2) (CONS (QUOTE NIL) C)) 55 | (COMPLIS (CDR E) N (COMP (CAR E) N (CONS (QUOTE 13) C))))) 56 | (LOCATION LAMBDA (E N) 57 | (LETREC 58 | (IF (MEMBER E(CAR N)) (CONS (QUOTE 0) (POSN E (CAR N))) 59 | (INCAR (LOCATION E (CDR N)))) 60 | (MEMBER LAMBDA (E N) 61 | (IF (EQ N (QUOTE NIL)) (QUOTE NIL) 62 | (IF (EQ E (CAR N)) (QUOTE T) (MEMBER E (CDR N))))) 63 | (POSN LAMBDA (E N) 64 | (IF (EQ E (CAR N)) (QUOTE 0) (ADD (QUOTE 1) (POSN E (CDR N))))) 65 | (INCAR LAMBDA (L) (CONS (ADD (QUOTE 1) (CAR L)) (CDR L))))) 66 | (VARS LAMBDA (D) 67 | (IF (EQ D (QUOTE NIL)) (QUOTE NIL) 68 | (CONS (CAR (CAR D)) (VARS (CDR D))))) 69 | (EXPRS LAMBDA (D) 70 | (IF (EQ D (QUOTE NIL)) (QUOTE NIL) 71 | (CONS (CDR (CAR D)) (EXPRS (CDR D))))) ) 72 | -------------------------------------------------------------------------------- /lispkit/Makefile: -------------------------------------------------------------------------------- 1 | TOPDIR = .. 2 | 3 | all: $(TOPDIR)/lispkit/compiler.lob 4 | 5 | include $(TOPDIR)/Rules.mk 6 | -------------------------------------------------------------------------------- /lispkit/README.md: -------------------------------------------------------------------------------- 1 | LispKit Lisp Compiler 2 | ===================== 3 | 4 | This directory contains original LispKit Lisp compiler and an extended version. 5 | The original version (`APENDIX2.LSO`, `APENDIX2.LOB`) may be found in Appendix 2 6 | of 7 | 8 | P. Henderson, "Functional Programming: Application and Implementation", 9 | Prentice Hall, 1980. 10 | 11 | The transcriptions were obtained from . 12 | 13 | The extended version (`compiler.lso`) adds the following: 14 | 15 | - commands to utilize extensions to the SECD instruction set 16 | - short-circuiting AND/OR 17 | - proper handling of tail recursion 18 | - removes requirement to QUOTE numbers 19 | - support for lazy evaluation (DELAY/FORCE) 20 | - support for MACROs (see below) 21 | 22 | Note that the extended version of the compiler must not use any of these 23 | extensions, as it must be compiled by the original compiler. 24 | 25 | 26 | 27 | Macros 28 | ------ 29 | 30 | In the definitions for a `(LET ...)` or `(LETREC ...)` block, one can 31 | include MACRO definitions. They have the same syntax as LAMBDA 32 | definitions except with the keyword MACRO in place of LAMBDA. 33 | Macro definitions do not get compiled. 34 | References to macros are processed at *compile* time, rather than at 35 | run-time: The macro call is replaced with the body from the macro 36 | definition, with its arguments substituted with the provided 37 | S-expressions. 38 | 39 | Example: 40 | 41 | (LET 42 | (F (TEST (1 2 3) 4 5)) 43 | (TEST MACRO (X Y Z) 44 | (LIST (QUOTE X) (CONS Y Z)))) 45 | 46 | While compiling the above, `(TEST (1 2 3) 4 5)` would be replaced by 47 | `(LIST (QUOTE (1 2 3)) (CONS 4 5))`. Compilation would then continue 48 | as if the code had been written as: 49 | 50 | (LET 51 | (F (LIST (QUOTE (1 2 3)) (CONS 4 5)))) 52 | 53 | Note that, if TEST had been a LAMBDA definition, `(TEST (1 2 3) 4 5)` 54 | would be illegal, since `(1 2 3)` would be interpreted as a call to the 55 | function `1`. Because it is a MACRO, however, `(QUOTE (1 2 3))` is 56 | substituted for `(1 2 3)` *before* proceeding with compilation. 57 | 58 | 59 | 60 | Compiling the Compiler 61 | ---------------------- 62 | 63 | To compile the extended compiler, issue the command: 64 | 65 | make 66 | 67 | Compilation of the compiler proceeds in the following manner: 68 | 69 | 1. `APENDIX2.LOB` (transcribed from the Henderson book) is used to compile 70 | `APENDIX2.LSO` (also transcribed from the book). By having the compiler 71 | compile itself, we ensure that the transcription is accurate. This 72 | compiler is written to `primitive-compiler.lob` 73 | 2. `primitive-compiler.lob` is used to compile the extended compiler 74 | (`compiler.lso`). This compiler is written to `compiler.lob.tmp`. 75 | 3. Finally, `compiler.lob.tmp` is used to compile `compiler.lso` again. 76 | This ensures that the compiler is working well enough to compile itself. 77 | This compiler is written to `compiler.lob` and used to compile other 78 | programs. 79 | 80 | -------------------------------------------------------------------------------- /lispkit/compiler.lso: -------------------------------------------------------------------------------- 1 | dnl =========================================================================== 2 | dnl | Extended LispKit Lisp Compiler 3 | dnl | 4 | dnl | This compiler is substantially the same as the one in Henderson's [1] 5 | dnl | book, except for the following: 6 | dnl | 7 | dnl | - additional commands have been added to make use of the additional 8 | dnl | opcodes that have been added to the SECD machine (see secd.asm). 9 | dnl | - the generated code has also been modified to implement proper handling 10 | dnl | of tail calls (Exercise 6.6 in Henderson's book). We also handle 11 | dnl | handling of tail calls when they occur within an (IF ...) expression. 12 | dnl | - For code compiled with this compiler, numbers do not need to be quoted. 13 | dnl | For example, one may use "(EQ X 0)" instead of "(EQ X (QUOTE 0))". 14 | dnl | 15 | dnl | NOTE: This compiler is intended to be compiled by the original LispKit 16 | dnl | Lisp compiler, and so must not use these extended features. 17 | dnl | 18 | dnl | Chapter 6 of Henderson's book describes the construction of this compiler 19 | dnl | in detail. The original compiler and object file, transcribed from 20 | dnl | Appendix 2 of the book, may be found in APENDIX2.LSO and APENDIX2.LOB, 21 | dnl | respectively. 22 | dnl | 23 | dnl | [1] P. Henderson, "Functional Programming: Application and Implementation", 24 | dnl | Prentice Hall, 1980. 25 | dnl =========================================================================== 26 | dnl 27 | (LETREC COMPILE 28 | (COMPILE LAMBDA (E) 29 | (COMP E (INITDEFS) (QUOTE (4 21)))) 30 | (COMP LAMBDA (E N C) 31 | (IF (EQ (SUB E E) (QUOTE 0)) dnl --- is the token a number? 32 | (CONS (QUOTE 2) (CONS E C)) 33 | (IF (ATOM E) 34 | (LET 35 | (IF (EQ LOC (QUOTE NIL)) 36 | (IF (EQ E (QUOTE ADD)) 37 | (COMP (QUOTE (LETREC F 38 | (F LAMBDA (X . REST) 39 | (IF (EQ REST (QUOTE NIL)) 40 | X 41 | (APPLY F (CONS (ADD X (CAR REST)) (CDR REST))))))) N C) 42 | (IF (EQ E (QUOTE SUB)) 43 | (COMP (QUOTE (LAMBDA (A B) (SUB A B))) N C) 44 | (IF (EQ E (QUOTE MUL)) 45 | (COMP (QUOTE (LETREC F 46 | (F LAMBDA (X . REST) 47 | (IF (EQ REST (QUOTE NIL)) 48 | X 49 | (APPLY F (CONS (MUL X (CAR REST)) (CDR REST))))))) N C) 50 | (IF (EQ E (QUOTE MULX)) 51 | (COMP (QUOTE (LAMBDA (A B) (MULX A B))) N C) 52 | (IF (EQ E (QUOTE DIV)) 53 | (COMP (QUOTE (LAMBDA (A B) (DIV A B))) N C) 54 | (IF (EQ E (QUOTE REM)) 55 | (COMP (QUOTE (LAMBDA (A B) (REM A B))) N C) 56 | (IF (EQ E (QUOTE LEQ)) 57 | (COMP (QUOTE (LAMBDA (A B) (LEQ A B))) N C) 58 | (IF (EQ E (QUOTE EQ)) 59 | (COMP (QUOTE (LAMBDA (A B) (EQ A B))) N C) 60 | (IF (EQ E (QUOTE CAR)) 61 | (COMP (QUOTE (LAMBDA (A B) (CAR A B))) N C) 62 | (IF (EQ E (QUOTE CDR)) 63 | (COMP (QUOTE (LAMBDA (A B) (CDR A B))) N C) 64 | (IF (EQ E (QUOTE CONS)) 65 | (COMP (QUOTE (LAMBDA (A B) (CONS A B))) N C) 66 | (IF (EQ E (QUOTE LIST)) 67 | (COMP (QUOTE (LAMBDA X X)) N C) 68 | (IF (EQ E (QUOTE APPLY)) 69 | (COMP (QUOTE (LAMBDA (F X) (APPLY F X))) N C) 70 | (IF (EQ E (QUOTE ATOM)) 71 | (COMP (QUOTE (LAMBDA (X) (ATOM X))) N C) 72 | (IF (EQ E (QUOTE SYMBOL)) 73 | (COMP (QUOTE (LAMBDA (X) (SYMBOL X))) N C) 74 | (IF (EQ E (QUOTE NUMBER)) 75 | (COMP (QUOTE (LAMBDA (X) (NUMBER X))) N C) 76 | (IF (EQ E (QUOTE RECIPE)) 77 | (COMP (QUOTE (LAMBDA (X) (RECIPE X))) N C) 78 | (IF (EQ E (QUOTE STOP)) 79 | (COMP (QUOTE (LAMBDA (X) (STOP X))) N C) 80 | (IF (EQ E (QUOTE GET)) 81 | (COMP (QUOTE (LAMBDA NIL (GET))) N C) 82 | (IF (EQ E (QUOTE PUT)) 83 | (COMP (QUOTE (LAMBDA (X) (PUT X))) N C) 84 | (IF (EQ E (QUOTE PUTEXP)) 85 | (COMP (QUOTE (LAMBDA (X) (PUTEXP X))) N C) 86 | (IF (EQ E (QUOTE AND)) 87 | (COMP (QUOTE (LETREC F 88 | (F LAMBDA (X . REST) 89 | (IF (EQ REST (QUOTE NIL)) 90 | X 91 | (APPLY F (CONS (AND X (CAR REST)) (CDR REST))))))) N C) 92 | (IF (EQ E (QUOTE OR)) 93 | (COMP (QUOTE (LETREC F 94 | (F LAMBDA (X . REST) 95 | (IF (EQ REST (QUOTE NIL)) 96 | X 97 | (APPLY F (CONS (OR X (CAR REST)) (CDR REST))))))) N C) 98 | (LET 99 | (STOP (CONS (QUOTE ERROR) (CONS (QUOTE Undefined) E))) 100 | (STOP LAMBDA (X) ( 101 | (CONS (QUOTE 2) (CONS X (QUOTE (21)))))))))))))))))))))))))))))) 102 | (COMPLOC LOC C)) 103 | (LOC LOCATION E (GETNAMES N))) 104 | (IF (EQ (CAR E) (QUOTE BEGIN)) 105 | (IF (EQ (CDR (CDR E)) (QUOTE NIL)) 106 | (COMP (CAR (CDR E)) N C) 107 | (COMP (CAR (CDR E)) N (CONS (QUOTE 30) (COMP (CONS (QUOTE BEGIN) (CDR (CDR E))) N C)))) 108 | (IF (EQ (CAR E) (QUOTE LIST)) 109 | (IF (EQ (CDR E) (QUOTE NIL)) 110 | (CONS (QUOTE 2) (CONS (QUOTE NIL) C)) 111 | (COMP (CONS (QUOTE LIST) (CDR (CDR E))) N (COMP (CAR (CDR E)) N (CONS (QUOTE 13) C)))) 112 | (IF (EQ (CAR E) (QUOTE APPLY)) 113 | (LET 114 | (COMP (CAR (CDR (CDR E))) N 115 | (COMP (CAR (CDR E)) N APC)) 116 | (APC IF (EQ (CAR C) (QUOTE 5)) 117 | (CONS (QUOTE 26) (CDR C)) 118 | (CONS (QUOTE 4) C))) 119 | (IF (EQ (CAR E) (QUOTE NOP)) 120 | (COMP (CAR (CDR E)) N (CONS (QUOTE 0) C)) 121 | (IF (EQ (CAR E) (QUOTE QUOTE)) 122 | (CONS (QUOTE 2) (CONS (CAR (CDR E)) C)) 123 | (IF (EQ (CAR E) (QUOTE ADD)) 124 | (IF (EQ (CDR (CDR E)) (QUOTE NIL)) 125 | (COMP (CAR (CDR E)) N C) 126 | (IF (EQ (CDR (CDR (CDR E))) (QUOTE NIL)) 127 | (COMP (CAR (CDR E)) N (COMP (CAR (CDR (CDR E))) N (CONS (QUOTE 15) C))) 128 | (COMP 129 | (CONS (QUOTE ADD) 130 | (CONS 131 | (CONS (QUOTE ADD) 132 | (CONS (CAR (CDR E)) 133 | (CONS (CAR (CDR (CDR E))) (QUOTE NIL)))) 134 | (CDR (CDR (CDR E))))) N C))) 135 | (IF (EQ (CAR E) (QUOTE SUB)) 136 | (COMP (CAR (CDR E)) N (COMP (CAR (CDR (CDR E))) N (CONS (QUOTE 16) C))) 137 | (IF (EQ (CAR E) (QUOTE MUL)) 138 | (IF (EQ (CDR (CDR E)) (QUOTE NIL)) 139 | (COMP (CAR (CDR E)) N C) 140 | (IF (EQ (CDR (CDR (CDR E))) (QUOTE NIL)) 141 | (COMP (CAR (CDR E)) N (COMP (CAR (CDR (CDR E))) N (CONS (QUOTE 17) C))) 142 | (COMP 143 | (CONS (QUOTE MUL) 144 | (CONS 145 | (CONS (QUOTE MUL) 146 | (CONS (CAR (CDR E)) 147 | (CONS (CAR (CDR (CDR E))) (QUOTE NIL)))) 148 | (CDR (CDR (CDR E))))) N C))) 149 | (IF (EQ (CAR E) (QUOTE MULX)) 150 | (COMP (CAR (CDR E)) N (COMP (CAR (CDR (CDR E))) N (CONS (QUOTE 28) C))) 151 | (IF (EQ (CAR E) (QUOTE DIV)) 152 | (COMP (CAR (CDR E)) N (COMP (CAR (CDR (CDR E))) N (CONS (QUOTE 18) C))) 153 | (IF (EQ (CAR E) (QUOTE REM)) 154 | (COMP (CAR (CDR E)) N (COMP (CAR (CDR (CDR E))) N (CONS (QUOTE 19) C))) 155 | (IF (EQ (CAR E) (QUOTE LEQ)) 156 | (COMP (CAR (CDR E)) N (COMP (CAR (CDR (CDR E))) N (CONS (QUOTE 20) C))) 157 | (IF (EQ (CAR E) (QUOTE EQ)) 158 | (COMP (CAR (CDR E)) N (COMP (CAR (CDR (CDR E))) N (CONS (QUOTE 14) C))) 159 | (IF (EQ (CAR E) (QUOTE CAR)) 160 | (COMP (CAR (CDR E)) N (CONS (QUOTE 10) C)) 161 | (IF (EQ (CAR E) (QUOTE CDR)) 162 | (COMP (CAR (CDR E)) N (CONS (QUOTE 11) C)) 163 | (IF (EQ (CAR E) (QUOTE ATOM)) 164 | (COMP (CAR (CDR E)) N (CONS (QUOTE 12) C)) 165 | (IF (EQ (CAR E) (QUOTE SYMBOL)) 166 | (COMP (CAR (CDR E)) N (CONS (QUOTE 22) C)) 167 | (IF (EQ (CAR E) (QUOTE NUMBER)) 168 | (COMP (CAR (CDR E)) N (CONS (QUOTE 23) C)) 169 | (IF (EQ (CAR E) (QUOTE RECIPE)) 170 | (COMP (CAR (CDR E)) N (CONS (QUOTE 52) C)) 171 | (IF (EQ (CAR E) (QUOTE STOP)) 172 | (COMP (CAR (CDR E)) N (CONS (QUOTE 21) C)) 173 | (IF (EQ (CAR E) (QUOTE GET)) 174 | (CONS (QUOTE 24) C) 175 | (IF (EQ (CAR E) (QUOTE PUT)) 176 | (COMP (CAR (CDR E)) N (CONS (QUOTE 25) C)) 177 | (IF (EQ (CAR E) (QUOTE PUTEXP)) 178 | (COMP (CAR (CDR E)) N (CONS (QUOTE 29) C)) 179 | (IF (EQ (CAR E) (QUOTE J)) 180 | (COMP (CAR (CDR E)) N (CONS (QUOTE 48) C)) 181 | (IF (EQ (CAR E) (QUOTE INVOKEJ)) 182 | (COMP (CAR (CDR E)) N (CONS (QUOTE 49) C)) 183 | (IF (EQ (CAR E) (QUOTE CVEC)) 184 | (COMP (CAR (CDR E)) N (CONS (QUOTE 31) C)) 185 | (IF (EQ (CAR E) (QUOTE VSET)) 186 | (COMP (CAR (CDR (CDR (CDR E)))) N (COMP (CAR (CDR (CDR E))) N (COMP (CAR (CDR E)) N (CONS (QUOTE 32) C)))) 187 | (IF (EQ (CAR E) (QUOTE VREF)) 188 | (COMP (CAR (CDR (CDR E))) N (COMP (CAR (CDR E)) N (CONS (QUOTE 33) C))) 189 | (IF (EQ (CAR E) (QUOTE VLEN)) 190 | (COMP (CAR (CDR E)) N (CONS (QUOTE 34) C)) 191 | (IF (EQ (CAR E) (QUOTE VCPY)) 192 | (COMP (CAR (CDR (CDR (CDR (CDR (CDR E)))))) N (COMP (CAR (CDR (CDR (CDR (CDR E))))) N (COMP (CAR (CDR (CDR (CDR E)))) N (COMP (CAR (CDR (CDR E))) N (COMP (CAR (CDR E)) N (CONS (QUOTE 35) C)))))) 193 | (IF (EQ (CAR E) (QUOTE CBIN)) 194 | (COMP (CAR (CDR E)) N (CONS (QUOTE 36) C)) 195 | (IF (EQ (CAR E) (QUOTE BSET)) 196 | (COMP (CAR (CDR (CDR (CDR E)))) N (COMP (CAR (CDR (CDR E))) N (COMP (CAR (CDR E)) N (CONS (QUOTE 37) C)))) 197 | (IF (EQ (CAR E) (QUOTE BREF)) 198 | (COMP (CAR (CDR (CDR E))) N (COMP (CAR (CDR E)) N (CONS (QUOTE 38) C))) 199 | (IF (EQ (CAR E) (QUOTE BLEN)) 200 | (COMP (CAR (CDR E)) N (CONS (QUOTE 39) C)) 201 | (IF (EQ (CAR E) (QUOTE BCPY)) 202 | (COMP (CAR (CDR (CDR (CDR (CDR (CDR E)))))) N (COMP (CAR (CDR (CDR (CDR (CDR E))))) N (COMP (CAR (CDR (CDR (CDR E)))) N (COMP (CAR (CDR (CDR E))) N (COMP (CAR (CDR E)) N (CONS (QUOTE 40) C)))))) 203 | (IF (EQ (CAR E) (QUOTE CONS)) 204 | (COMP (CAR (CDR (CDR E))) N (COMP (CAR (CDR E)) N (CONS (QUOTE 13) C))) 205 | (IF (EQ (CAR E) (QUOTE AND)) 206 | (IF (EQ (CDR (CDR E)) (QUOTE NIL)) 207 | (COMP (CAR (CDR E)) N C) 208 | (IF (EQ (CDR (CDR (CDR E))) (QUOTE NIL)) 209 | (COMP (CONS (QUOTE IF) (CONS (CAR (CDR E)) (CONS (CAR (CDR (CDR E))) (CONS (QUOTE (QUOTE F)) (QUOTE NIL))))) N C) 210 | (COMP 211 | (CONS (QUOTE AND) 212 | (CONS 213 | (CONS (QUOTE AND) 214 | (CONS (CAR (CDR E)) 215 | (CONS (CAR (CDR (CDR E))) (QUOTE NIL)))) 216 | (CDR (CDR (CDR E))))) N C))) 217 | (IF (EQ (CAR E) (QUOTE OR)) 218 | (IF (EQ (CDR (CDR E)) (QUOTE NIL)) 219 | (COMP (CAR (CDR E)) N C) 220 | (IF (EQ (CDR (CDR (CDR E))) (QUOTE NIL)) 221 | (COMP (CONS (QUOTE IF) (CONS (CAR (CDR E)) (CONS (QUOTE (QUOTE T)) (CONS (CAR (CDR (CDR E))) (QUOTE NIL))))) N C) 222 | (COMP 223 | (CONS (QUOTE OR) 224 | (CONS 225 | (CONS (QUOTE OR) 226 | (CONS (CAR (CDR E)) 227 | (CONS (CAR (CDR (CDR E))) (QUOTE NIL)))) 228 | (CDR (CDR (CDR E))))) N C))) 229 | (IF (EQ (CAR E) (QUOTE IF)) 230 | (IF (EQ (CAR C) (QUOTE 5)) 231 | (LET (COMP (CAR (CDR E)) N (CONS (QUOTE 27) 232 | (CONS THENPT (CONS ELSEPT C)))) 233 | (THENPT COMP (CAR (CDR (CDR E))) N (QUOTE (5))) 234 | (ELSEPT COMP (CAR (CDR (CDR (CDR E)))) N (QUOTE (5))) ) 235 | (LET (COMP (CAR (CDR E)) N (CONS (QUOTE 8) 236 | (CONS THENPT (CONS ELSEPT C)))) 237 | (THENPT COMP (CAR (CDR (CDR E))) N (QUOTE (9))) 238 | (ELSEPT COMP (CAR (CDR (CDR (CDR E)))) N (QUOTE (9))) )) 239 | (IF (EQ (CAR E) (QUOTE DELAY)) 240 | (LET (CONS (QUOTE 53) (CONS BODY C)) 241 | (BODY COMP (CAR (CDR E)) N (QUOTE (55)))) 242 | (IF (EQ (CAR E) (QUOTE FORCE)) 243 | (COMP (CAR (CDR E)) N (CONS (QUOTE 54) C)) 244 | (IF (EQ (CAR E) (QUOTE LAMBDA)) 245 | (LET (CONS (QUOTE 3) (CONS BODY C)) 246 | (BODY COMP (CAR (CDR (CDR E))) (CONSFORMALS (CAR (CDR E)) N) 247 | (QUOTE (5))) ) 248 | (IF (EQ (CAR E) (QUOTE LET)) 249 | (LET (LET (LET (COMPLIS ARGS N (CONS (QUOTE 3) 250 | (CONS BODY 251 | (IF (EQ (CAR C) (QUOTE 5)) 252 | (CONS (QUOTE 26) (CDR C)) 253 | (CONS (QUOTE 4) C))))) 254 | (BODY COMP (CAR (CDR E)) M (QUOTE (5)))) 255 | (M CONSDEFS DEF N) 256 | (ARGS CAR (CDR DEF))) 257 | 258 | (DEF DEFS (CDR (CDR E)))) 259 | (IF (EQ (CAR E) (QUOTE LETREC)) 260 | (LET (LET (LET (CONS (QUOTE 6) (COMPLIS ARGS M 261 | (CONS (QUOTE 3) (CONS BODY (CONS (QUOTE 7) C))))) 262 | (BODY COMP (CAR (CDR E)) M (QUOTE (5)))) 263 | (M CONSDEFS DEF N) 264 | (ARGS CAR (CDR DEF))) 265 | (DEF DEFS (CDR (CDR E)))) 266 | (LET 267 | (IF (EQ MINDEX (QUOTE NIL)) 268 | (COMPLIS (CDR E) N (COMP (CAR E) N 269 | (IF (EQ (CAR C) (QUOTE 5)) 270 | (CONS (QUOTE 26) (CDR C)) 271 | (CONS (QUOTE 4) C)))) 272 | (LET 273 | (COMP (SUBST (CAR (CDR (CDR MEXPR))) (CAR (CDR MEXPR)) (CDR E)) N C) 274 | (MEXPR ELEM (CDR MINDEX) (ELEM (CAR MINDEX) (GETMEXPRS N))))) 275 | (MINDEX LOCATION (CAR E) (GETMVARS N)))))))))))))))))))))))))))))))))))))))))))))))))) 276 | (COMPLIS LAMBDA (E N C) 277 | (IF (EQ E (QUOTE NIL)) (CONS (QUOTE 2) (CONS (QUOTE NIL) C)) 278 | (COMPLIS (CDR E) N (COMP (CAR E) N (CONS (QUOTE 13) C))))) 279 | (COMPLOC LAMBDA (LOC C) 280 | (IF (ATOM (CDR LOC)) 281 | (CONS (QUOTE 1) (CONS LOC C)) 282 | (IF (EQ (CAR (CDR LOC)) (QUOTE 0)) 283 | (CONS (QUOTE 1) (CONS (CAR LOC) C)) 284 | (COMPLOC (CONS (CAR LOC) (CONS (SUB (CAR (CDR LOC)) (QUOTE 1)) (QUOTE NIL))) 285 | (CONS (QUOTE 11) C))))) 286 | (SUBST LAMBDA (E A M) 287 | (IF (EQ E (QUOTE NIL)) 288 | (QUOTE NIL) 289 | (IF (ATOM E) 290 | (LET 291 | (IF (EQ INDEX (QUOTE NIL)) 292 | E 293 | (IF (ATOM INDEX) 294 | (ELEM INDEX M) 295 | (DROP (CAR INDEX) M))) 296 | (INDEX FIND E A)) 297 | (CONS (SUBST (CAR E) A M) (SUBST (CDR E) A M))))) 298 | (DROP LAMBDA (N L) 299 | (IF (EQ N (QUOTE 0)) 300 | L 301 | (DROP (SUB N (QUOTE 1)) (CDR L)))) 302 | (ELEM LAMBDA (N L) 303 | (IF (EQ N (QUOTE 0)) 304 | (CAR L) 305 | (ELEM (SUB N (QUOTE 1)) (CDR L)))) 306 | (LOCATION LAMBDA (X LL) 307 | (LOCATIONREC X LL (QUOTE 0))) 308 | (LOCATIONREC LAMBDA (X LL ACC) 309 | (IF (EQ LL (QUOTE NIL)) 310 | (QUOTE NIL) 311 | (LET 312 | (IF (EQ INDEX (QUOTE NIL)) 313 | (LOCATIONREC X (CDR LL) (ADD ACC (QUOTE 1))) 314 | (CONS ACC INDEX)) 315 | (INDEX FIND X (CAR LL))))) 316 | (FIND LAMBDA (X L) 317 | (FINDREC X L (QUOTE 0))) 318 | (FINDREC LAMBDA (X L ACC) 319 | (IF (EQ L (QUOTE NIL)) 320 | (QUOTE NIL) 321 | (IF (ATOM L) 322 | (IF (EQ X L) 323 | (CONS ACC (QUOTE NIL)) 324 | (QUOTE NIL)) 325 | (IF (EQ X (CAR L)) 326 | ACC 327 | (FINDREC X (CDR L) (ADD ACC (QUOTE 1))))))) 328 | (CONSDEFS LAMBDA (D DD) 329 | (LET 330 | (CONS N (CONS MV ME)) 331 | (N CONS (CAR D) (CAR DD)) 332 | (MV CONS (CAR (CDR (CDR D))) (CAR (CDR DD))) 333 | (ME CONS (CDR (CDR (CDR D))) (CDR (CDR DD))))) 334 | (CONSFORMALS LAMBDA (ARGS DD) 335 | (LET 336 | (CONS N (CONS MV ME)) 337 | (N CONS ARGS (CAR DD)) 338 | (MV CAR (CDR DD)) 339 | (ME CDR (CDR DD)))) 340 | (INITDEFS LAMBDA NIL 341 | (CONS (QUOTE NIL) (CONS (QUOTE NIL) (QUOTE NIL)))) 342 | (GETNAMES LAMBDA (N) (CAR N)) 343 | (GETMVARS LAMBDA (N) (CAR (CDR N))) 344 | (GETMEXPRS LAMBDA (N) (CDR (CDR N))) 345 | (DEFS LAMBDA (D) 346 | (DEFSREC D (QUOTE NIL) (QUOTE NIL) (QUOTE NIL) (QUOTE NIL))) 347 | (DEFSREC LAMBDA (D VARS EXPRS MVARS MEXPRS) 348 | (IF (EQ D (QUOTE NIL)) 349 | (CONS VARS (CONS EXPRS (CONS MVARS MEXPRS))) 350 | (IF (EQ (CAR (CDR (CAR D))) (QUOTE MACRO)) 351 | (DEFSREC (CDR D) VARS EXPRS (CONS (CAR (CAR D)) MVARS) (CONS (CDR (CAR D)) MEXPRS)) 352 | (DEFSREC (CDR D) (CONS (CAR (CAR D)) VARS) (CONS (CDR (CAR D)) EXPRS) MVARS MEXPRS)))) ) 353 | -------------------------------------------------------------------------------- /meta/Makefile: -------------------------------------------------------------------------------- 1 | TOPDIR = .. 2 | 3 | all: secd.lob 4 | 5 | secd.lob: secd.lso ../util/Util.lso ../util/Pattern.lso ../util/CallCC.lso 6 | 7 | run: run-secd 8 | 9 | include $(TOPDIR)/Rules.mk 10 | -------------------------------------------------------------------------------- /meta/secd.lso: -------------------------------------------------------------------------------- 1 | dnl =========================================================================== 2 | dnl | SECD Machine 3 | dnl | 4 | dnl | An implementation of the SECD machine runs on an underlying SECD machine. 5 | dnl | This implementation does not yet support any of the extended opcodes that 6 | dnl | the underlying machine does. 7 | dnl | 8 | dnl =========================================================================== 9 | (LETREC EXEC 10 | 11 | include(Util.lso) 12 | include(Pattern.lso) 13 | include(CallCC.lso) 14 | 15 | dnl ------------------------------------------------------------------------- 16 | dnl | Applies the next applicable transition to the SECD-machine state. 17 | dnl | 18 | dnl | STATE = A list of the form "(S E C D)" with the contents of the SECD 19 | dnl | machine registers 20 | dnl | STOP = A continuation function to call if the machine halts. The 21 | dnl | function must accept one argument, which is the result computed 22 | dnl | by the SECD-machine 23 | dnl ------------------------------------------------------------------------- 24 | (STEP LAMBDA (STATE STOP) (LETREC 25 | (MATCH STATE 26 | 27 | dnl -- Each rule has one of the following forms: 28 | dnl -- (RULE 29 | dnl -- ) 30 | dnl -- (RULE* 31 | dnl -- ) 32 | dnl -- where: 33 | dnl -- = the symbolic name of the opcode 34 | dnl -- = names to refer to the components extracted from 35 | dnl -- the state 36 | dnl -- = the pattern to match against the current state 37 | dnl -- = what to print if __TRACE__ is enabled 38 | dnl -- = what to transform each of the SECD-machine 39 | dnl -- registers into 40 | dnl -- = the result of the transformation 41 | 42 | (RULE LD (S E I₁ I₂ C D) (_ _ (1 (#_ . #_) . _) _) (LIST (CONS I₁ I₂) (ENVSPEC E)) 43 | (CONS (LOCATE I₁ I₂ E) S) E C D) 44 | 45 | (RULE LDC (S E X C D) (_ _ (2 _ . _) _) X 46 | (CONS X S) E C D) 47 | 48 | (RULE CONS (A B S E C D) ((_ _ . _) _ (13 . _) _) (CONS A B) 49 | (CONS (CONS A B) S) E C D) 50 | 51 | dnl -- Short forms for binary operations: (BINOP ) is 52 | dnl -- equivalent to: 53 | dnl -- (RULE (B A S E C D) ((_ _ . _) _ ( . _) _) 54 | dnl -- 55 | dnl -- (CONS ( B A) S) E C D) 56 | (BINOP 14 EQ) 57 | (BINOP 15 ADD) 58 | (BINOP 16 SUB) 59 | (BINOP 17 MUL) 60 | (BINOP 18 DIV) 61 | (BINOP 19 REM) 62 | (BINOP 20 LEQ) 63 | 64 | (RULE CAR (A S E C D) (((_ . *) . _) _ (10 . _) _) A 65 | (CONS A S) E C D) 66 | 67 | (RULE CDR (B S E C D) (((* . _) . _) _ (11 . _) _) B 68 | (CONS B S) E C D) 69 | 70 | (RULE ATOM (A S E C D) ((_ . _) _ (12 . _) _) (LIST A (ATOM A)) 71 | (CONS (ATOM A) S) E C D) 72 | 73 | (RULE SEL (S E Cf C D) ((F . _) _ (8 * _ . _) _) (QUOTE F) 74 | S E Cf (CONS C D)) 75 | 76 | (RULE SEL (S E Cf C D) ((NIL . _) _ (8 * _ . _) _) (QUOTE F) 77 | S E Cf (CONS C D)) 78 | 79 | (RULE SEL (S E Ct C D) ((* . _) _ (8 _ * . _) _) (QUOTE T) 80 | S E Ct (CONS C D)) 81 | 82 | (RULE JOIN (S E C D) (_ _ (9) (_ . _)) (QUOTE NIL) 83 | S E C D) 84 | 85 | (RULE LDF (S E C′ C D) (_ _ (3 _ . _) _) (LIST C′ (ENVSPEC E)) 86 | (CONS (CONS C′ E) S) E C D) 87 | 88 | (RULE AP (C′ E′ V S E C D) (((_ . _) _ . _) _ (4 . _) _) (LIST C′ (ENVSPEC (CONS V E′))) 89 | (QUOTE NIL) (CONS V E′) C′ (CONS S (CONS E (CONS C D)))) 90 | 91 | (RULE RTN (X S E C D) ((_) * (5) (_ _ _ . _)) (LIST X (ENVSPEC E)) 92 | (CONS X S) E C D) 93 | 94 | (RULE* STOP (X) ((_ . *) * (21) *) X 95 | (STOP X)) 96 | 97 | (RULE* DUM (S E C D) (_ _ (6 . _) _) (ENVSPEC E) 98 | (LETREC 99 | (MATCH V 100 | (CASE* (STATE) (* _ . 1) STATE) 101 | (CASE * (LIST S (CONS Ω E) C (CONS V D)))) 102 | (V CALL/CC (LAMBDA (F) F)) 103 | (Ω DELAY (CAR V)))) 104 | 105 | (RULE* RAP (C′ E′ V S E C F D) (((_ . _) _ . _) (* . _) (7 . _) (_ . _)) (ENVSPEC E′) 106 | (F (CONS V (CONS (LIST (QUOTE NIL) E′ C′ (CONS S (CONS E (CONS C D)))) 1)))) 107 | 108 | (RULE* ERROR (S E C) (_ _ _ *) (LIST S (ENVSPEC E) C) 109 | (STOP (LIST (QUOTE ERROR) S (ENVSPEC E) C))))) 110 | 111 | dnl -- Helper functions 112 | (LOCATE LAMBDA (I₁ I₂ E) 113 | (ELEM I₂ (FORCE (ELEM I₁ E)))) 114 | (ELEM LAMBDA (N L) 115 | (IF (EQ N 0) (CAR L) (ELEM (SUB N 1) (CDR L)))) 116 | 117 | dnl -- Helper macros 118 | (BINOP MACRO (INSTR OP) 119 | (RULE OP (A B S E C D) ((_ _ . _) _ (INSTR . _) _) (LIST B A (OP B A)) 120 | (CONS (OP B A) S) E C D)) 121 | 122 | (RULE MACRO (OP PARAMS PATTERN INFO S E C D) 123 | (RULE* OP PARAMS PATTERN INFO (LIST S E C D))) 124 | 125 | (RULE* MACRO (OP PARAMS PATTERN INFO RESULT) 126 | (CASE* PARAMS PATTERN 127 | (TRACE* OP INFO 128 | RESULT))) 129 | 130 | ifdef(`__TRACE__', 131 | 132 | (TRACE MACRO (OP X) 133 | (BEGIN (PUTEXP (QUOTE OP)) (LET 134 | (BEGIN (PUTEXP (QUOTE OK)) (PUT 10) Y) (Y . X)))) 135 | 136 | (TRACE* MACRO (OP T X) 137 | (BEGIN (PUTEXP (LIST (QUOTE OP) T)) (LET 138 | (BEGIN (PUTEXP (QUOTE OK)) (PUT 10) Y) (Y . X)))) 139 | 140 | (ENVSPEC LAMBDA (E) 141 | (CONS (QUOTE ENV) (ENVSPECREC E))) 142 | 143 | (ENVSPECREC LAMBDA (E) 144 | (MATCH E 145 | (CASE NIL (QUOTE NIL)) 146 | (CASE? (_ . _) (RECIPE _1) (CONS (QUOTE ?) (ENVSPECREC _2))) 147 | (CASE (_ . _) (CONS (LENGTH _1) (ENVSPECREC _2))))) 148 | 149 | ,dnl !__TRACE__ 150 | 151 | (TRACE MACRO (OP X) X) 152 | (TRACE* MACRO (OP T X) X) 153 | 154 | )dnl 155 | 156 | )) 157 | 158 | dnl ------------------------------------------------------------------------- 159 | dnl | Applies SECD-machine transitions repeatedly until the machine halts 160 | dnl | 161 | dnl | STATE = The initial SECD-machine state. A list of the form "(S E C D)" 162 | dnl | with the contents of the SECD machine registers 163 | dnl | STOP = A continuation function to call if the machine halts. The 164 | dnl | function must accept one argument, which is the result computed 165 | dnl | by the SECD-machine 166 | dnl ------------------------------------------------------------------------- 167 | (CYCLE LAMBDA (STATE STOP) 168 | (CYCLE (STEP STATE STOP))) 169 | 170 | dnl ------------------------------------------------------------------------- 171 | dnl | Executes the SECD-machine with the provided code and arguments. 172 | dnl | 173 | dnl | C = The contents of the code (C) register 174 | dnl | S = The contents of the stack (S) register. The list on the top of the 175 | dnl | stack register will be passed as the arguments to the function 176 | dnl | loaded by the code register. 177 | dnl ------------------------------------------------------------------------- 178 | (EXEC LAMBDA (C S) 179 | (CALL/CC 180 | (LAMBDA (STOP) 181 | (CYCLE (LIST S (QUOTE NIL) C (QUOTE NIL)) STOP))))) 182 | -------------------------------------------------------------------------------- /scheme/.gitignore: -------------------------------------------------------------------------------- 1 | SchemeCFG.lso 2 | SchemeDFA.lso 3 | -------------------------------------------------------------------------------- /scheme/BuildSchemeCFG.lso: -------------------------------------------------------------------------------- 1 | dnl --- 2 | (LETREC BuildSchemeCFG 3 | (BuildSchemeCFG LAMBDA NIL 4 | (MAPTOLIST (NEWCFG (FORCE G)))) 5 | 6 | (G DELAY (CFGGRAMMAR (SchemeGrammar))) 7 | 8 | include(SchemeSyntax.lso) 9 | include(Cfg.lso) 10 | 11 | ) 12 | -------------------------------------------------------------------------------- /scheme/BuildSchemeDFA.lso: -------------------------------------------------------------------------------- 1 | dnl --- 2 | (LETREC BuildSchemeDFA 3 | (BuildSchemeDFA LAMBDA NIL 4 | (MAPTOLIST (CFGDFA (MAPFROMLIST SchemeCFG)))) 5 | 6 | include(Map.lso) 7 | include(Cfg.lso) 8 | 9 | (SchemeCFG QUOTE 10 | include(SchemeCFG.lso) 11 | ) 12 | 13 | ) 14 | -------------------------------------------------------------------------------- /scheme/Makefile: -------------------------------------------------------------------------------- 1 | TOPDIR = .. 2 | CLEANFILES = SchemeCFG.lso SchemeDFA.lso 3 | 4 | all: TestLex.lob TestParse.lob 5 | 6 | TestLex.lob: LexScheme.lso ../util/Util.lso 7 | 8 | TestParse.lob: LexScheme.lso SchemeCFG.lso SchemeDFA.lso ../util/Cfg.lso ../util/Util.lso 9 | 10 | BuildSchemeCFG.lob: SchemeSyntax.lso ../util/Cfg.lso 11 | 12 | BuildSchemeDFA.lob: SchemeCFG.lso ../util/Cfg.lso 13 | 14 | SchemeCFG.lso: BuildSchemeCFG.lob 15 | cat $^ | $(SECD) > $@ 16 | 17 | SchemeDFA.lso: BuildSchemeDFA.lob 18 | cat $^ | $(SECD) > $@ 19 | 20 | test-parse: TestParse.lob 21 | @echo ")) " > .init 22 | @cat TestParse.lob .init - | $(SECD) 23 | @rm -f .init 24 | 25 | test-lex: TestLex.lob 26 | @echo ")) " > .init 27 | @cat TestLex.lob .init - | $(SECD) 28 | @rm -f .init 29 | 30 | include $(TOPDIR)/Rules.mk 31 | -------------------------------------------------------------------------------- /scheme/README.md: -------------------------------------------------------------------------------- 1 | Scheme Compiler 2 | =============== 3 | 4 | This directory contains a (currently incomplete) implementation of a 5 | [Scheme (R5RS)](http://www.schemers.org/Documents/Standards/R5RS/) compiler. 6 | 7 | 8 | 9 | Lexer 10 | ----- 11 | 12 | To test the lexer, issue the command: 13 | 14 | make test-lex 15 | 16 | The program reads Scheme tokens from standard input and prints a description of 17 | them to standard output. 18 | 19 | 20 | 21 | Parser 22 | ------ 23 | 24 | To test the parser, issue the command: 25 | 26 | make test-parse 27 | 28 | The program reads the source for a Scheme program from standard input and prints 29 | the parse tree to standard output. 30 | 31 | 32 | 33 | KNOWN ISSUES 34 | ------------ 35 | 36 | This program pushes against the limits of the SECD machine (64K cells) and 37 | will likely crash if it is fed a Scheme program that is too large. The reason 38 | for the 64K limit is that each cell in the SECD machine is 32-bits. A cons pair 39 | (used for building lists) is stored in a single cell as two 16-bit cell indices. 40 | 41 | The reason that test-parse is slow is because it needs to rebuild a large MAP 42 | data structure before it can start parsing. If the map could be loaded directly, 43 | rather than have it rebuild the map from a list of entries, it would be much 44 | faster. Unfortunately attempting to load the MAP on startup causes the 64K 45 | limit to be exceeded. 46 | 47 | I have plans to modify the SECD machine to read its program in a binary format, 48 | rather than parsing text from stdin. This will allow for optimizing the layout 49 | of compiled LispKit Lisp programs (for example, identical tokens could share the 50 | same location in memory). This will help alleviate this issue. 51 | 52 | 53 | -------------------------------------------------------------------------------- /scheme/SchemeSyntax.lso: -------------------------------------------------------------------------------- 1 | dnl =========================================================================== 2 | dnl | Grammar for Scheme (R5RS) syntax 3 | dnl | 4 | dnl | See http://www.schemers.org/Documents/Standards/R5RS for details 5 | dnl | 6 | dnl | The following grammar is structured as a list of items of the form: 7 | dnl | 8 | dnl | ( () () ... ), or 9 | dnl | () 10 | dnl | 11 | dnl | where is a non-terminal symbol, and is followed by a list 12 | dnl | one or more production rules for that symbol, or where is a 13 | dnl | terminal symbol, and thus has no production rules. Each production rule 14 | dnl | is a list of the symbols on the right hand side of the 15 | dnl | production rule. The production rule NIL denotes a production of the form 16 | dnl | 17 | dnl | --> 18 | dnl | 19 | dnl | There is a special non-terminal symbol "START" which must have exactly one 20 | dnl | production rule. 21 | dnl =========================================================================== 22 | ifdef(`scheme_syntax_lso_m4',,`define(`scheme_syntax_lso_m4',1)dnl 23 | 24 | (SchemeGrammar MACRO NIL (LIST 25 | 26 | dnl --------------------------------------------------------------------------- 27 | dnl | Root Production Rule 28 | dnl --------------------------------------------------------------------------- 29 | 30 | (: START (=> (Program))) 31 | 32 | 33 | 34 | dnl --------------------------------------------------------------------------- 35 | dnl | Helper Rules 36 | dnl --------------------------------------------------------------------------- 37 | 38 | (: Identifier* 39 | (=> NIL) 40 | (=>* (Identifier* IDENT) (CONS _2 _1))) 41 | (: Variable* 42 | (=> NIL) 43 | (=>1 (Variable+))) 44 | (: Variable+ 45 | (=> (VARIABLE)) 46 | (=>* (Variable+ VARIABLE) (CONS _2 _1))) 47 | 48 | 49 | 50 | dnl --------------------------------------------------------------------------- 51 | dnl | Terminals 52 | dnl --------------------------------------------------------------------------- 53 | 54 | (: AND) 55 | (: ARROW) 56 | (: BACKQUOTE) 57 | (: BEGIN) 58 | (: BOOL) 59 | (: CASE) 60 | (: CHAR) 61 | (: CLOSEP) 62 | (: COMMA) 63 | (: COMMAAT) 64 | (: COND) 65 | (: DEFINE) 66 | (: DEFINESYNTAX) 67 | (: DELAY) 68 | (: DO) 69 | (: DOT) 70 | (: ELLIPSIS) 71 | (: ELSE) 72 | (: IDENT) 73 | (: IF) 74 | (: KEYWORD) 75 | (: KEYWORDQUOTE) 76 | (: LAMBDA) 77 | (: LET) 78 | (: LETREC) 79 | (: LETRECSYNTAX) 80 | (: LETSTAR) 81 | (: LETSYNTAX) 82 | (: NUMBER) 83 | (: OPENP) 84 | (: OPENVEC) 85 | (: OR) 86 | (: QUOTE) 87 | (: SETBANG) 88 | (: STRING) 89 | (: SYNTAXRULES) 90 | (: VARIABLE) 91 | 92 | 93 | 94 | dnl --------------------------------------------------------------------------- 95 | dnl | 7.1.2 External Representations 96 | dnl --------------------------------------------------------------------------- 97 | 98 | (: Datum 99 | (=>1 (SimpleDatum)) 100 | (=>1 (CompoundDatum))) 101 | (: Datum* 102 | (=> NIL) 103 | (=>1 (Datum+))) 104 | (: Datum+ 105 | (=> (Datum)) 106 | (=>* (Datum+ Datum) (CONS _2 _1))) 107 | (: SimpleDatum 108 | (=>1 (BOOL)) 109 | (=>1 (NUMBER)) 110 | (=>1 (CHAR)) 111 | (=>1 (STRING)) 112 | (=>1 (Symbol))) 113 | (: Symbol 114 | (=>1 (VARIABLE))) 115 | (: CompoundDatum 116 | (=>1 (List)) 117 | (=>1 (Vector))) 118 | (: List 119 | (=>* (OPENP Datum* CLOSEP) (REVERSE _2)) 120 | (=>* (OPENP Datum+ DOT Datum CLOSEP) (APPEND (REVERSE _2) _4)) 121 | (=>1 (Abbreviation))) 122 | (: Abbreviation 123 | (=> (AbbrevPrefix Datum))) 124 | (: AbbrevPrefix 125 | (=>1 (QUOTE)) 126 | (=>1 (BACKQUOTE)) 127 | (=>1 (COMMA)) 128 | (=>1 (COMMAAT))) 129 | (: Vector 130 | (=>* (OPENVEC Datum* CLOSEP) (LIST (QUOTE Vector) (REVERSE _2)))) 131 | 132 | 133 | 134 | dnl --------------------------------------------------------------------------- 135 | dnl | 7.1.3 Expressions 136 | dnl --------------------------------------------------------------------------- 137 | 138 | (: Expression 139 | (=>1 (VARIABLE)) 140 | (=>1 (Literal)) 141 | (=>1 (ProcedureCall)) 142 | (=>1 (LambdaExpression)) 143 | (=>1 (Conditional)) 144 | (=>1 (Assignment)) 145 | (=>1 (DerivedExpression)) 146 | (=>1 (MacroUse)) 147 | (=>1 (MacroBlock))) 148 | (: Literal 149 | (=>1 (Quotation)) 150 | (=>1 (SelfEvaluating))) 151 | (: SelfEvaluating 152 | (=>1 (BOOL)) 153 | (=>1 (NUMBER)) 154 | (=>1 (CHAR)) 155 | (=>1 (STRING))) 156 | (: Quotation 157 | (=>* (QUOTE Datum) (LIST (QUOTE Quotation) _2)) 158 | (=>* (OPENP KEYWORDQUOTE Datum CLOSEP) (LIST (QUOTE Quotation) _3))) 159 | (: ProcedureCall 160 | (=>* (OPENP Operator Operand+ CLOSEP) (LIST (QUOTE ProcedureCall) _2 (REVERSE _3))) 161 | (=>* (OPENP Operator CLOSEP) (LIST (QUOTE ProcedureCall) _2 (QUOTE NIL)))) 162 | (: Operator 163 | (=>1 (Expression))) 164 | (: Operand 165 | (=>1 (Expression))) 166 | (: Operand* 167 | (=> NIL) 168 | (=>* (Operand* Operand) (CONS _2 _1))) 169 | (: Operand+ 170 | (=> (Operand)) 171 | (=>* (Operand+ Operand) (CONS _2 _1))) 172 | (: LambdaExpression 173 | (=>* (OPENP LAMBDA Formals Body CLOSEP) (LIST (QUOTE LambdaExpression) _3 _4))) 174 | (: Formals 175 | (=>* (OPENP Variable* CLOSEP) (REVERSE _2)) 176 | (=>1 (VARIABLE)) 177 | (=>* (OPENP Variable+ DOT VARIABLE CLOSEP) (APPEND (REVERSE _2) _4))) 178 | (: Body 179 | (=>* (Definition* Sequence) (LIST (QUOTE Body) (REVERSE _1) _2))) 180 | (: Sequence 181 | (=>1 (Expression)) 182 | (=>* (Command+ Expression) (APPEND (REVERSE _1) _2))) 183 | (: Command 184 | (=>1 (Expression))) 185 | (: Command* 186 | (=> NIL) 187 | (=>* (Command* Command) (CONS _2 _1))) 188 | (: Command+ 189 | (=> (Command)) 190 | (=>* (Command+ Command) (CONS _2 _1))) 191 | (: Conditional 192 | (=>* (OPENP IF Test Consequent Alternate CLOSEP) 193 | (LIST (QUOTE If) _3 _4 _5))) 194 | (: Test 195 | (=>1 (Expression))) 196 | (: Consequent 197 | (=>1 (Expression))) 198 | (: Alternate 199 | (=>1 (Expression)) 200 | (=> NIL)) 201 | (: Assignment 202 | (=>* (OPENP SETBANG VARIABLE Expression CLOSEP) 203 | (LIST (QUOTE Assignment) _3 _4))) 204 | (: DerivedExpression 205 | (=>* (OPENP COND CondClause+ CLOSEP) (LIST (QUOTE Conditional) (REVERSE _3) (QUOTE NIL))) 206 | (=>* (OPENP COND CondClause+ OPENP ELSE Sequence CLOSEP CLOSEP) 207 | (LIST (QUOTE Conditional) (REVERSE _3) _6)) 208 | (=>* (OPENP COND OPENP ELSE Sequence CLOSEP CLOSEP) 209 | (LIST (QUOTE Conditional) (QUOTE NIL) _5)) 210 | (=>* (OPENP CASE Expression CaseClause+ CLOSEP) 211 | (LIST (QUOTE Case) _3 (REVERSE _4) (QUOTE NIL))) 212 | (=>* (OPENP CASE Expression CaseClause+ OPENP ELSE Sequence CLOSEP CLOSEP) 213 | (LIST (QUOTE Case) _3 (REVERSE _4) _7)) 214 | (=>* (OPENP CASE Expression OPENP ELSE Sequence CLOSEP CLOSEP) 215 | (LIST (QUOTE Case) _3 (QUOTE NIL) _6)) 216 | (=>* (OPENP AND Test* CLOSEP) (LIST (QUOTE And) (REVERSE _3))) 217 | (=>* (OPENP OR Test* CLOSEP) (LIST (QUOTE Or) (REVERSE _3))) 218 | (=>* (OPENP LET OPENP BindingSpec* CLOSEP Body CLOSEP) 219 | (LIST (QUOTE Let) (QUOTE NIL) (REVERSE _4) _6)) 220 | (=>* (OPENP LET VARIABLE OPENP BindingSpec* CLOSEP Body CLOSEP) 221 | (LIST (QUOTE Let) _3 (REVERSE _5) _7)) 222 | (=>* (OPENP LETSTAR OPENP BindingSpec* CLOSEP Body CLOSEP) 223 | (LIST (QUOTE Let*) (REVERSE _4) _6)) 224 | (=>* (OPENP LETREC OPENP BindingSpec* CLOSEP Body CLOSEP) 225 | (LIST (QUOTE LetRec) (REVERSE _4) _6)) 226 | (=>* (OPENP BEGIN Sequence CLOSEP) (LIST (QUOTE Sequence) _3)) 227 | (=>* (OPENP DO OPENP IterationSpec* CLOSEP OPENP Test DoResult CLOSEP Sequence CLOSEP) 228 | (LIST (QUOTE Do) (REVERSE _4) _7 _8 (NTH _0 10))) 229 | (=>* (OPENP DO OPENP IterationSpec* CLOSEP OPENP Test DoResult CLOSEP CLOSEP) 230 | (LIST (QUOTE Do) (REVERSE _4) _7 _8 (QUOTE NIL))) 231 | (=>* (OPENP DELAY Expression CLOSEP) (LIST (QUOTE Delay) _3))) 232 | (: CondClause 233 | (=>* (OPENP Test Sequence CLOSEP) (LIST (QUOTE CondClause) (QUOTE Sequence) _2 _3)) 234 | (=>* (OPENP Test CLOSEP) (LIST (QUOTE CondClause) (QUOTE Self) _2)) 235 | (=>* (OPENP Test ARROW Recipient CLOSEP) (LIST (QUOTE CondClause) (QUOTE Recipient) _2 _4))) 236 | (: CondClause* 237 | (=> NIL) 238 | (=>* (CondClause* CondClause) (CONS _2 _1))) 239 | (: CondClause+ 240 | (=> (CondClause)) 241 | (=>* (CondClause+ CondClause) (CONS _2 _1))) 242 | (: Recipient 243 | (=>1 (Expression))) 244 | (: CaseClause 245 | (=>* (OPENP OPENP Datum* CLOSEP Sequence CLOSEP) 246 | (LIST (QUOTE CaseClause) (REVERSE _3) _5))) 247 | (: BindingSpec 248 | (=>* (OPENP VARIABLE Expression CLOSEP) (LIST (QUOTE BindingSpec) _2 _3))) 249 | (: IterationSpec 250 | (=>* (OPENP VARIABLE Init Step CLOSEP) (LIST (QUOTE IterationSpec) _2 _3 _4)) 251 | (=>* (OPENP VARIABLE Init CLOSEP) (LIST (QUOTE IterationSpec) _2 _3))) 252 | (: Init 253 | (=>1 (Expression))) 254 | (: Step 255 | (=>1 (Expression))) 256 | (: DoResult 257 | (=>1 (Sequence)) 258 | (=> NIL)) 259 | (: MacroUse 260 | (=>* (OPENP Keyword Datum* CLOSEP) (LIST (QUOTE MacroUse) _2 (REVERSE _3)))) 261 | (: Keyword 262 | (=>1 (IDENT))) 263 | (: MacroBlock 264 | (=> (OPENP LETSYNTAX OPENP SyntaxSpec* CLOSEP Body CLOSEP)) 265 | (=> (OPENP LETRECSYNTAX OPENP SyntaxSpec* CLOSEP Body CLOSEP))) 266 | (: SyntaxSpec 267 | (=> (OPENP Keyword TransformerSpec CLOSEP))) 268 | 269 | 270 | 271 | dnl --------------------------------------------------------------------------- 272 | dnl | 7.1.5 Transformers 273 | dnl --------------------------------------------------------------------------- 274 | 275 | (: TransformerSpec 276 | (=> (OPENP SYNTAXRULES OPENP Identifier* CLOSEP SyntaxRule* CLOSEP) 277 | (LIST (QUOTE TransformerSpec) (REVERSE _4) (REVERSE _6)))) 278 | (: SyntaxRule 279 | (=>* (OPENP Pattern Template CLOSEP) (LIST (QUOTE SyntaxRule) _2 _3))) 280 | (: SyntaxRule* 281 | (=> NIL) 282 | (=>* (SyntaxRule* SyntaxRule) (CONS _2 _1))) 283 | (: Pattern 284 | (=>* (PatternIdentifier) (LIST (QUOTE Pattern) (QUOTE SExp) (QUOTE F) _1)) 285 | (=>* (OPENP Pattern* CLOSEP) (LIST (QUOTE Pattern) (QUOTE SExp) (QUOTE F) (REVERSE _2))) 286 | (=>* (OPENP Pattern+ DOT Pattern CLOSEP) (LIST (QUOTE Pattern) (QUOTE SExp) (QUOTE F) (APPEND (REVERSE _2) _4))) 287 | (=>* (OPENP Pattern+ ELLIPSIS CLOSEP) (LIST (QUOTE Pattern) (QUOTE SExp) (QUOTE T) (REVERSE _2))) 288 | (=>* (OPENVEC Pattern* CLOSEP) (LIST (QUOTE Pattern) (QUOTE Vector) (QUOTE F) (REVERSE _2))) 289 | (=>* (OPENVEC Pattern+ ELLIPSIS CLOSEP) (LIST (QUOTE Pattern) (QUOTE Vector) (QUOTE T) (REVERSE _2))) 290 | (=>* (PatternDatum) (LIST (QUOTE Pattern) (QUOTE SExp) (QUOTE F) _1))) 291 | (: Pattern* 292 | (=> NIL) 293 | (=>1 (Pattern+))) 294 | (: Pattern+ 295 | (=> (Pattern)) 296 | (=>* (Pattern+ Pattern) (CONS _2 _1))) 297 | (: PatternDatum 298 | (=>1 (STRING)) 299 | (=>1 (CHAR)) 300 | (=>1 (BOOL)) 301 | (=>1 (NUMBER))) 302 | (: Template 303 | (=>1 (PatternIdentifier)) 304 | (=> (OPENP TemplateElement* CLOSEP)) 305 | (=> (OPENP TemplateElement+ DOT Template CLOSEP)) 306 | (=> (OPENVEC TemplateElement* CLOSEP)) 307 | (=>1 (TemplateDatum))) 308 | (: TemplateElement 309 | (=>1 (Template)) 310 | (=> (Template ELLIPSIS))) 311 | (: TemplateElement* 312 | (=> NIL) 313 | (=>1 (TemplateElement+))) 314 | (: TemplateElement+ 315 | (=> (TemplateElement)) 316 | (=>* (TemplateElement+ TemplateElement) (CONS _2 _1))) 317 | (: TemplateDatum 318 | (=>1 (PatternDatum))) 319 | (: PatternIdentifier 320 | (=>1 (VARIABLE))) dnl --- TODO: Should accept any identifier except "..." 321 | 322 | 323 | 324 | dnl --------------------------------------------------------------------------- 325 | dnl | 7.1.6 Programs and Definitions 326 | dnl --------------------------------------------------------------------------- 327 | 328 | (: Program (=> (CommandOrDefinition*))) 329 | (: CommandOrDefinition 330 | (=>1 (Command)) 331 | (=>1 (Definition)) 332 | (=>1 (SyntaxDefinition))) 333 | dnl (=> (OPENP BEGIN CommandAndDefinition+ CLOSEP))) 334 | dnl ^-- This production rule causes inherent ambiguities in the Scheme 335 | dnl grammar, since (OPENP BEGIN Definition+ CLOSEP) and 336 | dnl (OPENP BEGIN Command+ CLOSEP) are both accounted for by 337 | dnl production rules for "Definition" and for "DerivedExpression", 338 | dnl respectively. This rule essentially serves as a catch-all for 339 | dnl (OPENP BEGIN ... CLOSEP) blocks which either contain syntax 340 | dnl definitions or contain BOTH commands AND definitions. Until we 341 | dnl can implement a proper solution for this case, I am leaving this 342 | dnl production rule out. 343 | (: CommandOrDefinition* 344 | (=> NIL) 345 | (=>1 (CommandOrDefinition+))) 346 | (: CommandOrDefinition+ 347 | (=> (CommandOrDefinition)) 348 | (=>* (CommandOrDefinition+ CommandOrDefinition) (CONS _2 _1))) 349 | (: Definition 350 | (=>* (OPENP DEFINE VARIABLE Expression CLOSEP) 351 | (LIST (QUOTE Definition) _3 _4)) 352 | (=>* (OPENP DEFINE OPENP DefFormals CLOSEP Body CLOSEP) 353 | (LIST (QUOTE Definition) (CAR _4) (LIST (QUOTE LambdaExpression) (CDR _4) _6))) 354 | (=>* (OPENP BEGIN Definition+ CLOSEP) _3)) 355 | (: Definition* 356 | (=> NIL) 357 | (=>* (Definition* Definition) (CONS _2 _1))) 358 | (: Definition+ 359 | (=> (Definition)) 360 | (=>* (Definition+ Definition) (CONS _2 _1))) 361 | (: DefFormals 362 | (=>* (Variable+) (REVERSE _1)) 363 | (=>* (Variable+ DOT VARIABLE) (APPEND (REVERSE _1) _3))) 364 | (: SyntaxDefinition 365 | (=>* (OPENP DEFINESYNTAX IDENT TransformerSpec CLOSEP) 366 | (LIST (QUOTE SyntaxDefinition) _3 _4))) 367 | (: CaseClause* 368 | (=> NIL) 369 | (=>1 (CaseClause+))) 370 | (: CaseClause+ 371 | (=> (CaseClause)) 372 | (=>* (CaseClause+ CaseClause) (CONS _2 _1))) 373 | (: BindingSpec* 374 | (=> NIL) 375 | (=>* (BindingSpec* BindingSpec) (CONS _2 _1))) 376 | (: IterationSpec* 377 | (=> NIL) 378 | (=>* (IterationSpec* IterationSpec) (CONS _2 _1))) 379 | (: SyntaxSpec* 380 | (=> NIL) 381 | (=>* (SyntaxSpec* SyntaxSpec) (CONS _2 _1))) 382 | (: Test* 383 | (=> NIL) 384 | (=>* (Test* Test) (CONS _2 _1))) 385 | dnl --------------------------------------------------------------------------- 386 | )) 387 | 388 | ')dnl 389 | -------------------------------------------------------------------------------- /scheme/TestLex.lso: -------------------------------------------------------------------------------- 1 | dnl --------------------------------------------------------------------------- 2 | dnl Scheme (R5RS) compiler 3 | dnl --------------------------------------------------------------------------- 4 | dnl NOTE: This file must be processed by m4 before being fed to the secd 5 | dnl machine. 6 | dnl --------------------------------------------------------------------------- 7 | 8 | (LETREC COMPILE 9 | (COMPILE LAMBDA NIL 10 | (PRINTTOKENS (LEX (STDIN)))) 11 | 12 | dnl ------------------------------------------------------------------------- 13 | dnl | Processes tokens provided by the lexer by printing them to stdout and 14 | dnl | then passing control back to the lexer. 15 | dnl | X = the token 16 | dnl | REENTRY = the continuation for the lexer 17 | dnl ------------------------------------------------------------------------- 18 | (PRINTTOKENS LAMBDA (TOKENS) 19 | (IF (SISNIL TOKENS) 20 | (QUOTE __EOF__) 21 | (BEGIN 22 | (PRINT (CAR TOKENS)) 23 | (PRINTTOKENS (CDR TOKENS))))) 24 | 25 | dnl ------------------------------------------------------------------------- 26 | dnl | Prints a token to stdout 27 | dnl | X = the token to print 28 | dnl ------------------------------------------------------------------------- 29 | (PRINT LAMBDA (X) 30 | (IF (ISNIL X) dnl --- End of tokens 31 | X 32 | (IF (EQ (CAR X) (QUOTE VARIABLE)) dnl --- VARIABLE token 33 | (BEGIN 34 | (PRINTSTR (QUOTE (40 32))) dnl --- print '( ' 35 | (PUTEXP (QUOTE VARIABLE)) dnl --- print 'VARIABLE' 36 | (PRINTSTR (CDR X)) dnl --- print name 37 | (PRINTSTR (QUOTE (32 41 32))) dnl --- print ' ) ' 38 | X) 39 | (IF (EQ (CAR X) (QUOTE STRING)) dnl --- STRING token 40 | (BEGIN 41 | (PRINTSTR (QUOTE (40 32))) dnl --- print '( ' 42 | (PUTEXP (QUOTE STRING)) dnl --- print 'STRING' 43 | (PRINTSTR (CONS 34 (CDR X))) dnl --- print '"' + str 44 | (PRINTSTR (QUOTE (34 32 41 32))) dnl --- print '" ) ' 45 | X) 46 | (PUTEXP X))))) dnl --- Everything else 47 | 48 | include(Util.lso) 49 | include(Stream.lso) 50 | include(StdIn.lso) 51 | include(LexScheme.lso) 52 | ) 53 | -------------------------------------------------------------------------------- /scheme/TestParse.lso: -------------------------------------------------------------------------------- 1 | dnl --------------------------------------------------------------------------- 2 | dnl Scheme (R5RS) compiler 3 | dnl --------------------------------------------------------------------------- 4 | dnl NOTE: This file must be processed by m4 before being fed to the secd 5 | dnl machine. 6 | dnl --------------------------------------------------------------------------- 7 | 8 | (LETREC COMPILE 9 | (COMPILE LAMBDA NIL 10 | (CFGPARSE 11 | (MAPFROMLIST SchemeCFG) 12 | (MAPFROMLIST SchemeDFA) 13 | (LAMBDA (TOKEN) (CAR TOKEN)) dnl --- TYPE 14 | (LAMBDA (TOKEN) (STOP (CONS (QUOTE ParseError) TOKEN))) dnl --- ERROR 15 | (LEX (STDIN)) 16 | TAGGED)) 17 | 18 | (TAGGED LAMBDA (X LHS RULENUM) 19 | (MATCH LHS 20 | (CASE CommandOrDefinition (BEGIN (PUTEXP X) (PUT 10) (QUOTE NIL))) 21 | (CASE CommandOrDefinition+ (QUOTE NIL)) 22 | (CASE CommandOrDefinition* (QUOTE NIL)) 23 | (CASE * ((FORCE SchemeReduce) X LHS RULENUM)))) 24 | 25 | (SchemeReduce DELAY (CFGREDUCE (SchemeGrammar))) 26 | 27 | include(SchemeSyntax.lso) 28 | 29 | (SchemeCFG QUOTE 30 | include(SchemeCFG.lso) 31 | ) 32 | 33 | (SchemeDFA QUOTE 34 | include(SchemeDFA.lso) 35 | ) 36 | 37 | include(StdIn.lso) 38 | include(Stream.lso) 39 | include(Util.lso) 40 | include(Cfg.lso) 41 | include(LexScheme.lso) 42 | 43 | ) 44 | -------------------------------------------------------------------------------- /secd/.gitignore: -------------------------------------------------------------------------------- 1 | secd 2 | -------------------------------------------------------------------------------- /secd/Makefile: -------------------------------------------------------------------------------- 1 | TOPDIR = .. 2 | CLEANFILES = secd *.o 3 | 4 | all: $(TOPDIR)/secd/secd 5 | 6 | secd: $(TOPDIR)/secd/secd 7 | 8 | include $(TOPDIR)/Rules.mk 9 | -------------------------------------------------------------------------------- /secd/README.md: -------------------------------------------------------------------------------- 1 | SECD Machine Implementation 2 | =========================== 3 | 4 | This directory contains an implementation of an 5 | [SECD machine](http://en.wikipedia.org/wiki/SECD_machine) in x86 assembly. For 6 | details about its implementation, see: 7 | 8 | P. Henderson, "Functional Programming: Application and Implementation", 9 | Prentice Hall, 1980. 10 | 11 | 12 | Source Files 13 | ------------ 14 | 15 | - secd.asm: The implementation of the SECD machine. 16 | - main.asm: The program entry-point 17 | - string.asm: The string-store (stores names of tokens, ensuring that the 18 | same string does not get stored twice, thus ensuring that 19 | we can detect identical tokens). 20 | - support.asm: Functions for reading and writing expressions. 21 | - heap.asm: A heap implementation for dynamic allocation of arbitrarily 22 | sized chunks of memory (used for vector and binary "blob" 23 | data types -- not yet completed). 24 | 25 | -------------------------------------------------------------------------------- /secd/heap.asm: -------------------------------------------------------------------------------- 1 | ; ============================================================================== 2 | ; Heap implementation UNFINISHED 3 | ; 4 | ; This implements dynamic allocation of variable-length chunks of memory. To 5 | ; perform garbage collection, the heap is divided into two halves. Allocation 6 | ; takes place in a linear fashion on one half. When that half becomes full, 7 | ; a we perform a garbage collection cycle. This consists of marking all the 8 | ; chunks which are still in use (which is the responsibility of the client of 9 | ; the heap), and then copying the marked objects to the other half of the heap 10 | ; (thus compacting the heap in the process). Forwarding markers must be left in 11 | ; place of the old objects so that references to those old objects know where 12 | ; to find the new object. 13 | ; ============================================================================== 14 | ; 15 | %define HEAP_SIZE (1*1024*1024) 16 | 17 | segment .data 18 | next dd 0 ; where to allocate next chunk 19 | active_heap dd 0 ; pointer to active half of heap 20 | 21 | segment .bss 22 | align 8 23 | heap1 resb HEAP_SIZE ; first half of heap 24 | heap2 resb HEAP_SIZE ; second half of heap 25 | 26 | ; ============================================================================== 27 | ; Exported functions 28 | ; 29 | segment .text 30 | global _heap_alloc, _heap_forward, _heap_mark, _heap_sweep, \ 31 | _heap_item_length 32 | 33 | ; ------------------------------------------------------------------------------ 34 | ; Allocate a new chunk 35 | ; EXPECTS eax = size of chunk to allocate 36 | ; RETURNS pointer to new chunk, or 0 if the heap is full 37 | ; ------------------------------------------------------------------------------ 38 | _heap_alloc: 39 | push ebx 40 | mov ecx, eax 41 | 42 | ; check if heap is initialized 43 | mov eax, [next] 44 | cmp eax, dword 0 45 | jne .endif_init 46 | mov eax, dword heap1 47 | mov [active_heap], dword heap1 48 | .endif_init: 49 | 50 | ; align on dword boundary 51 | mov edx, ecx 52 | add edx, 3 53 | and edx, 0xfffffffc 54 | 55 | ; check if there is enough space remaining 56 | lea edx, [eax + edx + 4] 57 | mov ebx, [active_heap] 58 | add ebx, dword HEAP_SIZE 59 | cmp edx, ebx 60 | jg .full 61 | .endif_full: 62 | mov [eax], ecx 63 | mov [next], edx 64 | add eax, 4 65 | pop ebx 66 | ret 67 | .full: 68 | mov eax, 0 69 | pop ebx 70 | ret 71 | 72 | ; ------------------------------------------------------------------------------ 73 | ; Marks a chunk 74 | ; EXPECTS eax = pointer to chunk 75 | ; ------------------------------------------------------------------------------ 76 | _heap_mark: 77 | or [eax - 4], dword 0x80000000 78 | ret 79 | 80 | ; ------------------------------------------------------------------------------ 81 | ; Compacts heap by moving all marked chunks to the other half. 82 | ; ------------------------------------------------------------------------------ 83 | _heap_sweep: 84 | push ebx 85 | push esi 86 | push edi 87 | 88 | cld 89 | mov ebx, dword [active_heap] 90 | mov esi, ebx 91 | add ebx, dword HEAP_SIZE 92 | 93 | cmp esi, dword heap1 94 | jne .else 95 | mov edi, dword heap2 96 | jmp .endif 97 | .else: 98 | mov edi, dword heap1 99 | .endif: 100 | mov dword [active_heap], edi 101 | 102 | .loop: 103 | mov ecx, dword [esi] 104 | test ecx, dword 0x80000000 105 | jz .unmarked 106 | and ecx, dword 0x7fffffff 107 | mov dword [edi], ecx 108 | add edi, 4 109 | mov dword [esi], edi 110 | add esi, 4 111 | add ecx, 3 112 | and ecx, 0xfffffffc 113 | shr ecx, 2 114 | .loop_copy: 115 | rep movsd 116 | jcxz .endloop 117 | loop .loop_copy 118 | 119 | .unmarked: 120 | add esi, 4 121 | add esi, ecx 122 | .endloop: 123 | cmp esi, dword HEAP_SIZE 124 | jle .loop 125 | 126 | mov dword [next], edi 127 | 128 | pop edi 129 | pop esi 130 | pop ebx 131 | ret 132 | 133 | ; ------------------------------------------------------------------------------ 134 | ; Follows chunk forwarding pointer 135 | ; EXPECTS eax = pointer to forwarded chunk 136 | ; RETURNS pointer to new location of chunk 137 | ; ------------------------------------------------------------------------------ 138 | _heap_forward: 139 | mov eax, dword [eax - 4] 140 | ret 141 | 142 | ; ------------------------------------------------------------------------------ 143 | ; Gets the size of a chunk 144 | ; EXPECTS eax = pointer to chunk 145 | ; RETURNS size of chunk 146 | ; ------------------------------------------------------------------------------ 147 | _heap_item_length: 148 | mov eax, dword [eax - 4] 149 | and eax, 0x7fffffff 150 | ret 151 | 152 | -------------------------------------------------------------------------------- /secd/main.asm: -------------------------------------------------------------------------------- 1 | ; ============================================================================== 2 | ; SECD machine entry point 3 | ; ============================================================================== 4 | ; 5 | %include 'system.inc' 6 | 7 | %define NEWLINE 10 8 | 9 | segment .data 10 | extern tt_eof, tt_num, tt_alpha, tt_delim, nil 11 | 12 | segment .text 13 | global _start 14 | extern _putchar, _flush, _init_strings, _init, \ 15 | _scan, _putexp, _getexp, _exec, _getexplist 16 | 17 | ; ------------------------------------------------------------------------------ 18 | ; Entry point 19 | ; 20 | _start: 21 | call _init_strings ; initialize string-store 22 | call _init ; initialize SECD machine 23 | call _scan 24 | call _getexp ; read SECD object to process 25 | mov ebx, eax 26 | call _getexplist ; read expressions to pass to entry function 27 | push eax 28 | push ebx 29 | call _exec ; pass control to SECD machine 30 | add esp, 8 31 | push eax 32 | call _putexp ; print resulting expression 33 | add esp, 4 34 | push dword NEWLINE 35 | call _putchar ; print newline 36 | add esp, 4 37 | call _flush ; flush stdout 38 | sys.exit 0 ; done 39 | .halt: 40 | jmp .halt 41 | 42 | -------------------------------------------------------------------------------- /secd/secd.inc: -------------------------------------------------------------------------------- 1 | ; vim: filetype=nasm 2 | ; ============================================================================== 3 | ; Data cell type flags 4 | ; 5 | ; See secd.asm for details on data cell format and flags. 6 | ; ============================================================================== 7 | ; 8 | %define SECD_TYPEMASK 0x77 9 | %define SECD_CONS 0x00 10 | %define SECD_ATOM 0x01 11 | %define SECD_SYMBOL 0x00 | SECD_ATOM 12 | %define SECD_NUMBER 0x02 | SECD_ATOM 13 | %define SECD_BOOLEAN 0x04 | SECD_ATOM 14 | %define SECD_RECIPE 0x08 15 | %define SECD_HEAP 0x10 16 | %define SECD_VECTOR 0x20 | SECD_HEAP | SECD_ATOM 17 | %define SECD_BINARY 0x40 | SECD_HEAP | SECD_ATOM 18 | -------------------------------------------------------------------------------- /secd/string.asm: -------------------------------------------------------------------------------- 1 | ; ============================================================================== 2 | ; String-store implementation 3 | ; 4 | ; The string-store represents a set of strings used for symbols. It ensures 5 | ; that only one copy of any given string is ever added, so that equal strings in 6 | ; the input evaluate to the same symbol. 7 | ; ============================================================================== 8 | ; 9 | %define STORE_SIZE 65536 ; Amount of memory for string storage 10 | %define HASH_SIZE 16381 ; Size of hash table (should be a prime number) 11 | 12 | segment .bss 13 | hash resd HASH_SIZE ; Hash table 14 | data resb STORE_SIZE ; String storage block 15 | dataptr resd 1 ; Location to store next string 16 | dataend resd 1 ; End of string stoage block 17 | 18 | 19 | ; ============================================================================== 20 | ; Exported functions 21 | ; 22 | segment .text 23 | global _init_strings, _store 24 | 25 | ; ------------------------------------------------------------------------------ 26 | ; Initializes the string store 27 | ; ------------------------------------------------------------------------------ 28 | _init_strings: 29 | enter 0, 0 30 | push edi 31 | mov eax, 0 32 | mov ecx, HASH_SIZE 33 | mov edi, dword hash 34 | cld 35 | rep stosd 36 | mov eax, dword data 37 | mov [dataptr], eax 38 | add eax, STORE_SIZE 39 | mov [dataend], eax 40 | pop edi 41 | leave 42 | ret 43 | 44 | ; ------------------------------------------------------------------------------ 45 | ; Addes a new string to the string store 46 | ; USAGE: _store(, ) 47 | ; = the string to store 48 | ; = the length of the string 49 | ; RETURNS the pointer to the string in the string store, or 0 if the string 50 | ; store is full. 51 | ; ------------------------------------------------------------------------------ 52 | _store: 53 | enter 0, 0 54 | push esi 55 | push edi 56 | 57 | mov esi, [ebp + 8] ; ESI <-- 58 | mov ecx, [ebp + 12] ; ECX <-- 59 | 60 | push ecx 61 | push esi 62 | call _hash ; compute hash code 63 | add esp, 8 64 | 65 | mov ecx, dword HASH_SIZE 66 | mov edx, 0 67 | div ecx 68 | .probe_loop: ; scan for empty cell to store string in 69 | mov edi, [dword hash + edx * 4] 70 | cmp edi, 0 71 | je .probe_endloop 72 | 73 | push ecx 74 | mov ecx, [ebp + 12] 75 | .compare_loop: 76 | cmpsb 77 | jne .compare_endloop 78 | cmp byte [edi], 0 79 | loopne .compare_loop 80 | cmp byte [edi], 0 81 | jne .compare_endloop 82 | pop ecx 83 | mov eax, [dword hash + edx * 4] 84 | jmp .done 85 | 86 | .compare_endloop: 87 | pop ecx 88 | 89 | mov esi, [ebp + 8] 90 | 91 | ; TODO: check if the string at this location in the 92 | ; hash table matches the string we are trying to 93 | ; store. If so, return that string 94 | inc edx 95 | cmp edx, dword HASH_SIZE 96 | jne .endif 97 | mov edx, 0 98 | .endif: 99 | loop .probe_loop 100 | jmp .full 101 | .probe_endloop: 102 | 103 | mov ecx, [ebp + 12] 104 | 105 | mov edi, [dataptr] ; check if write will go past end of string 106 | mov eax, edi ; store. 107 | add eax, ecx 108 | cmp eax, [dataend] 109 | jge .full 110 | 111 | mov [dword hash + edx * 4], edi 112 | 113 | cld 114 | rep movsb ; write string to string store 115 | mov byte [edi], 0 116 | inc edi 117 | xchg edi, [dataptr] ; update ptr to next string 118 | mov eax, edi 119 | .done: 120 | pop edi 121 | pop esi 122 | leave 123 | ret 124 | .full: 125 | mov eax, 0 126 | jmp .done 127 | 128 | 129 | ; ============================================================================== 130 | ; Internal functions 131 | ; 132 | 133 | ; ------------------------------------------------------------------------------ 134 | ; Computes the hash code for a string 135 | ; USAGE: _hash(, ) 136 | ; = the string to compute the hash code for 137 | ; = the length of the string 138 | ; RETURNS the hash code 139 | ; ------------------------------------------------------------------------------ 140 | _hash: 141 | enter 0, 0 142 | push esi 143 | mov esi, [ebp + 8] ; ESI <-- 144 | mov ecx, [ebp + 12] ; ECX <-- 145 | mov eax, 0 146 | .loop: 147 | mov edx, 0 148 | mov dl, byte [esi] 149 | inc esi 150 | sub edx, eax 151 | shl eax, 6 152 | add edx, eax 153 | shl eax, 10 154 | add eax, edx 155 | loop .loop 156 | .done: 157 | pop esi 158 | leave 159 | ret 160 | 161 | -------------------------------------------------------------------------------- /secd/support.asm: -------------------------------------------------------------------------------- 1 | ; ============================================================================== 2 | ; Support Functions 3 | ; 4 | ; This file contains procedures to read and print characters, LispKit Lisp 5 | ; tokens and expressions. 6 | ; ============================================================================== 7 | ; 8 | %include 'system.inc' 9 | %include 'secd.inc' 10 | 11 | %define INBUF_SIZE 1024 ; size of read buffer 12 | %define OUTBUF_SIZE 80 ; size of write buffer 13 | %define MAX_TOKEN_SIZE 1024 ; maximum token length 14 | 15 | section .data 16 | global tt_eof, tt_num, tt_alpha, tt_delim 17 | extern nil 18 | 19 | tt_eof db "ENDFILE", 0 ; token types 20 | tt_num db "NUMERIC", 0 21 | tt_alpha db "ALPHANUMERIC", 0 22 | tt_delim db "DELIMITER", 0 23 | eof dd 0 ; end of file token 24 | outbufind dd 0 ; index into write buffer 25 | open_paren db "(" 26 | close_paren db ")" 27 | dot db "." 28 | ellipsis db "..." ; Used when printing a recursive expr. 29 | ellips_len equ $ - ellipsis 30 | recipe db "?" ; Used when printing a recipe 31 | recipe_len equ $ - recipe 32 | 33 | section .bss 34 | inbuf resb INBUF_SIZE ; read buffer 35 | outbuf resb OUTBUF_SIZE ; write buffer 36 | inbufptr resd 1 ; index into read buffer 37 | inbufend resd 1 ; pointer to end of read buffer 38 | char resd 1 ; last character read by _getchar 39 | token resb MAX_TOKEN_SIZE ; last token read by _gettoken 40 | type resd 1 ; type of last token read by _gettoken 41 | visited resb 65536 ; visited flag while printing expr 42 | 43 | section .text 44 | global _putchar, _length, _puttoken, _tostring, _tointeger, \ 45 | _getchar, _gettoken, _isdigit, _isletter, _scan, _isws, \ 46 | _flush, _putexp, _getexp, _getexplist 47 | extern _flags, _ivalue, _svalue, _car, _cdr, _store, _cons, _symbol, \ 48 | _number 49 | 50 | ; ------------------------------------------------------------------------------ 51 | ; Reads an expression from stdin 52 | ; EXPECTS token = the initial token 53 | ; RETURNS the index of the cons cell at the root of the expression 54 | ; ------------------------------------------------------------------------------ 55 | _getexp: 56 | enter 0, 0 57 | cmp [token], byte '(' 58 | jne .elseif 59 | cmp [token + 1], byte 0 60 | jne .elseif ; If next token is '(', then... 61 | call _scan ; Expression is a cons cell 62 | call _getexplist 63 | jmp .endif 64 | 65 | .elseif: 66 | cmp [type], dword tt_num 67 | jne .else ; If token is a number, then... 68 | push dword MAX_TOKEN_SIZE ; Convert to an integer and allocate a 69 | push dword token ; number cell 70 | call _tointeger 71 | add esp, 8 72 | call _number 73 | jmp .endif 74 | 75 | .else: ; Otherwise token is a symbol 76 | push dword token 77 | call _length 78 | add esp, 4 79 | push eax 80 | push dword token 81 | call _store ; Put in string-store and allocate a 82 | add esp, 8 ; symbol cell 83 | call _symbol 84 | 85 | .endif: 86 | push eax 87 | call _scan ; Scan for next token 88 | pop eax 89 | leave 90 | ret 91 | 92 | ; ------------------------------------------------------------------------------ 93 | ; Reads a list of expressions from stdin 94 | ; EXPECTS token = the initial token 95 | ; RETURNS eax = the index of the cons cell at the root of a list consisting of 96 | ; all of the expressions read 97 | ; ------------------------------------------------------------------------------ 98 | _getexplist: 99 | enter 0, 0 100 | push ebx 101 | call _getexp ; Read the car 102 | mov ebx, eax 103 | cmp [token], byte '.' 104 | jne .elseif 105 | cmp [token + 1], byte 0 106 | jne .else ; If next token is a dot, then... 107 | call _scan ; The cdr is a single expression 108 | call _getexp 109 | jmp .endif 110 | 111 | .elseif: 112 | cmp [token], byte ')' 113 | jne .else 114 | cmp [token + 1], byte 0 115 | jne .else ; If the next token is ')', then 116 | mov eax, dword 0 ; The cdr is NIL 117 | jmp .endif 118 | 119 | .else: 120 | call _getexplist ; Neither dot nor ')', cdr is a list 121 | 122 | .endif: 123 | mov edx, eax ; Assemble car and cdr into a cons cell 124 | mov eax, ebx 125 | call _cons 126 | pop ebx 127 | leave 128 | ret 129 | 130 | ; ------------------------------------------------------------------------------ 131 | ; Prints an expression to stdout 132 | ; USAGE: _putexp() 133 | ; = the index of a cell containing the expression to print 134 | ; ------------------------------------------------------------------------------ 135 | _putexp: 136 | enter 0, 0 137 | push ebx 138 | mov ebx, [ebp + 8] ; EBX <-- 139 | cmp [visited + ebx], byte 0 140 | je .not_visited 141 | push dword ellips_len ; Already in the process of printing 142 | push dword ellipsis ; the expression we're being asked to 143 | call _puttoken ; print (i.e., it is a recursive 144 | add esp, 8 ; expression), so print an ellipsis and 145 | pop ebx ; quit. 146 | leave 147 | ret 148 | .not_visited: 149 | mov [visited + ebx], byte 1 ; Mark visited while printing 150 | mov eax, ebx 151 | call _flags ; Branch depending on type of expression 152 | test eax, SECD_RECIPE 153 | jnz .putrecipe 154 | test eax, SECD_ATOM 155 | jz .putcons 156 | and eax, SECD_TYPEMASK 157 | cmp eax, SECD_SYMBOL 158 | je .putsym 159 | .putint: ; Expression is a number 160 | mov eax, ebx 161 | call _ivalue ; Get the value 162 | sub esp, 12 163 | mov ebx, esp 164 | push ebx 165 | push eax 166 | call _tostring ; Convert it to a string 167 | add esp, 8 168 | push dword 12 169 | push ebx 170 | call _puttoken ; Print the number 171 | add esp, 20 172 | jmp .done 173 | .putsym: ; Expression is a symbol 174 | mov eax, ebx 175 | call _ivalue ; Get the address of the string 176 | mov ebx, eax 177 | push eax 178 | call _length ; Get the length of the string 179 | add esp, 4 180 | push eax 181 | push ebx 182 | call _puttoken ; Print the name of the symbol 183 | add esp, 8 184 | jmp .done 185 | .putrecipe: 186 | push dword recipe_len 187 | push dword recipe 188 | call _puttoken 189 | add esp, 8 190 | jmp .done 191 | .putcons: ; Expression is a cons cell 192 | push dword 1 193 | push dword open_paren 194 | call _puttoken 195 | add esp, 8 196 | .consloop: ; Print the car and advance to the cdr, 197 | mov eax, ebx ; continuing as long as the cdr is also 198 | call _car ; a cons cell. 199 | push eax 200 | call _putexp 201 | add esp, 4 202 | mov eax, ebx 203 | call _cdr 204 | mov ebx, eax 205 | call _flags 206 | and eax, SECD_TYPEMASK | SECD_RECIPE 207 | cmp eax, SECD_CONS 208 | je .consloop 209 | cmp eax, SECD_SYMBOL ; If the last CDR is not NIL, then print 210 | jne .cons_dot ; dot before printing the CDR, otherwise 211 | mov edx, ebx ; just print the close parenthesis. 212 | mov eax, dword 0 213 | call _ivalue 214 | xchg eax, ebx 215 | call _ivalue 216 | cmp eax, ebx 217 | je .cons_end 218 | mov ebx, edx 219 | .cons_dot: 220 | push dword 1 221 | push dword dot 222 | call _puttoken ; Print the dot 223 | add esp, 8 224 | push ebx 225 | call _putexp ; Print the last cdr 226 | add esp, 4 227 | .cons_end: 228 | push dword 1 229 | push dword close_paren 230 | call _puttoken ; Print the close parenthesis 231 | add esp, 8 232 | .done: 233 | mov ebx, [ebp + 8] 234 | mov [visited + ebx], byte 0 ; Done printing.. clear visited flag 235 | pop ebx 236 | leave 237 | ret 238 | 239 | ; ------------------------------------------------------------------------------ 240 | ; Determines if the specified character is a whitespace character 241 | ; USAGE: _isws() 242 | ; = the ASCII code of the character to check 243 | ; RETURNS non-zero if is a whitespace character, zero otherwise. 244 | ; ------------------------------------------------------------------------------ 245 | _isws: 246 | enter 0, 0 247 | mov eax, [ebp + 8] ; EAX <-- 248 | cmp eax, 13 ; \n 249 | je .true 250 | cmp eax, 10 ; \r 251 | je .true 252 | cmp eax, 9 ; \t 253 | je .true 254 | cmp eax, 32 ; space 255 | je .true 256 | cmp eax, 0 ; \0 257 | je .true 258 | mov eax, 0 ; return 0 259 | leave 260 | ret 261 | .true: 262 | mov eax, 1 ; return 1 263 | leave 264 | ret 265 | 266 | ; ------------------------------------------------------------------------------ 267 | ; Reads a character from stdin and puts it in [char]. If at the end of the 268 | ; file, [eof] will be set to 1. 269 | ; USAGE: _getchar() 270 | ; RETURNS the ASCII code of the character read, or -1 if at the end of the file 271 | ; ------------------------------------------------------------------------------ 272 | _getchar: 273 | enter 0, 0 274 | push esi 275 | mov esi, [inbufptr] ; First see if the buffer has input 276 | cmp esi, [inbufend] ; available 277 | jl .endif 278 | ; Fill the buffer 279 | sys.read stdin, inbuf, INBUF_SIZE 280 | cmp eax, 0 281 | je .eof 282 | jl .error 283 | mov esi, dword inbuf 284 | add eax, esi 285 | mov [inbufend], eax 286 | .endif: 287 | mov eax, 0 ; We have a char to return 288 | mov al, byte [esi] 289 | mov [char], eax 290 | inc esi 291 | mov [inbufptr], esi 292 | .done: 293 | pop esi 294 | leave 295 | ret 296 | .error: 297 | .eof: 298 | mov eax, -1 ; End of file 299 | mov [eof], dword 1 300 | jmp .done 301 | 302 | ; ------------------------------------------------------------------------------ 303 | ; Reads a token from stdin. 304 | ; USAGE: _gettoken(,) 305 | ; = the buffer in which to read the token 306 | ; = the length of the buffer 307 | ; RETURNS the length of the token 308 | ; ------------------------------------------------------------------------------ 309 | _gettoken: 310 | enter 0, 0 311 | push ebx 312 | push edi 313 | mov edi, [ebp + 8] ; EDI <-- 314 | mov ecx, [ebp + 12] ; ECX <-- 315 | .loop: ; Loop to skip over whitespace 316 | cmp dword [eof], 0 ; at end of file? 317 | jne .eof 318 | push dword [char] 319 | call _isws 320 | add esp, 4 321 | cmp eax, 0 322 | je .endloop 323 | call _getchar 324 | jmp .loop 325 | .endloop: 326 | mov ebx, dword [char] ; EBX <-- first non-whitespace char 327 | 328 | push ebx ; Branch based on first character 329 | call _isdigit 330 | add esp, 4 331 | 332 | cmp eax, 0 333 | jne .digit ; Token is a number 334 | cmp ebx, '-' 335 | je .dash ; Could be symbol or number 336 | 337 | push ebx 338 | call _isletter 339 | add esp, 4 340 | cmp eax, 0 341 | jne .letter ; Token is a symbol 342 | 343 | ; Fall through -- token is a delimiter (parenthesis or dot) 344 | 345 | .delimiter: ; Handle delimiter 346 | mov edx, [ebp + 16] 347 | mov [edx], dword tt_delim 348 | mov byte [edi], bl 349 | inc edi 350 | call _getchar 351 | jmp .done 352 | 353 | .eof: ; Handle end of file 354 | mov edx, [ebp + 16] 355 | mov [edx], dword tt_eof 356 | jmp .done 357 | 358 | .dash: ; Handle token beginning with a dash 359 | mov byte [edi], bl 360 | inc edi 361 | call _getchar 362 | mov ebx, dword [char] ; Branch based on second character 363 | push ebx 364 | call _isletter 365 | add esp, 4 366 | cmp eax, 0 367 | jne .letter ; Token is a symbol 368 | push ebx 369 | call _isdigit 370 | add esp, 4 371 | cmp eax, 0 372 | jne .digit ; Token is a number 373 | jmp .alpha_endloop ; End of token: single "-" is a symbol 374 | 375 | .digit: ; Handle token beginning with a digit 376 | mov byte [edi], bl 377 | inc edi 378 | call _getchar 379 | mov ebx, dword [char] 380 | .digit_loop: ; Loop through digits 381 | push ebx 382 | call _isdigit 383 | add esp, 4 384 | cmp eax, 0 385 | je .digit_endloop 386 | mov byte [edi], bl 387 | inc edi 388 | call _getchar 389 | mov ebx, dword [char] 390 | jmp .digit_loop 391 | .digit_endloop: 392 | push ebx 393 | call _isletter ; If the token has letters following the 394 | add esp, 4 ; numbers, it is a symbol. 395 | cmp eax, 0 396 | jne .letter 397 | mov edx, [ebp + 16] ; Otherwise, it's a number 398 | mov [edx], dword tt_num 399 | jmp .done 400 | 401 | .letter: ; Handle token beginning with a letter 402 | mov byte [edi], bl 403 | inc edi 404 | call _getchar 405 | mov ebx, dword [char] 406 | .alpha_loop: ; Read in remaining letters and numbers 407 | push ebx 408 | call _isletter 409 | add esp, 4 410 | cmp eax, 0 411 | jne .alpha_continue 412 | push ebx 413 | call _isdigit 414 | add esp, 4 415 | cmp eax, 0 416 | je .alpha_endloop 417 | .alpha_continue: ; Hit whitespace or delimieter, we're 418 | mov byte [edi], bl ; done reading the symbol 419 | inc edi 420 | call _getchar 421 | mov ebx, dword [char] 422 | jmp .alpha_loop 423 | .alpha_endloop: 424 | mov edx, [ebp + 16] 425 | mov [edx], dword tt_alpha 426 | 427 | .done: 428 | mov eax, edi 429 | sub eax, [ebp + 8] ; EAX <-- length of token 430 | mov [edi], byte 0 431 | pop edi 432 | pop ebx 433 | leave 434 | ret 435 | 436 | ; ------------------------------------------------------------------------------ 437 | ; Scans stdin for the next token 438 | ; USAGE: _scan() 439 | ; ------------------------------------------------------------------------------ 440 | _scan: 441 | enter 0, 0 442 | push dword type 443 | push dword MAX_TOKEN_SIZE 444 | push dword token 445 | call _gettoken 446 | add esp, 12 447 | cmp [type], dword tt_eof 448 | jne .endif 449 | mov [type], dword tt_delim 450 | mov [token], byte ')' 451 | mov [token + 1], byte 0 452 | .endif: 453 | leave 454 | ret 455 | 456 | ; ------------------------------------------------------------------------------ 457 | ; Determines if character is a digit 458 | ; USAGE: _isdigit() 459 | ; = the ASCII code of the character to check 460 | ; RETURNS non-zero if is a digit, zero otherwise 461 | ; ------------------------------------------------------------------------------ 462 | _isdigit: 463 | enter 0, 0 464 | mov eax, [ebp + 8] ; EAX <-- 465 | cmp eax, '0' 466 | jl .else ; < '0'? 467 | cmp eax, '9' 468 | jg .else ; > '9'? 469 | mov eax, 1 ; return 1 470 | leave 471 | ret 472 | .else: 473 | mov eax, 0 ; return 0 474 | leave 475 | ret 476 | 477 | ; ------------------------------------------------------------------------------ 478 | ; Determines if character is a "letter". Anything that is not a digit, a dash, 479 | ; whitespace, or a delimiter (open or close parenthesis or a dot) is considered 480 | ; to be a letter. 481 | ; USAGE: _isletter() 482 | ; = the ASCII code of the character to check 483 | ; RETURNS non-zero if is a "letter", zero otherwise 484 | ; ------------------------------------------------------------------------------ 485 | _isletter: 486 | enter 0, 0 487 | mov eax, [ebp + 8] ; EAX <-- 488 | push eax 489 | call _isws ; Is it a whitespace char? 490 | add esp, 4 491 | cmp eax, 0 492 | jne .false 493 | mov eax, [ebp + 8] 494 | push eax 495 | call _isdigit ; Is it a digit? 496 | add esp, 4 497 | cmp eax, 0 498 | jne .false 499 | mov eax, [ebp + 8] ; Check other non-letter characters 500 | cmp eax, '(' 501 | je .false 502 | cmp eax, ')' 503 | je .false 504 | cmp eax, '.' 505 | je .false 506 | cmp eax, '-' 507 | je .false 508 | .true: 509 | mov eax, 1 ; return 1 510 | leave 511 | ret 512 | .false: 513 | mov eax, 0 ; return 0 514 | leave 515 | ret 516 | 517 | ; ------------------------------------------------------------------------------ 518 | ; Prints a token to stdout 519 | ; USAGE: _puttoken(, ) 520 | ; = pointer to token to print 521 | ; = the length of the token 522 | ; ------------------------------------------------------------------------------ 523 | _puttoken: 524 | enter 0, 0 525 | push ebx 526 | push esi 527 | mov esi, [ebp + 8] ; ESI <-- 528 | mov ebx, [ebp + 12] ; EBX <-- 529 | cmp ebx, 0 530 | jle .done ; ≤ 0? 531 | .loop: ; Loop through all chars in the token 532 | mov eax, 0 533 | mov al, byte [esi] 534 | cmp al, 0 535 | je .done 536 | push ebx 537 | push esi 538 | push eax 539 | call _putchar 540 | add esp, 4 541 | pop esi 542 | pop ebx 543 | inc esi ; Advance to next char 544 | dec ebx ; One less to print 545 | jnz .loop 546 | .done: 547 | push dword ' ' ; Print single space to separate this 548 | call _putchar ; token from the next 549 | add esp, 4 550 | pop esi 551 | pop ebx 552 | leave 553 | ret 554 | 555 | ; ------------------------------------------------------------------------------ 556 | ; Flushes the output buffer to stdout 557 | ; USAGE: _flush() 558 | ; ------------------------------------------------------------------------------ 559 | _flush: 560 | enter 0, 0 561 | sys.write stdout, outbuf, [outbufind] 562 | mov dword [outbufind], 0 563 | leave 564 | ret 565 | 566 | ; ------------------------------------------------------------------------------ 567 | ; Prints a character to stdout 568 | ; USAGE: _putchar() 569 | ; = the ASCII code of the character to print 570 | ; ------------------------------------------------------------------------------ 571 | _putchar: 572 | enter 0, 0 573 | mov ecx, [outbufind] ; Flush the buffer if it's full 574 | cmp ecx, OUTBUF_SIZE 575 | jb .endif 576 | sys.write stdout, outbuf, OUTBUF_SIZE 577 | mov ecx, 0 578 | .endif: 579 | mov eax, [ebp + 8] ; EAX <-- 580 | mov byte [outbuf + ecx], al ; Add to the output buffer 581 | inc ecx 582 | mov [outbufind], ecx 583 | leave 584 | ret 585 | 586 | ; ------------------------------------------------------------------------------ 587 | ; Converts a string to an integer 588 | ; USAGE: _tointeger(, ) 589 | ; = pointer to string to convert 590 | ; = length of the string to convert 591 | ; RETURNS the integer value of the string 592 | ; ------------------------------------------------------------------------------ 593 | _tointeger: 594 | enter 0, 0 595 | push esi 596 | push ebx 597 | mov eax, 0 598 | mov esi, [ebp + 8] ; ESI <-- 599 | mov ecx, [ebp + 12] ; ECX <-- 600 | mov edx, 0 601 | cmp byte [esi], '-' 602 | je .advance ; Skip over '-' for now 603 | .loop: 604 | mov dl, byte [esi] 605 | sub dl, '0' 606 | jo .done 607 | jc .done 608 | cmp dl, '9' 609 | jg .done ; Break on non-digit 610 | mov ebx, eax 611 | shl eax, 2 612 | add eax, ebx 613 | shl eax, 1 ; EAX <-- EAX * 10 614 | add eax, edx ; EAX <-- EAX + digit 615 | .advance: 616 | inc esi 617 | loop .loop 618 | .done: 619 | mov esi, [ebp + 8] ; ESI <-- 620 | cmp byte [esi], '-' 621 | jne .endif ; Negative number? 622 | neg eax 623 | .endif: 624 | pop ebx 625 | pop esi 626 | leave 627 | ret 628 | 629 | ; ------------------------------------------------------------------------------ 630 | ; Converts a number to a string 631 | ; USAGE: _tostring(, ) 632 | ; = number to convert 633 | ; = buffer to write string to (must be large enough to hold the result) 634 | ; ------------------------------------------------------------------------------ 635 | _tostring: 636 | enter 0, 0 637 | push ebx 638 | push esi 639 | push edi 640 | 641 | mov eax, [ebp + 8] ; EAX <-- 642 | mov edi, [ebp + 12] ; EDI <-- 643 | 644 | cmp eax, 0 645 | je .zero ; == 0? 646 | jl .negative ; < 0? 647 | 648 | .start: 649 | mov ebx, 10 ; We are going to be dividing by 10 650 | mov esi, esp 651 | sub esp, 12 652 | mov ecx, 0 653 | 654 | .loop: 655 | mov edx, 0 ; Sign extend abs(EAX) into EDX for div 656 | div ebx 657 | add edx, '0' 658 | dec esi 659 | mov byte [esi], dl 660 | inc ecx 661 | cmp eax, 0 662 | jne .loop 663 | 664 | cld 665 | rep movsb 666 | add esp, 12 667 | .done: 668 | mov [edi], byte 0 669 | pop edi 670 | pop esi 671 | pop ebx 672 | leave 673 | ret 674 | 675 | .zero: ; Just write a '0' and exit. 676 | mov [edi], byte '0' 677 | inc edi 678 | jmp .done 679 | 680 | .negative: ; Write a '-' and then print -EAX 681 | neg eax 682 | mov [edi], byte '-' 683 | inc edi 684 | jmp .start 685 | 686 | ; ------------------------------------------------------------------------------ 687 | ; Determines the length of a null-terminated string 688 | ; USAGE: _length() 689 | ; = the null-terminated string to compute the length of 690 | ; RETURNS the length of the null-terminated string 691 | ; ------------------------------------------------------------------------------ 692 | _length: 693 | enter 0, 0 694 | push edi 695 | mov edx, [ebp + 8] ; EDX <-- 696 | mov edi, edx 697 | mov ecx, -1 698 | mov eax, 0 699 | cld 700 | .scan: ; Scan for zero 701 | scasb 702 | jnz .scan 703 | dec edi ; Compute string length 704 | mov eax, edi 705 | sub eax, edx 706 | pop edi 707 | leave 708 | ret 709 | 710 | -------------------------------------------------------------------------------- /secd/system-cdecl.inc: -------------------------------------------------------------------------------- 1 | ; vim: filetype=nasm 2 | ; ============================================================================== 3 | ; System calls 4 | ; 5 | ; This version passes parameters on the stack. 6 | ; ============================================================================== 7 | ; 8 | 9 | ; ------------------------------------------------------------------------------ 10 | ; Special file descriptors 11 | ; 12 | %define stdin 0 13 | %define stdout 1 14 | %define stderr 2 15 | 16 | ; ------------------------------------------------------------------------------ 17 | ; System call numbers 18 | ; 19 | %define SYS_exit 1 20 | %define SYS_read 3 21 | %define SYS_write 4 22 | %define SYS_open 5 23 | %define SYS_close 6 24 | 25 | %define O_CREAT 0x00000100 26 | %define O_TRUNC 0x00001000 27 | %define O_RDONLY 0x00000000 28 | %define O_WRONLY 0x00000001 29 | %define O_RDWR 0x00000002 30 | 31 | ; ============================================================================== 32 | ; System call macros 33 | ; 34 | 35 | ; ------------------------------------------------------------------------------ 36 | ; Issues a system call 37 | ; USAGE: system 38 | ; = the number identifying the system call to issue 39 | ; ------------------------------------------------------------------------------ 40 | %macro system 1 41 | mov eax, %1 42 | call __kernel__ 43 | %endmacro 44 | 45 | ; ------------------------------------------------------------------------------ 46 | ; Read from a file 47 | ; USAGE: sys.read , , 48 | ; = the file descriptor to read from 49 | ; = the buffer to read into 50 | ; = the length of the buffer 51 | ; ------------------------------------------------------------------------------ 52 | %macro sys.read 3 53 | push dword 0 54 | push dword %3 55 | push dword %2 56 | push dword %1 57 | system SYS_read 58 | add esp, 16 59 | %endmacro 60 | 61 | ; ------------------------------------------------------------------------------ 62 | ; Writes to a file 63 | ; USAGE: sys.write , , 64 | ; = the file descriptor to write to 65 | ; = the buffer to write from 66 | ; = the number of bytes to write 67 | ; ------------------------------------------------------------------------------ 68 | %macro sys.write 3 69 | push dword %3 70 | push dword %2 71 | push dword %1 72 | system SYS_write 73 | add esp, 12 74 | %endmacro 75 | 76 | ; ------------------------------------------------------------------------------ 77 | ; Opens a file 78 | ; USAGE: sys.open , , 79 | ; = the name of the file to open 80 | ; = the file creation flags 81 | ; = the file access mode 82 | ; ------------------------------------------------------------------------------ 83 | %macro sys.open 3 84 | push dword %3 85 | push dword %2 86 | push dword %1 87 | system SYS_open 88 | add esp, 12 89 | %endmacro 90 | 91 | ; ------------------------------------------------------------------------------ 92 | ; Closes a file 93 | ; USAGE: sys.close 94 | ; = the file descriptor to close 95 | ; ------------------------------------------------------------------------------ 96 | %macro sys.close 1 97 | push dword %1 98 | system SYS_close 99 | add esp, 4 100 | %endmacro 101 | 102 | ; ------------------------------------------------------------------------------ 103 | ; Terminate the process 104 | ; USAGE: sys.exit 105 | ; = the exit code 106 | ; ------------------------------------------------------------------------------ 107 | %macro sys.exit 1 108 | push dword %1 109 | system SYS_exit 110 | add esp, 4 111 | %endmacro 112 | 113 | ; ------------------------------------------------------------------------------ 114 | ; Kernel system call 115 | ; 116 | section .text 117 | align 4 118 | __kernel__: 119 | int 0x80 120 | ret 121 | 122 | -------------------------------------------------------------------------------- /secd/system-fastcall.inc: -------------------------------------------------------------------------------- 1 | ; vim: filetype=nasm 2 | ; ============================================================================== 3 | ; System calls 4 | ; 5 | ; This version passes parameters in registers. 6 | ; ============================================================================== 7 | ; 8 | 9 | ; ------------------------------------------------------------------------------ 10 | ; Special file descriptors 11 | ; 12 | %define stdin 0 13 | %define stdout 1 14 | %define stderr 2 15 | 16 | ; ------------------------------------------------------------------------------ 17 | ; System call numbers 18 | ; 19 | %define SYS_exit 1 20 | %define SYS_read 3 21 | %define SYS_write 4 22 | %define SYS_open 5 23 | %define SYS_close 6 24 | 25 | %define O_CREAT 0q00000100 26 | %define O_TRUNC 0q00001000 27 | %define O_RDONLY 0x00000000 28 | %define O_WRONLY 0x00000001 29 | %define O_RDWR 0x00000002 30 | 31 | ; ============================================================================== 32 | ; System call macros 33 | ; 34 | 35 | ; ------------------------------------------------------------------------------ 36 | ; Issues a system call 37 | ; USAGE: system 38 | ; = the number identifying the system call to issue 39 | ; ------------------------------------------------------------------------------ 40 | %macro system 1 41 | mov eax, %1 42 | call __kernel__ 43 | %endmacro 44 | 45 | ; ------------------------------------------------------------------------------ 46 | ; Read from a file 47 | ; USAGE: sys.read , , 48 | ; = the file descriptor to read from 49 | ; = the buffer to read into 50 | ; = the length of the buffer 51 | ; ------------------------------------------------------------------------------ 52 | %macro sys.read 3 53 | mov edx, %3 54 | mov ecx, %2 55 | mov ebx, %1 56 | system SYS_read 57 | %endmacro 58 | 59 | ; ------------------------------------------------------------------------------ 60 | ; Writes to a file 61 | ; USAGE: sys.write , , 62 | ; = the file descriptor to write to 63 | ; = the buffer to write from 64 | ; = the number of bytes to write 65 | ; ------------------------------------------------------------------------------ 66 | %macro sys.write 3 67 | mov edx, %3 68 | mov ecx, %2 69 | mov ebx, %1 70 | system SYS_write 71 | %endmacro 72 | 73 | ; ------------------------------------------------------------------------------ 74 | ; Opens a file 75 | ; USAGE: sys.open , , 76 | ; = the name of the file to open 77 | ; = the file creation flags 78 | ; = the file access mode 79 | ; ------------------------------------------------------------------------------ 80 | %macro sys.open 3 81 | mov edx, %3 82 | mov ecx, %2 83 | mov ebx, %1 84 | system SYS_open 85 | %endmacro 86 | 87 | ; ------------------------------------------------------------------------------ 88 | ; Closes a file 89 | ; USAGE: sys.close 90 | ; = the file descriptor to close 91 | ; ------------------------------------------------------------------------------ 92 | %macro sys.close 1 93 | mov ebx, %1 94 | system SYS_close 95 | %endmacro 96 | 97 | ; ------------------------------------------------------------------------------ 98 | ; Terminate the process 99 | ; USAGE: sys.exit 100 | ; = the exit code 101 | ; ------------------------------------------------------------------------------ 102 | %macro sys.exit 1 103 | mov ebx, %1 104 | system SYS_exit 105 | %endmacro 106 | 107 | ; ------------------------------------------------------------------------------ 108 | ; Kernel system call 109 | ; 110 | section .text 111 | align 4 112 | __kernel__: 113 | int 0x80 114 | ret 115 | 116 | -------------------------------------------------------------------------------- /secd/system.inc: -------------------------------------------------------------------------------- 1 | ; vim: filetype=nasm 2 | 3 | %include 'system-fastcall.inc' 4 | -------------------------------------------------------------------------------- /util/CallCC.lso: -------------------------------------------------------------------------------- 1 | dnl =========================================================================== 2 | dnl | Call With Current Continuation 3 | dnl | ------------------------------ 4 | dnl | 5 | dnl | Implementation of Scheme's 'call-with-current-continuation' or 'call/cc' 6 | dnl | operator: 7 | dnl | 8 | dnl | http://en.wikipedia.org/wiki/Call-with-current-continuation 9 | dnl | 10 | dnl | CALL/CC is implemented in terms of Landin's [1] 'J-operator' as described 11 | dnl | by Thielecke [2]. 12 | dnl | 13 | dnl | The implementation of the J-operator in this SECD-machine is slightly 14 | dnl | different from the traditional implementation. The result of this 15 | dnl | J-operator is not a function, but a separate entity that requires INVOKEJ 16 | dnl | to be applied to it in order to apply the program closure. To get the 17 | dnl | proper semantics for CALL/CC, we therefore wrap the invocation in a 18 | dnl | lambda expression so that the argument to CALL/CC receives a plain 19 | dnl | function. 20 | dnl | 21 | dnl | [1] P.J. Landin. A generalization of jumps and labels. Report, UNIVAC 22 | dnl | Systems Programming Research, August 1965. 23 | dnl | [2] H. Thielecke. An introduction to Landin's "A generalization of jumps 24 | dnl | and labels". Higher-order and Symbolic Computation / Lisp and 25 | dnl | Symbolic Computation 11(2):117-123, 1998. 26 | dnl | 27 | dnl =========================================================================== 28 | ifdef(`callcc_lso_m4',,`define(`callcc_lso_m4',1)dnl 29 | 30 | dnl ------------------------------------------------------------------------- 31 | dnl | Call-with-current-continuation 32 | dnl | F = A function that takes one argument -- which is the current 33 | dnl | current continuation, also a function taking one argument. When the 34 | dnl | continuation is invoked, CALL/CC will immediately return the value 35 | dnl | passed to the continuation. If the continuation is never invoked, 36 | dnl | CALL/CC will return the result returned by F. 37 | dnl | RETURN The argument passed to the continuation that was passed to F, or 38 | dnl | the result of F if the continuation is never invoked. 39 | dnl ------------------------------------------------------------------------- 40 | (CALL/CC LAMBDA (F) 41 | (LET 42 | (F (LAMBDA (X) ((INVOKEJ RETURN) X))) 43 | (RETURN J (LAMBDA (X) X)))) 44 | 45 | ')dnl 46 | -------------------------------------------------------------------------------- /util/Map.lso: -------------------------------------------------------------------------------- 1 | dnl =========================================================================== 2 | dnl | Map Abstract Data Type 3 | dnl | 4 | dnl | The MAP is a collection of (key . value) pairs. Functions are provided to 5 | dnl | add new entries and to search for entries by their key. 6 | dnl | 7 | dnl | The MAP is organized as a binary search tree. All nodes in the left 8 | dnl | subtree of node M have keys that are less than the key associated with 9 | dnl | node M. All nodes in the right subtree of M have keys which are greater. 10 | dnl | The red-black tree algorith is used to keep the tree relatively balanced. 11 | dnl | See http://en.wikipedia.org/wiki/Red-black_tree for details. 12 | dnl =========================================================================== 13 | ifdef(`map_lso_m4',,`define(`map_lso_m4',1)dnl 14 | 15 | include(Pattern.lso) 16 | include(Util.lso) 17 | 18 | dnl ------------------------------------------------------------------------- 19 | dnl | Creates a new map 20 | dnl | RETURNS an empty map 21 | dnl ------------------------------------------------------------------------- 22 | (NEWMAP LAMBDA NIL 23 | MAPEMPTY) 24 | 25 | dnl ------------------------------------------------------------------------- 26 | dnl | Optimizes the maps internal structure for faster retrieval 27 | dnl | M = the map to balance 28 | dnl | RETURNS the balanced map 29 | dnl ------------------------------------------------------------------------- 30 | (MAPBALANCE LAMBDA (M) 31 | (LETREC 32 | (BALANCE (MAPTOLIST M)) 33 | (BALANCE LAMBDA (L) 34 | (IF (ISNIL L) 35 | (NEWMAP) 36 | (LET 37 | (LET 38 | (LET 39 | (LET 40 | (MAPCONS (CAR PIVOT) (CDR PIVOT) MAPBLACK LM RM) 41 | (LM BALANCE LEFT) 42 | (RM BALANCE RIGHT)) 43 | (PIVOT CAR RIGHTWPIVOT) 44 | (RIGHT CDR RIGHTWPIVOT)) 45 | (LEFT CAR S) 46 | (RIGHTWPIVOT CDR S)) 47 | (S SPLITMID L)))) 48 | (SPLITMID LAMBDA (L) 49 | (SPLIT L (DIV (LENGTH L) 2))))) 50 | 51 | dnl ------------------------------------------------------------------------- 52 | dnl | Puts all of the entries in the specified list into the map. 53 | dnl | M = the map to add entries to 54 | dnl | L = a list of the form ( (k0.v0) (k1.v1) ... (kn.vn) ) of the key-value 55 | dnl | pairs to add to the map 56 | dnl | RETURNS a map with the list of entries added 57 | dnl ------------------------------------------------------------------------- 58 | (MAPPUTALL LAMBDA (M L) 59 | (IF (ISNIL L) 60 | M 61 | (MAPPUTALL (MAPPUT M (CAR (CAR L)) (CDR (CAR L))) (CDR L)))) 62 | 63 | dnl ------------------------------------------------------------------------- 64 | dnl | Computes the height of the tree used to hold the entries in the map 65 | dnl | M = the map to evaluate 66 | dnl | RETURNS the height of the tree representing the map 67 | dnl ------------------------------------------------------------------------- 68 | (MAPDEPTH LAMBDA (M) 69 | (IF (EQ M MAPEMPTY) 70 | 0 71 | (ADD 1 (MAX (MAPDEPTH (MAPLEFT M)) (MAPDEPTH (MAPRIGHT M)))))) 72 | 73 | dnl ------------------------------------------------------------------------- 74 | dnl | Finds all of the entries in the map that match a specified pattern 75 | dnl | M = the map to search 76 | dnl | P = the pattern to match (see the PATTERN function in Pattern.lso for 77 | dnl | details) 78 | dnl | RETURNS a list of all the key-value pairs that match the pattern P 79 | dnl ------------------------------------------------------------------------- 80 | (MAPFINDPATTERN LAMBDA (M P) 81 | (FILTER (LAMBDA (X) (NEQ X (QUOTE F))) 82 | (MAP (LAMBDA (E) (PATTERN E P)) 83 | (MAPTOLIST M)))) 84 | 85 | dnl ------------------------------------------------------------------------- 86 | dnl | Adds an entry to the map 87 | dnl | M = the map 88 | dnl | K = the key 89 | dnl | V = the value 90 | dnl | RETURNS a map with the key value pair (K.V) added 91 | dnl ------------------------------------------------------------------------- 92 | (MAPPUT LAMBDA (M K V) 93 | (LETREC 94 | (MAPSETCOLOR (MAPPUTCC M K V) MAPBLACK) 95 | (MAPPUTCC LAMBDA (M K V) 96 | (IF (EQ M MAPEMPTY) 97 | (MAPCONS K V MAPRED MAPEMPTY MAPEMPTY) 98 | (LET 99 | (IF (EQ CMP 0) 100 | (MAPSUBST M V) 101 | (BALANCE 102 | (IF (LEQ CMP 0) 103 | (MAPCONS 104 | (MAPKEY M) 105 | (MAPVALUE M) 106 | (MAPCOLOR M) 107 | (MAPPUTCC (MAPLEFT M) K V) 108 | (MAPRIGHT M)) 109 | (MAPCONS 110 | (MAPKEY M) 111 | (MAPVALUE M) 112 | (MAPCOLOR M) 113 | (MAPLEFT M) 114 | (MAPPUTCC (MAPRIGHT M) K V))))) 115 | (CMP DEEPCMP K (MAPKEY M))))) 116 | (REBUILD LAMBDA (A XK XV B YK YV C ZK ZV D) 117 | (MAPCONS YK YV MAPRED 118 | (MAPCONS XK XV MAPBLACK A B) 119 | (MAPCONS ZK ZV MAPBLACK C D))) 120 | (BALANCE LAMBDA (M) 121 | (MATCH M 122 | (CASE (((_ _ _ _ . RED) _ _ _ . RED) _ _ _ . BLACK) (APPLY REBUILD _0)) 123 | (CASE ((_ _ _ (_ _ _ _ . RED) . RED) _ _ _ . BLACK) (APPLY REBUILD _0)) 124 | (CASE (_ _ _ ((_ _ _ _ . RED) _ _ _ . RED) . BLACK) (APPLY REBUILD _0)) 125 | (CASE (_ _ _ (_ _ _ (_ _ _ _ . RED) . RED) . BLACK) (APPLY REBUILD _0)) 126 | (CASE _ _1))))) 127 | 128 | dnl ------------------------------------------------------------------------- 129 | dnl | Gets the value associated with the given key 130 | dnl | M = the map to search 131 | dnl | K = the key to search for 132 | dnl | RETURNS the value associated with the key, or NIL if the key is not 133 | dnl | found 134 | dnl ------------------------------------------------------------------------- 135 | (MAPGET LAMBDA (M K) 136 | (IF (EQ M MAPEMPTY) 137 | (QUOTE NIL) 138 | (LET 139 | (IF (EQ CMP 0) 140 | (MAPVALUE M) 141 | (IF (LEQ CMP 0) 142 | (MAPGET (MAPLEFT M) K) 143 | (MAPGET (MAPRIGHT M) K))) 144 | (CMP DEEPCMP K (MAPKEY M))))) 145 | 146 | dnl ------------------------------------------------------------------------- 147 | dnl | Gets a list of all of the entries in the map 148 | dnl | M = the map 149 | dnl | RETURNS a list of the key-value pairs in the map 150 | dnl ------------------------------------------------------------------------- 151 | (MAPTOLIST LAMBDA (M) 152 | (LETREC 153 | (MAPTOLISTCC M (QUOTE NIL)) 154 | (MAPTOLISTCC LAMBDA (M CC) 155 | (IF (EQ M MAPEMPTY) 156 | CC 157 | (MAPTOLISTCC (MAPLEFT M) 158 | (CONS (CONS (MAPKEY M) (MAPVALUE M)) (MAPTOLISTCC (MAPRIGHT M) CC))))))) 159 | 160 | dnl ------------------------------------------------------------------------- 161 | dnl | Creates a new map using the entries in the provided list. Each entry 162 | dnl | must be a pair of the form ( . ). 163 | dnl | L = the list of entries 164 | dnl | RETURNS a new map containing the entries from L 165 | dnl ------------------------------------------------------------------------- 166 | (MAPFROMLIST LAMBDA (L) 167 | (MAPPUTALL (NEWMAP) L)) 168 | 169 | 170 | 171 | dnl ========================================================================= 172 | dnl | Private functions 173 | dnl ========================================================================= 174 | 175 | (MAPEMPTY QUOTE NIL) dnl --- The empty map 176 | (MAPBLACK QUOTE BLACK) dnl --- A symbol denoting a black node 177 | (MAPRED QUOTE RED) dnl --- A symbol denoting a red node 178 | 179 | dnl ------------------------------------------------------------------------- 180 | dnl | Gets the left child of the specified map node 181 | dnl | M = the map node 182 | dnl | RETURNS the left child of the node 183 | dnl ------------------------------------------------------------------------- 184 | (MAPLEFT LAMBDA (M) 185 | (FIRST M)) 186 | 187 | dnl ------------------------------------------------------------------------- 188 | dnl | Gets the key stored at the given map node 189 | dnl | M = the map node 190 | dnl | RETURNS the key stored at the map node 191 | dnl ------------------------------------------------------------------------- 192 | (MAPKEY LAMBDA (M) 193 | (SECOND M)) 194 | 195 | dnl ------------------------------------------------------------------------- 196 | dnl | Gets the value stored at the given map node 197 | dnl | M = the map node 198 | dnl | RETURNS the value stored at the map node 199 | dnl ------------------------------------------------------------------------- 200 | (MAPVALUE LAMBDA (M) 201 | (THIRD M)) 202 | 203 | dnl ------------------------------------------------------------------------- 204 | dnl | Gets the right child of the specified map node 205 | dnl | M = the map node 206 | dnl | RETURNS the right child of the node 207 | dnl ------------------------------------------------------------------------- 208 | (MAPRIGHT LAMBDA (M) 209 | (FOURTH M)) 210 | 211 | dnl ------------------------------------------------------------------------- 212 | dnl | Gets the color of the specified map node (see 213 | dnl | http://en.wikipedia.org/wiki/Red-black_tree) 214 | dnl | M = the map node 215 | dnl | RETURNS the color associated with the node 216 | dnl ------------------------------------------------------------------------- 217 | (MAPCOLOR LAMBDA (M) 218 | (CDR (CDR (CDR (CDR M))))) 219 | 220 | dnl ------------------------------------------------------------------------- 221 | dnl | Creates a new map node 222 | dnl | K = the key for the new map node 223 | dnl | V = the value associated with the key 224 | dnl | C = the color of the new map node 225 | dnl | L = the left child of the new node 226 | dnl | R = the right child of the new node 227 | dnl ------------------------------------------------------------------------- 228 | (MAPCONS LAMBDA (K V C L R) 229 | (CONS L (CONS K (CONS V (CONS R C))))) 230 | 231 | dnl ------------------------------------------------------------------------- 232 | dnl | Creates a new node identical to the specified node except with a 233 | dnl | different value associated with it 234 | dnl | M = the map node 235 | dnl | V = the new value 236 | dnl | RETURNS the new node with the value substituted 237 | dnl ------------------------------------------------------------------------- 238 | (MAPSUBST LAMBDA (M V) 239 | (MAPCONS (MAPKEY M) V (MAPCOLOR M) (MAPLEFT M) (MAPRIGHT M))) 240 | 241 | dnl ------------------------------------------------------------------------- 242 | dnl | Creates a new node identical to the specified node except with a 243 | dnl | different color 244 | dnl | M = the map node 245 | dnl | C = the new color 246 | dnl | RETURNS the new node with the color substituted 247 | dnl ------------------------------------------------------------------------- 248 | (MAPSETCOLOR LAMBDA (M C) 249 | (LET 250 | (IF (EQ C COLOR) 251 | M 252 | (MAPCONS (MAPKEY M) (MAPVALUE M) C (MAPLEFT M) (MAPRIGHT M))) 253 | (COLOR MAPCOLOR M))) 254 | 255 | ')dnl 256 | -------------------------------------------------------------------------------- /util/Parser.lso: -------------------------------------------------------------------------------- 1 | dnl =========================================================================== 2 | dnl | Parser combinators 3 | dnl | ------------------ 4 | dnl | 5 | dnl | This parser combinator implementation is based on the Scala parser 6 | dnl | combinators: 7 | dnl | 8 | dnl | http://www.scala-lang.org/api/current/scala/util/parsing/combinator/Parsers.html 9 | dnl | http://www.scala-lang.org/api/current/scala/util/parsing/combinator/Parsers$Parser.html 10 | dnl | 11 | dnl | Implementation is discussed in: 12 | dnl | 13 | dnl | Chapter 33, "Combinator Parsing", in 14 | dnl | M. Odersky, L. Spoon, B. Venners, "Programming in Scala, Second Edition", 15 | dnl | 2010, Artima Press, Walnut Creek, CA 16 | dnl | 17 | dnl =========================================================================== 18 | ifdef(`parser_lso_m4',,`define(`parser_lso_m4',1)dnl 19 | 20 | include(Pattern.lso) 21 | include(Util.lso) 22 | include(CallCC.lso) 23 | 24 | dnl ========================================================================= 25 | dnl | A "parser" is a function: 26 | dnl | 27 | dnl | (LAMBDA (IN CC) ...) 28 | dnl | 29 | dnl | where: 30 | dnl | 31 | dnl | IN = a stream of input tokens 32 | dnl | CC = a continuation function (LAMBDA (RESULT IN) ...) to be called on 33 | dnl | successful matching with the results of the parsing and the 34 | dnl | remainder of the input 35 | dnl | 36 | dnl | RETURNS (CC IN) if parsing succeeds, 37 | dnl | ( . IN) if parsing fails 38 | dnl ========================================================================= 39 | 40 | dnl ------------------------------------------------------------------------- 41 | dnl | Creates a parser that always succeeds 42 | dnl | X = the result for the parser 43 | dnl ------------------------------------------------------------------------- 44 | (PARSE_SUCC LAMBDA (X) 45 | (LAMBDA (IN CC) (CC X IN))) 46 | 47 | dnl ------------------------------------------------------------------------- 48 | dnl | Creates a parser that always fails 49 | dnl | MSG = The failure message 50 | dnl ------------------------------------------------------------------------- 51 | (PARSE_FAIL LAMBDA (MSG) 52 | (LAMBDA (IN CC) (CONS MSG IN))) 53 | 54 | dnl ------------------------------------------------------------------------- 55 | dnl | Creates a parser from a lazily evaluated underlying parser. This allows 56 | dnl | recursive parsers to be defined. (PARSE_REC P) matches the same input 57 | dnl | as P and returns the same results and failure messages as P. 58 | dnl | P = a function taking no parameters (LAMBDA NIL ...) that returns a 59 | dnl | parser 60 | dnl ------------------------------------------------------------------------- 61 | (PARSE_REC LAMBDA (P) 62 | (LAMBDA (IN CC) ((P) IN CC))) 63 | 64 | dnl ------------------------------------------------------------------------- 65 | dnl | Creates a parser that matches input that satisfies a predicate 66 | dnl | KIND = the element kind, used for error messages 67 | dnl | P = the predicate that determines which elements to match 68 | dnl ------------------------------------------------------------------------- 69 | (PARSE_ELEM LAMBDA (KIND P) 70 | (LAMBDA (IN CC) 71 | (IF (P (CAR IN)) 72 | (CC (CAR IN) (CDR IN)) 73 | (LIST (QUOTE EXPECTED) KIND)))) 74 | 75 | dnl ------------------------------------------------------------------------- 76 | dnl | Creates a parser that matches the specified token only 77 | dnl | TOKEN = the token to match 78 | dnl ------------------------------------------------------------------------- 79 | (PARSE_TOKEN LAMBDA (TOKEN) 80 | (PARSE_ELEM TOKEN (LAMBDA (X) (EQ X TOKEN)))) 81 | 82 | dnl ------------------------------------------------------------------------- 83 | dnl | A parser that transforms the result from another parser. 84 | dnl | (PARSE_MAP P F) succeeds only if P succeeds. The result of the parser 85 | dnl | is (F X), where X is the result from P. 86 | dnl | P = the underlying parser 87 | dnl | F = the transformation to apply to the result 88 | dnl ------------------------------------------------------------------------- 89 | (PARSE_MAP LAMBDA (P F) 90 | (LAMBDA (IN CC) 91 | (P IN (LAMBDA (PR OUT) (CC (F PR) OUT))))) 92 | 93 | dnl ------------------------------------------------------------------------- 94 | dnl | A parser that returns a constant value if the provided underlying parser 95 | dnl | succeeds. (PARSE_TO P RESULT) succeeds only if P succeeds. The result 96 | dnl | of the parser is RESULT. 97 | dnl | P = the underlying parser 98 | dnl | RESULT = the result of the parser if P succeeds 99 | dnl ------------------------------------------------------------------------- 100 | (PARSE_TO LAMBDA (P RESULT) 101 | (PARSE_MAP P (LAMBDA (X) RESULT))) 102 | 103 | dnl ------------------------------------------------------------------------- 104 | dnl | A parser combinator for sequential composition. (PARSE_CONS P Q) 105 | dnl | succeeds only if P succeeds and Q succeeds on the input left over by P. 106 | dnl | P = the left parser 107 | dnl | Q = the right parser 108 | dnl ------------------------------------------------------------------------- 109 | (PARSE_CONS LAMBDA (P Q) 110 | (LAMBDA (IN CC) 111 | (P IN (LAMBDA (PR QIN) (Q QIN 112 | (LAMBDA (QR OUT) 113 | (CC (CONS PR QR) OUT))))))) 114 | 115 | dnl ------------------------------------------------------------------------- 116 | dnl | A parser combinator for sequential composition which keeps only the left 117 | dnl | result. (PARSE_CONS_L P Q) succeeds only if P succeeds and Q succeeds 118 | dnl | on the input left over by P. 119 | dnl | P = the left parser 120 | dnl | Q = the right parser 121 | dnl ------------------------------------------------------------------------- 122 | (PARSE_CONS_L LAMBDA (P Q) 123 | (PARSE_MAP (PARSE_CONS P Q) (LAMBDA (X) (CAR X)))) 124 | 125 | dnl ------------------------------------------------------------------------- 126 | dnl | A parser combinator for sequential composition which keeps only the 127 | dnl | right result. (PARSE_CONS_R P Q) succeeds only if P succeeds and Q 128 | dnl | succeeds on the input left over by P. 129 | dnl | P = the left parser 130 | dnl | Q = the right parser 131 | dnl ------------------------------------------------------------------------- 132 | (PARSE_CONS_R LAMBDA (P Q) 133 | (LAMBDA (IN CC) (P IN (LAMBDA (PR POUT) (Q POUT CC))))) 134 | 135 | dnl ------------------------------------------------------------------------- 136 | dnl | A parser combinator for sequential composition which keeps only the 137 | dnl | middle result. (PARSE_DELIM OPEN P CLOSE) succeeds only if OPEN 138 | dnl | succeeds, then P succeeds on the input left over by OPEN, then CLOSE 139 | dnl | succeeds on the input left over by OPEN and P. On success, the result 140 | dnl | is the result from P. On failure, the result is the failure message 141 | dnl | from CLOSE. 142 | dnl | OPEN = the parser for the opening delimiter 143 | dnl | P = the parser for the body of the delimited input 144 | dnl | CLOSE = the parser for the closing delimiter 145 | dnl ------------------------------------------------------------------------- 146 | (PARSE_DELIM LAMBDA (OPEN P CLOSE) 147 | (PARSE_CONS_R OPEN (PARSE_CONS_L P CLOSE))) 148 | 149 | dnl ------------------------------------------------------------------------- 150 | dnl | A parser combinator for alternative composition. (PARSE_OR P Q) 151 | dnl | succeeds if either P or Q succeeds. The result is that of P if P 152 | dnl | succeeds, or of Q if P fails and Q succeeds. If P and Q both fail, the 153 | dnl | failure message from Q is returned. 154 | dnl | P = the parser for the first alternative 155 | dnl | Q = the parser for the second alternative 156 | dnl ------------------------------------------------------------------------- 157 | (PARSE_OR LAMBDA (P Q) 158 | (LAMBDA (IN C) 159 | (CALL/CC 160 | (LAMBDA (CC) 161 | (BEGIN 162 | (P IN (LAMBDA (RESULT OUT) (CC (C RESULT OUT)))) 163 | (Q IN (LAMBDA (RESULT OUT) (C RESULT OUT)))))))) 164 | 165 | dnl ------------------------------------------------------------------------- 166 | dnl | A parser combinator for sequential composition. 167 | dnl | (PARSE_SEQ (LIST P1 ... Pn)) succeeds if P1 succeeds and if Pj succeeds, 168 | dnl | for all 1 < j <= n, on the input left over from P1 ... P(j-1). The 169 | dnl | result is (LIST R1 ... Rn), where Rj is the result from Pj. 170 | dnl | PS = the list of parsers to combine sequentially 171 | dnl ------------------------------------------------------------------------- 172 | (PARSE_SEQ LAMBDA (PS) 173 | (IF (ISNIL PS) 174 | (PARSE_SUCC (QUOTE NIL)) 175 | (PARSE_CONS (CAR PS) (PARSE_SEQ (CDR PS))))) 176 | 177 | dnl ------------------------------------------------------------------------- 178 | dnl | A parser combinator for alternative composition. 179 | dnl | (PARSE_SEQ (LIST P1 ... Pn)) succeeds if Pj succeeds for any 180 | dnl | 1 <= j <= n. The result is the result of Pk, where Pk has succeeded, 181 | dnl | and Pi has failed for 1 <= i < k. If all alternatives fail, the 182 | dnl | provided failure message is returned. 183 | dnl | MSG = the failure message 184 | dnl | PS = the list of parsers for the alternatives 185 | dnl ------------------------------------------------------------------------- 186 | (PARSE_ANY LAMBDA (MSG PS) 187 | (IF (ISNIL PS) 188 | (PARSE_FAIL MSG) 189 | (PARSE_OR (CAR PS) (PARSE_ANY MSG (CDR PS))))) 190 | 191 | dnl ------------------------------------------------------------------------- 192 | dnl | Creates a parser that optionally parses whatever P parses. 193 | dnl | (PARSE_OPT P) always succeeds. If P succeeds, the result is the list 194 | dnl | containing the result from P. If P fails, the result is the empty list. 195 | dnl | P = the underlying parser 196 | dnl ------------------------------------------------------------------------- 197 | (PARSE_OPT LAMBDA (P) 198 | (PARSE_OR 199 | (PARSE_MAP P (LAMBDA (X) (CONS X (QUOTE NIL)))) 200 | (PARSE_SUCC (QUOTE NIL)))) 201 | 202 | dnl ------------------------------------------------------------------------- 203 | dnl | Creates a parser that repeatedly parses whatever P parses. 204 | dnl | (PARSE_REP P) always succeeds. The result is the list containing the 205 | dnl | results from P ending when P fails. 206 | dnl | P = the underlying parser 207 | dnl ------------------------------------------------------------------------- 208 | (PARSE_REP LAMBDA (P) 209 | (PARSE_OR 210 | (PARSE_CONS P (PARSE_REC (LAMBDA NIL (PARSE_REP P)))) 211 | (PARSE_SUCC (QUOTE NIL)))) 212 | 213 | dnl ------------------------------------------------------------------------- 214 | dnl | Creates a parser that repeatedly parses whatever P parses. P must 215 | dnl | succeed at least once. The result is the list containing the results 216 | dnl | from P ending when P fails. 217 | dnl | P = the underlying parser 218 | dnl ------------------------------------------------------------------------- 219 | (PARSE_REP1 LAMBDA (P) 220 | (PARSE_CONS P (PARSE_REP P))) 221 | 222 | dnl ------------------------------------------------------------------------- 223 | dnl | Creates a parser that repeatedly parses what P parses interleaved with 224 | dnl | SEP. P must succeed at least once. The result is the list containing 225 | dnl | the results from P, ending when either P or SEP fails. 226 | dnl | P = the parser to match the list elements 227 | dnl | SEP = the parser to match the list element separator 228 | dnl ------------------------------------------------------------------------- 229 | (PARSE_REP1SEP LAMBDA (P SEP) 230 | (PARSE_CONS P (PARSE_REP (PARSE_CONS_R SEP P)))) 231 | 232 | dnl ------------------------------------------------------------------------- 233 | dnl | Creates a parser that repeatedly parses what P parses interleaved with 234 | dnl | SEP. (PARSE_REPSEP P SEP) always succeeds. The result is the list 235 | dnl | containing the results from P, ending when either P or SEP fails. 236 | dnl | P = the parser to match the list elements 237 | dnl | SEP = the parser to match the list element separator 238 | dnl ------------------------------------------------------------------------- 239 | (PARSE_REPSEP LAMBDA (P SEP) 240 | (PARSE_OR 241 | (PARSE_REP1SEP P SEP) 242 | (PARSE_SUCC (QUOTE NIL)))) 243 | 244 | dnl ------------------------------------------------------------------------- 245 | dnl | Creates a parser that repeatedly parses what P parses interleaved with 246 | dnl | OPER. P must succeed at least once. OPER must return a function having 247 | dnl | two parameters. The result is the results from P, ending when either P 248 | dnl | or OPER fails, reduced from left to right using the results from OPER. 249 | dnl | P = the parser to match the list elements, and returning operands to the 250 | dnl | binary operator returned by OPER 251 | dnl | OPER = the parser to match the list element separator, and returning a 252 | dnl | binary function (LAMBDA (X Y) ...) to apply to the operands 253 | dnl | returned by P. 254 | dnl ------------------------------------------------------------------------- 255 | (PARSE_CHAIN_L1 LAMBDA (P OPER) 256 | (LETREC 257 | (PARSE_MAP 258 | (PARSE_CONS P (PARSE_REP (PARSE_CONS OPER P))) 259 | COMBINE) 260 | (COMBINE LAMBDA (L) 261 | (IF (ISNIL (CDR L)) 262 | (CAR L) 263 | (LET 264 | (COMBINE (CONS (OP A B) REST)) 265 | (A CAR L) 266 | (OP CAR (CAR (CDR L))) 267 | (B CDR (CAR (CDR L))) 268 | (REST CDR (CDR L))))))) 269 | 270 | ')dnl 271 | -------------------------------------------------------------------------------- /util/Pattern.lso: -------------------------------------------------------------------------------- 1 | dnl =========================================================================== 2 | dnl | Pattern matching 3 | dnl =========================================================================== 4 | ifdef(`pattern_lso_m4',,`define(`pattern_lso_m4',1)dnl 5 | 6 | include(Util.lso) 7 | 8 | dnl ------------------------------------------------------------------------- 9 | dnl | Determines if X matches the specified pattern and optionally extracts 10 | dnl | matching elements into a list. 11 | dnl | 12 | dnl | A number or symbol in the pattern must match the corresponding number 13 | dnl | or symbol in X. A cons cell in the pattern must match a cons cell in 14 | dnl | X, and the car and the cdr of the cons cell must match the car and cdr 15 | dnl | of the corresponding cell in X. Note that, since a list is built from 16 | dnl | cons cells, this means that a list of n elements in the pattern must 17 | dnl | match a list of n elements in X, and corresponding elements of the list 18 | dnl | and of the pattern must match. 19 | dnl | 20 | dnl | The following symbols act as wildcards in the pattern: 21 | dnl | 22 | dnl | * - Matches any object (atomic value or cons cell). 23 | dnl | _ - Matches any object and specifies that the matching object be 24 | dnl | extracted 25 | dnl | !* - Matches any atom (symbol or number) 26 | dnl | !_ - Matches any atom and specifies that it be extracted 27 | dnl | #* - Matches a number 28 | dnl | #_ - Matches and extracts a number 29 | dnl | @* - Matches a symbol 30 | dnl | @_ - Matches and extracts a symbol 31 | dnl | 32 | dnl | The pattern "(\ )" matches only against an exact copy of . This 33 | dnl | can be used when one wants to match a symbol that is normally 34 | dnl | interpreted as a wildcard. For example, "(\ *)" in the pattern will 35 | dnl | match the "*" symbol. To match the backslash, use the pattern "(\ \)". 36 | dnl | 37 | dnl | X = the object to match 38 | dnl | P = the pattern 39 | dnl | RETURNS a list of elements extracted from X, if X matches the pattern P, 40 | dnl | or the boolean value "F" if X does not match P. Note that if 41 | dnl | X matches P but the pattern P did not specify any elements to 42 | dnl | be extracted, the return value will be NIL. 43 | dnl ------------------------------------------------------------------------- 44 | (PATTERN LAMBDA (X P) 45 | (LETREC 46 | (LET 47 | (IF (EQ RESULT (QUOTE F)) 48 | (QUOTE F) 49 | (REVERSE RESULT)) 50 | (RESULT PATTERNCC X P (QUOTE NIL))) 51 | (REVERSE LAMBDA (X) 52 | (REVERSECC X (QUOTE NIL))) 53 | (REVERSECC LAMBDA (X CC) 54 | (IF (EQ X (QUOTE NIL)) 55 | CC 56 | (REVERSECC (CDR X) (CONS (CAR X) CC)))) 57 | (PATTERNCC LAMBDA (X P CC) 58 | (IF (EQ P (QUOTE _)) 59 | (CONS X CC) 60 | (IF (EQ P (QUOTE *)) 61 | CC 62 | (IF (EQ P (QUOTE !*)) 63 | (IF (ATOM X) 64 | CC 65 | (QUOTE F)) 66 | (IF (EQ P (QUOTE !_)) 67 | (IF (ATOM X) 68 | (CONS X CC) 69 | (QUOTE F)) 70 | (IF (EQ P (QUOTE #*)) 71 | (IF (NUMBER X) 72 | CC 73 | (QUOTE F)) 74 | (IF (EQ P (QUOTE #_)) 75 | (IF (NUMBER X) 76 | (CONS X CC) 77 | (QUOTE F)) 78 | (IF (EQ P (QUOTE @*)) 79 | (IF (SYMBOL X) 80 | CC 81 | (QUOTE F)) 82 | (IF (EQ P (QUOTE @_)) 83 | (IF (SYMBOL X) 84 | (CONS X CC) 85 | (QUOTE F)) 86 | (IF (ATOM P) 87 | (IF (EQ X P) 88 | CC 89 | (QUOTE F)) 90 | (IF (EQ (CAR P) (QUOTE \)) 91 | (IF (DEEPEQ X (CAR (CDR P))) 92 | CC 93 | (QUOTE F)) 94 | (IF (ATOM X) 95 | (QUOTE F) 96 | (LET 97 | (IF (EQ SUBRESULT (QUOTE F)) 98 | (QUOTE F) 99 | (PATTERNCC (CDR X) (CDR P) SUBRESULT)) 100 | (SUBRESULT PATTERNCC (CAR X) (CAR P) CC)))))))))))))))) 101 | 102 | dnl ------------------------------------------------------------------------- 103 | dnl | Matches X against a list of patterns and evaluates the corresponding 104 | dnl | function against the extracted elements. 105 | dnl | 106 | dnl | X = the object to match 107 | dnl | CASES = A list of lists having the following form: 108 | dnl | (PATTERN PREDICATE FUNCTION) 109 | dnl | where PATTERN is a pattern as described by the (PATTERN) 110 | dnl | function above, and PREDICATE and FUNCTION are functions taking 111 | dnl | a number of arguments equal to the number of elements extracted 112 | dnl | by PATTERN. If PATTERN matches X, the extracted elements will 113 | dnl | be passed to PREDICATE (if present). For the first entry in 114 | dnl | CASES for which PATTERN matches and PREDICATE evaluates to true, 115 | dnl | the extracted elements will be passed to the corresponding 116 | dnl | FUNCTION as its arguments. 117 | dnl | RETURNS the result of from the function corresponding to the first 118 | dnl | matching pattern in CASES for which PREDICATE evaluates to true, 119 | dnl | applied to the extracted elements, or (QUOTE NOMATCH) if no 120 | dnl | pattern in CASES match X. 121 | dnl ------------------------------------------------------------------------- 122 | (_MATCH LAMBDA (X CASES) 123 | (IF (ISNIL CASES) 124 | (QUOTE NOMATCH) 125 | (LET 126 | (LET 127 | (LET 128 | (IF (EQ ARGS (QUOTE F)) 129 | (_MATCH X (CDR CASES)) 130 | (LET 131 | (IF (APPLY P ARGS) 132 | (APPLY F ARGS) 133 | (_MATCH X (CDR CASES))) 134 | (P CAR (CDR CASE)) 135 | (F CAR (CDR (CDR CASE))))) 136 | (ARGS PATTERN X PAT)) 137 | (PAT CAR CASE)) 138 | (CASE CAR CASES)))) 139 | 140 | (MATCH MACRO (X . CASES) 141 | (_MATCH X (LIST . CASES))) 142 | 143 | (CASE?* MACRO (ARGS PAT P F) 144 | (LIST (QUOTE PAT) 145 | (LAMBDA _0 146 | (LET 147 | (APPLY P* _0) 148 | (P* LAMBDA ARGS P))) 149 | (LAMBDA _0 150 | (LET 151 | (APPLY F* _0) 152 | (F* LAMBDA ARGS F))))) 153 | 154 | (CASE*? MACRO (ARGS PAT P F) (CASE?* ARGS PAT P F)) 155 | (CASE* MACRO (ARGS PAT F) (CASE*? ARGS PAT (QUOTE T) F)) 156 | (CASE? MACRO (PAT P F) (CASE?* (_1 _2 _3 _4 _5 _6 _7 _8 _9) PAT P F)) 157 | (CASE MACRO (PAT F) (CASE? PAT (QUOTE T) F)) 158 | 159 | ')dnl 160 | -------------------------------------------------------------------------------- /util/README.md: -------------------------------------------------------------------------------- 1 | Utilities 2 | ========= 3 | 4 | This directory contains LispKit Lisp include files with generally useful 5 | functions. 6 | 7 | - Util.lso: general purpose functions 8 | - Pattern.lso: Pattern matching 9 | - Map.lso: A map abstract data type (stores key/value pairs) 10 | - Set.lso: A set abstract data type 11 | - Cfg.lso: Functions for handling context free grammars. 12 | 13 | -------------------------------------------------------------------------------- /util/Set.lso: -------------------------------------------------------------------------------- 1 | dnl =========================================================================== 2 | dnl | Set Abstract Data Type 3 | dnl | 4 | dnl | Implemented as a MAP using the elements as keys and storing boolean values 5 | dnl | (either T to indicate that the set contains that element, or F to indicate 6 | dnl | that it has been deleted). 7 | dnl =========================================================================== 8 | ifdef(`set_lso_m4',,`define(`set_lso_m4',1)dnl 9 | 10 | include(Map.lso) 11 | 12 | dnl ------------------------------------------------------------------------- 13 | dnl | Creates a new set 14 | dnl | RETURNS a new set 15 | dnl ------------------------------------------------------------------------- 16 | (NEWSET LAMBDA NIL 17 | (NEWMAP)) 18 | 19 | dnl ------------------------------------------------------------------------- 20 | dnl | Adds a new element to the set 21 | dnl | S = the set to add to 22 | dnl | E = the element to add to the set 23 | dnl | RETURNS the set S union {E} 24 | dnl ------------------------------------------------------------------------- 25 | (SETPUT LAMBDA (S E) 26 | (MAPPUT S E (QUOTE T))) 27 | 28 | dnl ------------------------------------------------------------------------- 29 | dnl | Adds all of the items in the specified list to the set 30 | dnl | S = the set to add to 31 | dnl | L = the list of items to add 32 | dnl | RETURNS the set S union {a0,a1,...,an}, where L is the list 33 | dnl | (a0 a1 ... an) 34 | dnl ------------------------------------------------------------------------- 35 | (SETPUTALL LAMBDA (S L) 36 | (IF (ISNIL L) 37 | S 38 | (SETPUTALL (SETPUT S (CAR L)) (CDR L)))) 39 | 40 | dnl ------------------------------------------------------------------------- 41 | dnl | Removes the speicifed item from the set 42 | dnl | S = the set to remove from 43 | dnl | E = the element to remove 44 | dnl | RETURNS the set S \ {E} 45 | dnl ------------------------------------------------------------------------- 46 | (SETDEL LAMBDA (S E) 47 | (MAPPUT S E (QUOTE F))) 48 | 49 | dnl ------------------------------------------------------------------------- 50 | dnl | Determines if the set contains the specified element 51 | dnl | S = the set to check 52 | dnl | E = the element to search for 53 | dnl | RETURNS T if S contains E, F otherwise 54 | dnl ------------------------------------------------------------------------- 55 | (SETCONTAINS LAMBDA (S E) 56 | (EQ (MAPGET S E) (QUOTE T))) 57 | 58 | dnl ------------------------------------------------------------------------- 59 | dnl | Gets a list of elements in the set 60 | dnl | S = the set 61 | dnl | RETURNS a list of elements of the set 62 | dnl ------------------------------------------------------------------------- 63 | (SETTOLIST LAMBDA (S) 64 | (MAP (LAMBDA (X) (CAR X)) (FILTER (LAMBDA (X) (CDR X)) (MAPTOLIST S)))) 65 | 66 | dnl ------------------------------------------------------------------------- 67 | dnl | Gets a set of all elements in the provided list 68 | dnl | L = the list 69 | dnl | RETURNS the set containing all of the elements of L 70 | dnl ------------------------------------------------------------------------- 71 | (SETFROMLIST LAMBDA (L) 72 | (SETPUTALL (NEWSET) L)) 73 | 74 | dnl ------------------------------------------------------------------------- 75 | dnl | Computes the union of two sets 76 | dnl | A = the first set 77 | dnl | B = the second set 78 | dnl | RETURNS a set containing all elements which are in A or in B 79 | dnl ------------------------------------------------------------------------- 80 | (SETUNION LAMBDA (A B) 81 | (SETPUTALL A (SETTOLIST B))) 82 | 83 | dnl ------------------------------------------------------------------------- 84 | dnl | Computes the intersection of two sets 85 | dnl | A = the first set 86 | dnl | B = the second set 87 | dnl | RETURNS a set containing all elements which are in A and in B 88 | dnl ------------------------------------------------------------------------- 89 | (SETINTERSECT LAMBDA (A B) 90 | (SETFROMLIST 91 | (FILTER 92 | (LAMBDA (E) (SETCONTAINS B E)) 93 | (SETTOLIST A)))) 94 | 95 | ')dnl 96 | -------------------------------------------------------------------------------- /util/StdIn.lso: -------------------------------------------------------------------------------- 1 | dnl --- Standard input stream --- 2 | ifdef(`stdin_lso_m4',,`define(`stdin_lso_m4',1)dnl 3 | 4 | (STDIN LAMBDA NIL 5 | (LETREC 6 | (DELAY (IN)) 7 | (IN LAMBDA NIL 8 | (LET 9 | (IF (LEQ X -1) 10 | (QUOTE NIL) 11 | (CONS X (DELAY (IN)))) 12 | (X GET))))) 13 | 14 | ')dnl 15 | -------------------------------------------------------------------------------- /util/Stream.lso: -------------------------------------------------------------------------------- 1 | dnl --- Utility functions --- 2 | ifdef(`stream_lso_m4',,`define(`stream_lso_m4',1)dnl 3 | 4 | (FORCE* LAMBDA (S) 5 | (IF (RECIPE S) (FORCE* (FORCE S)) S)) 6 | 7 | (FOREVER LAMBDA (X) 8 | (LETREC 9 | (FORCE (CDR S)) 10 | (S CONS X (DELAY S)))) 11 | 12 | (SFLATTEN LAMBDA (S) 13 | (IF (SISNIL S) 14 | (QUOTE NIL) 15 | (SAPPEND (FORCE* (CAR S)) (DELAY (SFLATTEN (CDR S)))))) 16 | 17 | (SISNIL LAMBDA (S) 18 | (EQ (FORCE* S) (QUOTE NIL))) 19 | 20 | dnl ------------------------------------------------------------------------- 21 | dnl | Appends two streams 22 | dnl | A = the first stream 23 | dnl | B = the second stream 24 | dnl | RETURNS a stream consisting of all of the elements of A, followed by all 25 | dnl | of the elements of B 26 | dnl ------------------------------------------------------------------------- 27 | (SAPPEND LAMBDA (A B) 28 | (IF (SISNIL A) 29 | (FORCE* B) 30 | (CONS (FORCE* (CAR A)) (DELAY (SAPPEND (CDR A) B))))) 31 | 32 | (STOLIST LAMBDA (S) 33 | (IF (SISNIL S) 34 | (QUOTE NIL) 35 | (CONS (FORCE* (CAR S)) (STOLIST (CDR S))))) 36 | 37 | dnl ------------------------------------------------------------------------- 38 | dnl | Applies a function to all elements in a list 39 | dnl | F = the function to apply 40 | dnl | L = the list elements on which to apply F 41 | dnl | RESULT the list ((F a0) (F a1) ... (F an)), where L = (a0 a1 ... an) 42 | dnl ------------------------------------------------------------------------- 43 | (SMAP LAMBDA (F S) 44 | (IF (SISNIL S) 45 | (QUOTE NIL) 46 | (CONS (FORCE* (F (CAR S))) (DELAY (SMAP F (CDR S)))))) 47 | 48 | dnl ------------------------------------------------------------------------- 49 | dnl | Computes a list containing the elements of the specified list that 50 | dnl | satisfy the provided predicate function 51 | dnl | P = a function that takes one argument and returns a boolean value 52 | dnl | L = the list to filter 53 | dnl | RESULT the list containing the elements "x", for which (P x) is true. 54 | dnl ------------------------------------------------------------------------- 55 | (SFILTER LAMBDA (P S) 56 | (IF (SISNIL S) 57 | (QUOTE NIL) 58 | (IF (P (CAR S)) 59 | (CONS (FORCE* (CAR S)) (DELAY (SFILTER P (CDR S)))) 60 | (SFILTER P (CDR S))))) 61 | 62 | (SCAR LAMBDA (S) (CAR (FORCE* S))) 63 | (SCDR LAMBDA (S) (CDR (FORCE* S))) 64 | 65 | dnl ------------------------------------------------------------------------- 66 | dnl | Gets the first item in the list 67 | dnl | L = the list 68 | dnl | RETURNS the first element of L 69 | dnl ------------------------------------------------------------------------- 70 | (SFIRST LAMBDA (S) 71 | (SCAR S)) 72 | 73 | dnl ------------------------------------------------------------------------- 74 | dnl | Gets the second item in the list 75 | dnl | L = the list 76 | dnl | RETURNS the second element of L 77 | dnl ------------------------------------------------------------------------- 78 | (SSECOND LAMBDA (S) 79 | (SCAR (SCDR S))) 80 | 81 | dnl ------------------------------------------------------------------------- 82 | dnl | Gets the third item in the list 83 | dnl | L = the list 84 | dnl | RETURNS the third element of L 85 | dnl ------------------------------------------------------------------------- 86 | (STHIRD LAMBDA (S) 87 | (SCAR (SCDR (SCDR S)))) 88 | 89 | dnl ------------------------------------------------------------------------- 90 | dnl | Gets the fourth item in the list 91 | dnl | L = the list 92 | dnl | RETURNS the fourth element of L 93 | dnl ------------------------------------------------------------------------- 94 | (SFOURTH LAMBDA (S) 95 | (SCAR (SCDR (SCDR (SCDR S))))) 96 | 97 | dnl ------------------------------------------------------------------------- 98 | dnl | Gets the fifth item in the list 99 | dnl | L = the list 100 | dnl | RETURNS the fifth element of L 101 | dnl ------------------------------------------------------------------------- 102 | (SFIFTH LAMBDA (S) 103 | (SCAR (SCDR (SCDR (SCDR (SCDR S)))))) 104 | 105 | dnl ------------------------------------------------------------------------- 106 | dnl | Inserts an item into a list 107 | dnl | L = the list to insert into 108 | dnl | N = the index at which to insert the new item 109 | dnl | E = the element to insert 110 | dnl | RETURNS the list L with E inserted into the Nth position 111 | dnl ------------------------------------------------------------------------- 112 | (SINSERT LAMBDA (S N E) 113 | (IF (EQ N 0) 114 | (CONS E S) 115 | (IF (SISNIL S) 116 | (QUOTE NIL) 117 | (CONS (CAR S) (DELAY (SINSERT (CDR S) (SUB N 1) E)))))) 118 | 119 | dnl ------------------------------------------------------------------------- 120 | dnl | Determines if a list contains a given number or symbol 121 | dnl | C = the value to search for 122 | dnl | L = the list to scan 123 | dnl | RETURNS a value indicating if the list L contains C as an element 124 | dnl ------------------------------------------------------------------------- 125 | (SCONTAINS LAMBDA (C S) 126 | (IF (SISNIL S) 127 | (QUOTE F) 128 | (OR (EQ C (CAR S)) (SCONTAINS C (CDR S))))) 129 | 130 | dnl ------------------------------------------------------------------------- 131 | dnl | Determines if a list is a prefix of another 132 | dnl | P = the list to match 133 | dnl | L = the list to test 134 | dnl | RETURNS a value indicating if P is a prefix of L 135 | dnl ------------------------------------------------------------------------- 136 | (SSTARTSWITH LAMBDA (P S) 137 | (IF (SISNIL P) 138 | (QUOTE T) 139 | (IF (SISNIL S) 140 | (QUOTE F) 141 | (IF (EQ (CAR P) (CAR S)) 142 | (SSTARTSWITH (CDR P) (CDR S)) 143 | (QUOTE F))))) 144 | 145 | dnl ------------------------------------------------------------------------- 146 | dnl | Prints a string (represented as a list of ASCII values) to stdout 147 | dnl | S = the string to print. 148 | dnl | RETURNS NIL 149 | dnl ------------------------------------------------------------------------- 150 | (SPRINTSTR LAMBDA (S) 151 | (IF (SISNIL S) 152 | S 153 | (BEGIN 154 | (PUT (CAR S)) 155 | (SPRINTSTR (CDR S))))) 156 | 157 | (SDROP LAMBDA (N S) 158 | (IF (LEQ N 0) 159 | S 160 | (IF (SISNIL S) 161 | (QUOTE NIL) 162 | (SDROP (SUB N 1) (CDR S))))) 163 | 164 | (STAKE LAMBDA (N S) 165 | (IF (LEQ N 0) 166 | (QUOTE NIL) 167 | (IF (SISNIL S) 168 | (QUOTE NIL) 169 | (CONS (CAR S) (DELAY (STAKE (SUB N 1) (CDR S))))))) 170 | 171 | ')dnl 172 | -------------------------------------------------------------------------------- /util/Unicode.lso: -------------------------------------------------------------------------------- 1 | dnl =========================================================================== 2 | dnl | Unicode functions 3 | dnl | 4 | dnl | Functions for encoding and printing Unicode characters. 5 | dnl =========================================================================== 6 | ifdef(`unicode_lso_m4',,`define(`unicode_lso_m4',1)dnl 7 | 8 | dnl ------------------------------------------------------------------------- 9 | dnl | Prints a string of Unicode characters to stdout 10 | dnl | S = a list of Unicode code points 11 | dnl | RETURNS NIL 12 | dnl ------------------------------------------------------------------------- 13 | (PRINTUTF8 LAMBDA (S) 14 | (LETREC 15 | (CONTINUEPRINTUTF8 S (QUOTE NIL)) 16 | (CONTINUEPRINTUTF8 LAMBDA (S A) 17 | (IF (ISNIL S) 18 | S 19 | (CONTINUEPRINTUTF8 (CDR S) (PRINTSTR (UTF8 (CAR S)))))))) 20 | 21 | dnl ------------------------------------------------------------------------- 22 | dnl | Encodes a Unicode code-point usint UTF-8. 23 | dnl | CODE = the Unicode code point to convert. 24 | dnl | RETURNS a list of numbers (in the range of 0-255) represnting the bytes 25 | dnl | of the UTF-8 encoding of the Unicode character U+. 26 | dnl ------------------------------------------------------------------------- 27 | (UTF8 LAMBDA (CODE) 28 | (LETREC 29 | (IF (LEQ CODE -1) 30 | (CONS1 0) 31 | (IF (LEQ CODE 127) 32 | (CONS1 CODE) 33 | (IF (LEQ CODE 2047) 34 | (CONS2 (ADD 192 (DIV CODE 64)) (ADD 128 (REM CODE 64))) 35 | (IF (LEQ CODE 65535) 36 | (CONS (ADD 224 (DIV CODE 4096)) (UTF8TAIL (REM CODE 4096))) 37 | (IF (LEQ CODE 2097151) 38 | (CONS (ADD 240 (DIV CODE 262144)) (UTF8TAIL (REM CODE 262144))) 39 | (IF (LEQ CODE 67108863) 40 | (CONS (ADD 248 (DIV CODE 16777216)) (UTF8TAIL (REM CODE 16777216))) 41 | (IF (LEQ CODE 2147483647) 42 | (CONS (ADD 252 (DIV CODE 1073741824)) (UTF8TAIL (REM CODE 1073741824))) 43 | (STOP (QUOTE InvalidUTFCodePoint))))))))) 44 | (UTF8TAIL LAMBDA (CODE) 45 | (CONTINUEUTF8TAIL CODE (QUOTE NIL))) 46 | (CONTINUEUTF8TAIL LAMBDA (CODE TAIL) 47 | (IF (EQ CODE 0) 48 | TAIL 49 | (CONTINUEUTF8TAIL (DIV CODE 64) (CONS (ADD 128 (REM CODE 64)) TAIL)))))) 50 | 51 | ')dnl 52 | -------------------------------------------------------------------------------- /util/Util.lso: -------------------------------------------------------------------------------- 1 | dnl --- Utility functions --- 2 | ifdef(`util_lso_m4',,`define(`util_lso_m4',1)dnl 3 | 4 | dnl ------------------------------------------------------------------------- 5 | dnl | Splits a list before the specified index 6 | dnl | L = the list to split 7 | dnl | N = the index into the list at which to split 8 | dnl | RETURNS a pair ( A . B ) consisting of the two lists with length(A) = N, 9 | dnl | length(B) = length(L) - N, and (APPEND A B) = L 10 | dnl ------------------------------------------------------------------------- 11 | (SPLIT LAMBDA (L N) 12 | (LETREC 13 | (SPLITCC L N (QUOTE NIL)) 14 | (SPLITCC LAMBDA (L N PREFIX) 15 | (IF (EQ N 0) 16 | (CONS (REVERSE PREFIX) L) 17 | (SPLITCC (CDR L) (SUB N 1) (CONS (CAR L) PREFIX)))))) 18 | 19 | dnl ------------------------------------------------------------------------- 20 | dnl | Reverses a list 21 | dnl | L = the list to reverse 22 | dnl | RETURNS the list L in reverse order 23 | dnl ------------------------------------------------------------------------- 24 | (REVERSE LAMBDA (L) 25 | (LETREC 26 | (REVERSECC L (QUOTE NIL)) 27 | (REVERSECC LAMBDA (L CC) 28 | (IF (EQ L (QUOTE NIL)) 29 | CC 30 | (REVERSECC (CDR L) (CONS (CAR L) CC)))))) 31 | 32 | dnl ------------------------------------------------------------------------- 33 | dnl | Flatten a list of lists 34 | dnl | L = the list to flatten. Each element of L must be a list (either NIL 35 | dnl | or a (CONS x y), where y is a list). 36 | dnl | RETURNS a list formed by concatenating all of the elements in L 37 | dnl ------------------------------------------------------------------------- 38 | (FLATTEN LAMBDA (L) 39 | (LETREC 40 | (FLATTENREV (REVERSE L) (QUOTE NIL)) 41 | (FLATTENREV LAMBDA (L CC) 42 | (IF (EQ L (QUOTE NIL)) 43 | CC 44 | (FLATTENREV (CDR L) (APPEND (CAR L) CC)))))) 45 | 46 | dnl ------------------------------------------------------------------------- 47 | dnl | Gets the item in the list at the specified (zero-based) index 48 | dnl | L = the list to search 49 | dnl | N = the zero-based index into the list 50 | dnl | RETURNS the Nth element in the list, i.e., 51 | dnl | (CAR (CDR ... ... (CDR L) ... )) 52 | dnl ------------------------------------------------------------------------- 53 | (NTH LAMBDA (L N) 54 | (IF (EQ N 0) 55 | (CAR L) 56 | (NTH (CDR L) (SUB N 1)))) 57 | 58 | dnl ------------------------------------------------------------------------- 59 | dnl | Gets the length of the list 60 | dnl | L = the list to get the length of 61 | dnl | RETURNS the length of the list 62 | dnl ------------------------------------------------------------------------- 63 | (LENGTH LAMBDA (L) 64 | (LETREC 65 | (LENGTHCC L 0) 66 | (LENGTHCC LAMBDA (L CC) 67 | (IF (EQ L (QUOTE NIL)) 68 | CC 69 | (LENGTHCC (CDR L) (ADD CC 1)))))) 70 | 71 | dnl ------------------------------------------------------------------------- 72 | dnl | Negates a number 73 | dnl | N = the number to negate 74 | dnl | RETURNS the additive inverse of N 75 | dnl ------------------------------------------------------------------------- 76 | (NEG LAMBDA (N) 77 | (MUL N -1)) 78 | 79 | dnl ------------------------------------------------------------------------- 80 | dnl | Computes the absolute value of a number 81 | dnl | N = the number to compute the absolute value of 82 | dnl | RETURNS N, if N >= 0, or -N if N < 0 83 | dnl ------------------------------------------------------------------------- 84 | (ABS LAMBDA (N) 85 | (IF (LEQ N 0) (NEG N) N)) 86 | 87 | dnl ------------------------------------------------------------------------- 88 | dnl | Raises a number to an exponent 89 | dnl | B = the base (i.e., the number to raise) 90 | dnl | E = the exponent 91 | dnl | RETURNS the value B * ... ... * B 92 | dnl ------------------------------------------------------------------------- 93 | (POW LAMBDA (B E) 94 | (LETREC 95 | (POWCC E 1) 96 | (POWCC LAMBDA (E CC) 97 | (IF (EQ E 0) 98 | CC 99 | (POWCC (SUB E 1) (MUL B CC)))))) 100 | 101 | dnl ------------------------------------------------------------------------- 102 | dnl | Computes the minimum of two values 103 | dnl | X = the first value 104 | dnl | Y = the second value 105 | dnl | RETURNS X, if X < Y, or Y otherwise 106 | dnl ------------------------------------------------------------------------- 107 | (MIN LAMBDA (X Y) 108 | (IF (LEQ X Y) X Y)) 109 | 110 | dnl ------------------------------------------------------------------------- 111 | dnl | Computes the maximum of two values 112 | dnl | X = the first value 113 | dnl | Y = the second value 114 | dnl | RETURNS X, if X > Y, or Y otherwise 115 | dnl ------------------------------------------------------------------------- 116 | (MAX LAMBDA (X Y) 117 | (IF (LEQ X Y) Y X)) 118 | 119 | dnl ------------------------------------------------------------------------- 120 | dnl | Computes the boolean XOR of two values 121 | dnl | P = the first value (must be "T" or "F") 122 | dnl | Q = the second value (must be "T" or "F") 123 | dnl | RETURNS the boolean value P XOR Q 124 | dnl ------------------------------------------------------------------------- 125 | (XOR LAMBDA (P Q) 126 | (IF P (NOT Q) Q)) 127 | 128 | dnl ------------------------------------------------------------------------- 129 | dnl | Determines if the specified symbol is a boolean value 130 | dnl | P = the value to check 131 | dnl | RETURNS a value indicating if P evaluates to "T" or "F" 132 | dnl ------------------------------------------------------------------------- 133 | (ISBOOLEAN LAMBDA (P) 134 | (OR (EQ P (QUOTE T)) (EQ P (QUOTE F)))) 135 | 136 | dnl ------------------------------------------------------------------------- 137 | dnl | Determines if the specified symbol is the NIL value (empty list) 138 | dnl | X = the value to check 139 | dnl | RETURNS a value indicating if X is the empty list (NIL) 140 | dnl ------------------------------------------------------------------------- 141 | (ISNIL LAMBDA (X) 142 | (EQ X (QUOTE NIL))) 143 | 144 | dnl ------------------------------------------------------------------------- 145 | dnl | Determines if the specified number is zero 146 | dnl | N = the value to check 147 | dnl | RETURNS a value indicating if N is zero 148 | dnl ------------------------------------------------------------------------- 149 | (ISZERO LAMBDA (N) 150 | (EQ N 0)) 151 | 152 | dnl ------------------------------------------------------------------------- 153 | dnl | Computes the boolean negation of the specified value 154 | dnl | P = the value to negate (must be "T" or "F") 155 | dnl | RETURNS the value "F" if P is "T", or "T" if P is "F" 156 | dnl ------------------------------------------------------------------------- 157 | (NOT LAMBDA (P) 158 | (IF (EQ P (QUOTE T)) (QUOTE F) (QUOTE T))) 159 | 160 | dnl ------------------------------------------------------------------------- 161 | dnl | Determines if X > Y 162 | dnl | X = the first value 163 | dnl | Y = the second value 164 | dnl | RETURNS a value indicating if X > Y 165 | dnl ------------------------------------------------------------------------- 166 | (GT LAMBDA (X Y) 167 | (NOT (LEQ X Y))) 168 | 169 | dnl ------------------------------------------------------------------------- 170 | dnl | Determines if X < Y 171 | dnl | X = the first value 172 | dnl | Y = the second value 173 | dnl | RETURNS a value indicating if X < Y 174 | dnl ------------------------------------------------------------------------- 175 | (LT LAMBDA (X Y) 176 | (NOT (LEQ Y X))) 177 | 178 | dnl ------------------------------------------------------------------------- 179 | dnl | Determines if X >= Y 180 | dnl | X = the first value 181 | dnl | Y = the second value 182 | dnl | RETURNS a value indicating if X >= Y 183 | dnl ------------------------------------------------------------------------- 184 | (GEQ LAMBDA (X Y) 185 | (LEQ Y X)) 186 | 187 | dnl ------------------------------------------------------------------------- 188 | dnl | Determines if X != Y 189 | dnl | X = the first value 190 | dnl | Y = the second value 191 | dnl | RETURNS a value indicating if X != Y 192 | dnl ------------------------------------------------------------------------- 193 | (NEQ LAMBDA (X Y) 194 | (NOT (EQ X Y))) 195 | 196 | dnl ------------------------------------------------------------------------- 197 | dnl | Appends two lists 198 | dnl | A = the first list 199 | dnl | B = the second list 200 | dnl | RETURNS a list consisting of all of the elements of A, followed by all 201 | dnl | of the elements of B 202 | dnl ------------------------------------------------------------------------- 203 | (APPEND LAMBDA (A B) 204 | (LETREC 205 | (PREPENDREVERSE (REVERSE A) B) 206 | (PREPENDREVERSE LAMBDA (A B) 207 | (IF (ISNIL A) 208 | B 209 | (PREPENDREVERSE (CDR A) (CONS (CAR A) B)))))) 210 | 211 | dnl ------------------------------------------------------------------------- 212 | dnl | Determines if two objects are equivalent, according to the following 213 | dnl | rules: 214 | dnl | 215 | dnl | 1) Two objects of differing types (e.g., number and symbol) are NOT 216 | dnl | equivalent 217 | dnl | 2) Two numbers are equivalent if the have the same value. 218 | dnl | 3) Two symbols (including NIL) are equivalent if they are the same 219 | dnl | symbol. 220 | dnl | 4) Two cons cells (X . Y) and (Z . W) are equivalent if X is equivalent 221 | dnl | to Z and Y is equivalent to W. 222 | dnl | 223 | dnl | A = the first item 224 | dnl | B = the second item 225 | dnl | RETURNS a value indicating whether A and B are equivalent 226 | dnl ------------------------------------------------------------------------- 227 | (DEEPEQ LAMBDA (A B) 228 | (EQ (DEEPCMP A B) 0)) 229 | 230 | dnl ------------------------------------------------------------------------- 231 | dnl | Compares two objects are equivalent, according to the following rules: 232 | dnl | 233 | dnl | 1) A total ordering is imposed upon the set of atoms (numbers and 234 | dnl | symbols) 235 | dnl | 2) Two numbers are compared according to their natural ordering, but 236 | dnl | there is no guarantee regarding the ordering in comparisons 237 | dnl | involving symbols other than that it will be consistent with the 238 | dnl | definition of a total ordering. 239 | dnl | 3) An atomic value is less than a cons cell. 240 | dnl | 4) For two cons cells (X . Y) and (Z . W), their ordering is determined 241 | dnl | first by the comparison of X and Z. If X and Z are equivalent, then 242 | dnl | the result is determined by comparing Y and W. 243 | dnl | 244 | dnl | A = the first item 245 | dnl | B = the second item 246 | dnl | RETURNS a value indicating the result of the comparison between A and B, 247 | dnl | with -1 indicating that A < B, 0 indicating that A and B are 248 | dnl | equivalent, and 1 indicating that A > B. 249 | dnl ------------------------------------------------------------------------- 250 | (DEEPCMP LAMBDA (A B) 251 | (IF (ATOM A) 252 | (IF (ATOM B) 253 | (IF (EQ A B) 0 (IF (LEQ A B) -1 1)) 254 | -1) 255 | (IF (ATOM B) 256 | 1 257 | (LET 258 | (IF (EQ CARCMP 0) 259 | (DEEPCMP (CDR A) (CDR B)) 260 | CARCMP) 261 | (CARCMP DEEPCMP (CAR A) (CAR B)))))) 262 | 263 | dnl ------------------------------------------------------------------------- 264 | dnl | Applies a function to all elements in a list 265 | dnl | F = the function to apply 266 | dnl | L = the list elements on which to apply F 267 | dnl | RESULT the list ((F a0) (F a1) ... (F an)), where L = (a0 a1 ... an) 268 | dnl ------------------------------------------------------------------------- 269 | (MAP LAMBDA (F L) 270 | (LETREC 271 | (MAPREVERSE (REVERSE L) (QUOTE NIL)) 272 | (MAPREVERSE LAMBDA (L CC) 273 | (IF (ISNIL L) 274 | CC 275 | (MAPREVERSE (CDR L) (CONS (F (CAR L)) CC)))))) 276 | 277 | dnl ------------------------------------------------------------------------- 278 | dnl | Computes a list containing the elements of the specified list that 279 | dnl | satisfy the provided predicate function 280 | dnl | P = a function that takes one argument and returns a boolean value 281 | dnl | L = the list to filter 282 | dnl | RESULT the list containing the elements "x", for which (P x) is true. 283 | dnl ------------------------------------------------------------------------- 284 | (FILTER LAMBDA (P L) 285 | (LETREC 286 | (FILTERREVERSE L (QUOTE NIL)) 287 | (FILTERREVERSE LAMBDA (L CC) 288 | (IF (ISNIL L) 289 | (REVERSE CC) 290 | (FILTERREVERSE (CDR L) (IF (P (CAR L)) 291 | (CONS (CAR L) CC) 292 | CC)))))) 293 | 294 | dnl ------------------------------------------------------------------------- 295 | dnl | Computes a list containing all but the first N elements of the given 296 | dnl | list. 297 | dnl | N = the number of elements to drop 298 | dnl | L = the list to drop N elements from 299 | dnl | RESULT a list containing all but the first N elements of L, or NIL if 300 | dnl | L contains N or fewer elements 301 | dnl ------------------------------------------------------------------------- 302 | (DROP LAMBDA (N L) 303 | (IF (OR (EQ N 0) (ISNIL L)) 304 | L 305 | (DROP (SUB N 1) (CDR L)))) 306 | 307 | dnl ------------------------------------------------------------------------- 308 | dnl | Evaluates to the first argument but prints the second 309 | dnl | VAL = the value of the expression 310 | dnl | MSG = the value to print 311 | dnl | RETURNS VAL 312 | dnl ------------------------------------------------------------------------- 313 | (TRACE LAMBDA (VAL MSG) 314 | (BEGIN (PUTEXP MSG) VAL)) 315 | 316 | dnl ------------------------------------------------------------------------- 317 | dnl | Gets the first item in the list 318 | dnl | L = the list 319 | dnl | RETURNS the first element of L 320 | dnl ------------------------------------------------------------------------- 321 | (FIRST LAMBDA (L) 322 | (CAR L)) 323 | 324 | dnl ------------------------------------------------------------------------- 325 | dnl | Gets the second item in the list 326 | dnl | L = the list 327 | dnl | RETURNS the second element of L 328 | dnl ------------------------------------------------------------------------- 329 | (SECOND LAMBDA (L) 330 | (CAR (CDR L))) 331 | 332 | dnl ------------------------------------------------------------------------- 333 | dnl | Gets the third item in the list 334 | dnl | L = the list 335 | dnl | RETURNS the third element of L 336 | dnl ------------------------------------------------------------------------- 337 | (THIRD LAMBDA (L) 338 | (CAR (CDR (CDR L)))) 339 | 340 | dnl ------------------------------------------------------------------------- 341 | dnl | Gets the fourth item in the list 342 | dnl | L = the list 343 | dnl | RETURNS the fourth element of L 344 | dnl ------------------------------------------------------------------------- 345 | (FOURTH LAMBDA (L) 346 | (CAR (CDR (CDR (CDR L))))) 347 | 348 | dnl ------------------------------------------------------------------------- 349 | dnl | Gets the fifth item in the list 350 | dnl | L = the list 351 | dnl | RETURNS the fifth element of L 352 | dnl ------------------------------------------------------------------------- 353 | (FIFTH LAMBDA (L) 354 | (CAR (CDR (CDR (CDR (CDR L)))))) 355 | 356 | dnl ------------------------------------------------------------------------- 357 | dnl | Creates a list with one element 358 | dnl | A = the first element 359 | dnl | RETURNS the list (A) 360 | dnl ------------------------------------------------------------------------- 361 | (CONS1 LAMBDA (A) 362 | (CONS A (QUOTE NIL))) 363 | 364 | dnl ------------------------------------------------------------------------- 365 | dnl | Creates a list with two elements 366 | dnl | A = the first element 367 | dnl | B = the second element 368 | dnl | RETURNS the list (A B) 369 | dnl ------------------------------------------------------------------------- 370 | (CONS2 LAMBDA (A B) 371 | (CONS A (CONS B (QUOTE NIL)))) 372 | 373 | dnl ------------------------------------------------------------------------- 374 | dnl | Creates a list with three elements 375 | dnl | A = the first element 376 | dnl | B = the second element 377 | dnl | C = the third element 378 | dnl | RETURNS the list (A B C) 379 | dnl ------------------------------------------------------------------------- 380 | (CONS3 LAMBDA (A B C) 381 | (CONS A (CONS B (CONS C (QUOTE NIL))))) 382 | 383 | dnl ------------------------------------------------------------------------- 384 | dnl | Creates a list with four elements 385 | dnl | A = the first element 386 | dnl | B = the second element 387 | dnl | C = the third element 388 | dnl | D = the fourth element 389 | dnl | RETURNS the list (A B C D) 390 | dnl ------------------------------------------------------------------------- 391 | (CONS4 LAMBDA (A B C D) 392 | (CONS A (CONS B (CONS C (CONS D (QUOTE NIL)))))) 393 | 394 | dnl ------------------------------------------------------------------------- 395 | dnl | Creates a list with five elements 396 | dnl | A = the first element 397 | dnl | B = the second element 398 | dnl | C = the third element 399 | dnl | D = the fourth element 400 | dnl | E = the fifth element 401 | dnl | RETURNS the list (A B C D E) 402 | dnl ------------------------------------------------------------------------- 403 | (CONS5 LAMBDA (A B C D E) 404 | (CONS A (CONS B (CONS C (CONS D (CONS E (QUOTE NIL))))))) 405 | 406 | dnl ------------------------------------------------------------------------- 407 | dnl | Inserts an item into a list 408 | dnl | L = the list to insert into 409 | dnl | N = the index at which to insert the new item 410 | dnl | E = the element to insert 411 | dnl | RETURNS the list L with E inserted into the Nth position 412 | dnl ------------------------------------------------------------------------- 413 | (INSERT LAMBDA (L N E) 414 | (LETREC 415 | (INSERTCC L N (QUOTE NIL)) 416 | (INSERTCC LAMBDA (L N CC) 417 | (IF (ISZERO N) 418 | (INSERTCC L (SUB N 1) (CONS E CC)) 419 | (IF (ISNIL L) 420 | (REVERSE CC) 421 | (INSERTCC (CDR L) (SUB N 1) (CONS (CAR L) CC))))))) 422 | 423 | dnl ------------------------------------------------------------------------- 424 | dnl | Determines if a list contains a given number or symbol 425 | dnl | C = the value to search for 426 | dnl | L = the list to scan 427 | dnl | RETURNS a value indicating if the list L contains C as an element 428 | dnl ------------------------------------------------------------------------- 429 | (CONTAINS LAMBDA (C L) 430 | (IF (ISNIL L) 431 | (QUOTE F) 432 | (OR (EQ C (CAR L)) (CONTAINS C (CDR L))))) 433 | 434 | dnl ------------------------------------------------------------------------- 435 | dnl | Determines if a list is a prefix of another 436 | dnl | P = the list to match 437 | dnl | L = the list to test 438 | dnl | RETURNS a value indicating if P is a prefix of L 439 | dnl ------------------------------------------------------------------------- 440 | (STARTSWITH LAMBDA (P L) 441 | (IF (ISNIL P) 442 | (QUOTE T) 443 | (IF (ISNIL L) 444 | (QUOTE F) 445 | (IF (EQ (CAR P) (CAR L)) 446 | (STARTSWITH (CDR P) (CDR L)) 447 | (QUOTE F))))) 448 | 449 | dnl ------------------------------------------------------------------------- 450 | dnl | Prints a string (represented as a list of ASCII values) to stdout 451 | dnl | S = the string to print. 452 | dnl | RETURNS NIL 453 | dnl ------------------------------------------------------------------------- 454 | (PRINTSTR LAMBDA (S) 455 | (IF (ISNIL S) 456 | S 457 | (BEGIN 458 | (PUT (CAR S)) 459 | (PRINTSTR (CDR S))))) 460 | 461 | dnl ------------------------------------------------------------------------- 462 | dnl | Folds elements of a list using a binary operation 463 | dnl | F = a function accepting two arguments 464 | dnl | X = the value to return if L is empty 465 | dnl | L = the list to fold 466 | dnl | RETURNS (F ... (F (F X L1) L2) ... Ln) 467 | dnl ------------------------------------------------------------------------- 468 | (FOLD LAMBDA (F X L) 469 | (IF (ISNIL L) 470 | X 471 | (FOLD F 472 | (F X (CAR L)) 473 | (CDR L)))) 474 | 475 | dnl ------------------------------------------------------------------------- 476 | dnl | Reduces elements of a list using a binary operation 477 | dnl | F = a function accepting two arguments 478 | dnl | L = the list to reduce 479 | dnl | RETURNS (F ... (F (F L1 L2) L3) ... Ln) 480 | dnl ------------------------------------------------------------------------- 481 | (REDUCE LAMBDA (F L) 482 | (FOLD F (CAR L) (CDR L))) 483 | 484 | dnl ------------------------------------------------------------------------- 485 | dnl | Arithmetic operators 486 | dnl ------------------------------------------------------------------------- 487 | (+ MACRO ARGS (ADD . ARGS)) 488 | (* MACRO ARGS (MUL . ARGS)) 489 | (- MACRO (A B) (SUB A B)) 490 | (/ MACRO (A B) (DIV A B)) 491 | 492 | (+ LAMBDA ARGS (APPLY ADD ARGS)) 493 | (* LAMBDA ARGS (APPLY MUL ARGS)) 494 | (- LAMBDA (A B) (SUB A B)) 495 | (/ LAMBDA (A B) (DIV A B)) 496 | 497 | dnl ------------------------------------------------------------------------- 498 | dnl | Creates a function with positional arguments. 499 | dnl | 500 | dnl | Example: 501 | dnl | (λ (+ _1 _2)) 502 | dnl | is equivalent to 503 | dnl | (LAMBDA (A B) (+ A B)) 504 | dnl | 505 | dnl | BODY = the body of the function, with _1, ..., _9 referring to the first 506 | dnl | nine arguments and _0 referring to the list containing all 507 | dnl | arguments 508 | dnl ------------------------------------------------------------------------- 509 | (λ MACRO (BODY) 510 | (LAMBDA _0 511 | (LET 512 | (APPLY F _0) 513 | (F LAMBDA (_1 _2 _3 _4 _5 _6 _7 _8 _9) BODY)))) 514 | 515 | ')dnl 516 | --------------------------------------------------------------------------------