Lisp (technically Scheme) written in FORTH
Martin_H
Posts: 4,051
This is too good not to post considering that there are FORTH and Lisp fans on the forum. It exists, a Lisp (technically Scheme) written in FORTH!
The source code is in a tarball link on this page http://www.complang.tuwien.ac.at/schani/oldstuff/#schemeinforth on the Internet. Here's the GPL-ed source:
The source code is in a tarball link on this page http://www.complang.tuwien.ac.at/schani/oldstuff/#schemeinforth on the Internet. Here's the GPL-ed source:
\ -*- forth -*-
\ lisp.fs
\
\ A Lisp interpreter in Forth
\
\ Copyright (C) 1999 Mark Probst
\
\ This program is free software; you can redistribute it and/or
\ modify it under the terms of the GNU General Public License
\ as published by the Free Software Foundation; either version 2
\ of the License, or (at your option) any later version.
\
\ This program is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied warranty of
\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
\ GNU General Public License for more details.
\
\ You should have received a copy of the GNU General Public License
\ along with this program; if not, write to the Free Software
\ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
\ utilities
: string-new { a u -- a u }
a u allocate drop dup >r u cmove
r> u ;
: string>num ( a u -- n )
0 swap 0 ?do
10 * over i + c@ [char] 0 - +
loop
nip ;
\ symbol table
struct
cell% field symtab-namea
cell% field symtab-nameu
cell% field symtab-lisp
cell% field symtab-next
end-struct symtab
0 variable symtab-first
drop
: symtab-lookup { namea nameu -- }
symtab-first @
begin
dup 0<>
while
>r
r@ symtab-namea @ r@ symtab-nameu @ namea nameu compare
0= if
r> symtab-lisp @ unloop exit
endif
r> symtab-next @
repeat
drop 0 ;
: symtab-add { namea nameu lisp -- }
symtab %allocate throw
dup symtab-namea namea swap !
dup symtab-nameu nameu swap !
dup symtab-lisp lisp swap !
dup symtab-next symtab-first @ swap !
symtab-first ! ;
: symtab-save ( -- ptr )
symtab-first @ ;
: symtab-restore ( ptr -- )
symtab-first ! ;
\ lisp interpreter
0 constant lisp-pair-tag
1 constant lisp-number-tag
2 constant lisp-builtin-tag
3 constant lisp-symbol-tag
4 constant lisp-special-tag
5 constant lisp-compound-tag
6 constant lisp-max-tag
lisp-max-tag cells allocate throw constant eval-dispatch
lisp-max-tag cells allocate throw constant display-dispatch
lisp-max-tag cells allocate throw constant eq?-dispatch
struct
cell% field lisp-tag
end-struct lisp
struct
cell% field pair-tag
cell% field pair-car
cell% field pair-cdr
end-struct lisp-pair
struct
cell% field number-tag
cell% field number-num
end-struct lisp-number
struct
cell% field builtin-tag
cell% field builtin-xt
end-struct lisp-builtin
struct
cell% field symbol-tag
cell% field symbol-namea
cell% field symbol-nameu
end-struct lisp-symbol
struct
cell% field special-tag
cell% field special-xt
end-struct lisp-special
struct
cell% field compound-tag
cell% field compound-args
cell% field compound-body
end-struct lisp-compound
: cons { car cdr -- lisp }
lisp-pair %allocate throw
dup pair-tag lisp-pair-tag swap !
dup pair-car car swap !
dup pair-cdr cdr swap ! ;
: car ( pair -- lisp )
pair-car @ ;
: cdr ( pair -- lisp )
pair-cdr @ ;
: number { num -- lisp }
lisp-number %allocate throw
dup number-tag lisp-number-tag swap !
dup number-num num swap ! ;
: builtin { xt -- lisp }
lisp-builtin %allocate throw
dup builtin-tag lisp-builtin-tag swap !
dup builtin-xt xt swap ! ;
: symbol { namea nameu -- lisp }
lisp-symbol %allocate throw
dup symbol-tag lisp-symbol-tag swap !
dup symbol-namea namea swap !
dup symbol-nameu nameu swap ! ;
: symbol-new ( namea nameu -- lisp )
string-new symbol ;
: special { xt -- lisp }
lisp-special %allocate throw
dup special-tag lisp-special-tag swap !
dup special-xt xt swap ! ;
: compound { args body -- lisp }
lisp-compound %allocate throw
dup compound-tag lisp-compound-tag swap !
dup compound-args args swap !
dup compound-body body swap ! ;
: lisp-display ( lisp -- )
dup 0= if
drop [char] ( emit [char] ) emit
else
dup lisp-tag @ cells display-dispatch + @ execute
endif ;
: lisp-display-pair ( lisp -- )
[char] ( emit 32 emit
begin
dup car lisp-display 32 emit
cdr
dup 0=
until
drop
[char] ) emit ;
' lisp-display-pair display-dispatch lisp-pair-tag cells + !
: lisp-display-number ( lisp -- )
number-num @ . ;
' lisp-display-number display-dispatch lisp-number-tag cells + !
: lisp-display-builtin ( lisp -- )
[char] $ emit special-xt @ . ;
' lisp-display-builtin display-dispatch lisp-builtin-tag cells + !
: lisp-display-symbol { lisp -- }
lisp symbol-namea @ lisp symbol-nameu @ type ;
' lisp-display-symbol display-dispatch lisp-symbol-tag cells + !
: lisp-display-special ( lisp -- )
[char] # emit special-xt @ . ;
' lisp-display-special display-dispatch lisp-special-tag cells + !
: lisp-display-compound ( lisp -- )
[char] & emit compound-body @ . ;
' lisp-display-compound display-dispatch lisp-compound-tag cells + !
: lisp-eval ( lisp -- lisp )
dup 0<> if
dup lisp-tag @ cells eval-dispatch + @ execute
endif ;
: lisp-eval-list recursive ( lisp -- lisp )
dup 0<> if
dup car lisp-eval swap cdr lisp-eval-list cons
endif ;
: lisp-bind-var ( name value -- )
>r dup symbol-namea @ swap symbol-nameu @ r> symtab-add ;
: lisp-bind-vars ( names values -- )
swap
begin
dup 0<>
while
2dup car swap car lisp-bind-var
cdr swap cdr swap
repeat
2drop ;
: lisp-apply-compound ( func args -- lisp )
symtab-save >r
over compound-args @ swap lisp-bind-vars
compound-body @ lisp-eval
r> symtab-restore ;
: lisp-apply ( func args -- lisp )
>r dup lisp-tag @ lisp-builtin-tag = if
r> swap builtin-xt @ execute
else
r> lisp-apply-compound
endif ;
: lisp-eval-pair ( lisp -- lisp )
>r
r@ car lisp-eval
dup lisp-tag @ lisp-special-tag = if
r> cdr swap special-xt @ execute
else
r> cdr lisp-eval-list lisp-apply
endif ;
' lisp-eval-pair eval-dispatch lisp-pair-tag cells + !
: lisp-eval-number ( lisp -- lisp ) ;
' lisp-eval-number eval-dispatch lisp-number-tag cells + !
: lisp-eval-builtin ( lisp -- lisp ) ;
' lisp-eval-builtin eval-dispatch lisp-builtin-tag cells + !
: lisp-eval-symbol { lisp -- lisp }
lisp symbol-namea @ lisp symbol-nameu @ symtab-lookup ;
' lisp-eval-symbol eval-dispatch lisp-symbol-tag cells + !
: lisp-eval-special ( lisp -- lisp ) ;
' lisp-eval-special eval-dispatch lisp-special-tag cells + !
: lisp-eval-compound ( lisp -- lisp ) ;
' lisp-eval-compound eval-dispatch lisp-compound-tag cells + !
\ the reader
: lisp-read-char ( e a -- e a c )
2dup <= if
0
else
dup c@ swap 1+ swap
endif ;
: lisp-unread-char ( e a -- e a )
1- ;
: lisp-is-ws ( c -- flag )
dup 10 = swap dup 13 = swap dup 9 = swap 32 = or or or ;
: lisp-skip-ws ( e a -- e a )
lisp-read-char
begin
dup 0<> over lisp-is-ws and
while
drop lisp-read-char
repeat
0<> if
lisp-unread-char
endif ;
128 allocate throw constant token-buffer
: lisp-read-token ( e a -- e a a u )
lisp-skip-ws
0 >r
lisp-read-char
begin
dup [char] ) <> over 0<> and over lisp-is-ws 0= and
while
token-buffer r@ + c! r> 1+ >r lisp-read-char
repeat
0<> if
lisp-unread-char
endif
token-buffer r> ;
defer lisp-read-lisp
: lisp-read-list recursive ( e a -- e a lisp )
lisp-skip-ws lisp-read-char
dup [char] ) = swap 0 = or if
0
else
lisp-unread-char lisp-read-lisp >r lisp-read-list r> swap cons
endif ;
: lisp-read-number ( e a -- e a lisp )
lisp-read-token string>num number ;
: lisp-read-symbol ( e a -- e a lisp )
lisp-read-token string-new symbol ;
: _lisp-read-lisp ( e a -- e a lisp )
lisp-skip-ws lisp-read-char
dup 0= if
drop 0
else
dup [char] ( = if
drop lisp-read-list
else
dup [char] 0 >= swap [char] 9 <= and if
lisp-unread-char lisp-read-number
else
lisp-unread-char lisp-read-symbol
endif
endif
endif ;
' _lisp-read-lisp is lisp-read-lisp
: lisp-load-from-string ( a u -- lisp )
over + swap 0 >r
begin
lisp-skip-ws 2dup >
while
r> drop lisp-read-lisp lisp-eval >r
repeat
2drop r> ;
8192 allocate throw constant read-buffer
: lisp-load-from-file ( a u -- lisp )
r/o open-file
0<> if
drop 0
else
>r read-buffer 8192 r@ read-file
0<> if
r> 2drop 0
else
r> close-file drop
read-buffer swap lisp-load-from-string
endif
endif ;
\ specials
: lisp-special-quote ( lisp -- lisp )
car ;
s" quote" string-new ' lisp-special-quote special symtab-add
: lisp-special-lambda ( lisp -- lisp )
dup car swap cdr car compound ;
s" lambda" string-new ' lisp-special-lambda special symtab-add
: lisp-special-define ( lisp -- lisp )
dup car swap cdr car lisp-eval lisp-bind-var 0 ;
s" define" string-new ' lisp-special-define special symtab-add
0 constant lisp-false
0 0 cons constant lisp-true
s" t" string-new lisp-true symtab-add
: lisp-special-cond recursive ( lisp -- lisp )
dup car car lisp-eval 0<> if
car cdr car lisp-eval
else
cdr dup 0<> if
lisp-special-cond
endif
endif ;
s" cond" string-new ' lisp-special-cond special symtab-add
\ builtins
: lisp-builtin-+ ( lisp -- lisp )
0 swap
begin
dup 0<>
while
dup car number-num @ rot + swap cdr
repeat
drop number ;
s" +" string-new ' lisp-builtin-+ builtin symtab-add
: lisp-builtin-- ( lisp -- lisp )
dup car number-num @ swap cdr dup 0= if
drop negate number
else
swap
begin
over car number-num @ - swap cdr swap
over 0=
until
nip number
endif ;
s" -" string-new ' lisp-builtin-- builtin symtab-add
: lisp-builtin-* ( lisp -- lisp )
1 swap
begin
dup 0<>
while
dup car number-num @ rot * swap cdr
repeat
drop number ;
s" *" string-new ' lisp-builtin-* builtin symtab-add
: lisp-builtin-cons ( lisp -- lisp )
dup car swap cdr car cons ;
s" cons" string-new ' lisp-builtin-cons builtin symtab-add
: lisp-builtin-car ( lisp -- lisp )
car car ;
s" car" string-new ' lisp-builtin-car builtin symtab-add
: lisp-builtin-cdr ( lisp -- lisp )
car cdr ;
s" cdr" string-new ' lisp-builtin-cdr builtin symtab-add
: lisp-builtin-eq? ( lisp -- lisp )
dup car swap cdr car 2dup = if
2drop lisp-true
else
2dup lisp-tag @ swap lisp-tag @ <> if
2drop lisp-false
else
dup lisp-tag @ cells eq?-dispatch + @ execute
endif
endif ;
s" eq?" string-new ' lisp-builtin-eq? builtin symtab-add
' lisp-false eq?-dispatch lisp-pair-tag cells + !
: lisp-eq?-number ( lisp lisp -- lisp )
number-num @ swap number-num @ = if
lisp-true
else
lisp-false
endif ;
' lisp-eq?-number eq?-dispatch lisp-number-tag cells + !
' lisp-false eq?-dispatch lisp-builtin-tag cells + !
: lisp-eq?-symbol { lisp1 lisp2 -- lisp }
lisp1 symbol-namea @ lisp1 symbol-nameu @
lisp2 symbol-namea @ lisp2 symbol-nameu @
compare 0= if
lisp-true
else
lisp-false
endif ;
' lisp-eq?-symbol eq?-dispatch lisp-symbol-tag cells + !
' lisp-false eq?-dispatch lisp-compound-tag cells + !
: lisp-builtin-display ( lisp -- lisp )
car lisp-display 0 ;
s" display" string-new ' lisp-builtin-display builtin symtab-add
Comments
Both of which produce the expected output.
https://formlis.wordpress.com/2010/06/30/forth-in-lisp/
Makes me think that anyone wasting their life creating a Z80 emulator for the Prop is actually boringly sane
I guess the difference would be that Lisp could be running in Forth on a Prop whereas there is no Lisp for the Prop but then again, there is Forth for the Prop, so therefore there is Lisp for the Prop. Recurse you Lisp!
I've tried all three - Tachyon, PropForth, and pfth. Each has a very different learning curve and different means of learning.
struct.fs also includes a few CELL words that define the cellsize of floating point variables. I think those can just be commented out. I'll look at it some more later on.
EDIT: There is also the THROW word that needs to be handled. I believe this is used to handle exceptions, and can probably be stubbed out.
https://www.complang.tuwien.ac.at/about
One thing that most of us seem unaware of is that Taiwan still holds on to one of the last remaining active Forth Interest Groups. I'd love to participate, but they seem to correspond primarily in Chinese.
https://sites.google.com/site/figtaiwanfigtaiwan/
Tachyon via Peter J. has done a terrific job of demonstrating the Forth on the Propeller is a flexible, powerful, and useful tool. It shouldn't be dismissed just for not being ANSI Forth.
And of course, PropForth goes in different directions as well.
All demonstrate the ability of Forth to generate diverse solutions to just about anything it is applied. But the real power is that the Propeller actually allows 8 cogs to share one dictionary. Other versions of Forth for microcontroller chips work, but generally with only one CPU tied to one dictionary. All the fun is in having multiple cogs. I have had a lot of fun with the ability to task and retask individual cogs as required.
I wonder how Lisp might cope with 8 cogs and if it is a good fit.
I got the thing to almost completely compile, but I ran out of memory. I'll try FORGETting some words that aren't needed to see if that opens up enough space. However, I'm starting to lose interest in this idea. Is there a version of lisp.fs written in C? That would be the way to do it.
http://howtowriteaprogram.blogspot.tw/2010/11/lisp-interpreter-in-90-lines-of-c.html
This might work. Only 90 lines of code, but it is C++
That is no doubt a brilliant attempt at lisp in C++ in the least amount of source lines.
The practical problems start with it's use of: Which probably pulls in a few megabytes of libraries!
It's probably more space efficient to write similar code but in Python or JavaScript. Which basically have things like string and vector etc built in. Both Python and JS can be run on small MCU's with MicroPython and Esprunio respectively.
Or in Forth, as is the subject of this thread.
I have no idea if it is actually doable though.
I've officially given up trying to port lisp.fs to pfth. I could probably get it to work in another day or so, but it seems a bit pointless. This exercise has reinforced my belief that Forth is just not a good language for writing large programs. It's fine for peeking and poking and dinking around. However, serious programming should really have library support and standards and compilers that assist the developer. Forth is fine if you want a challenge, but if you want to get something done use something else.
As I've said before, Forth is Sudoku for programmers.
Interestingly enough the C version used coordinated arrays rather than structures, while the FORTH version used structures. That's backwards because FORTH works best with arrays, and an arrays of structs would be more C like.
I think this is primarily always the problem of trying to "port" from one language into another except of course that lisp.fs is Forth, but it's a glorious top heavy PC Forth which lisp.fs was written in and may not port well to an embedded Forth with a small memory footprint perhaps. An understanding of the software is required along with "thinking Forth" to rewrite this in the target Forth. All languages on PCs, even cross compiled ones, are "glorious" in that they have the relatively huge resources and processing power to work with after which they generate a binary blob where none of that glorious compiler capability is now present.
So when we are discussing Forth vs other "languages" in this forum surely it is always in respect to the Propeller, not the PC (where rarely I would use Forth anyway), and Forth on the Propeller is actually a dynamic interactive language and O/S whereas the PC compiled binary blobs are not "languages" anymore, just a hard-coded black box.
As for Sudoku I wouldn't know, I just develop commercial applications in Forth rather than building and sharpening the PC tools in the belief that this will be used to actually build something as I've yet to see anything written in C for the Prop that approaches the speed, compactness, and functionality of my Forth systems. All I've seen are demos and benchmarks and hype, where are these "large applications" written in C for the Prop then?
The structure of the struct word in lisp.fs is similar to the technique used in the Forth chess program that I ported a while ago. The both use the DOES> word to compute the address of a structure element. DOES> is probably one of the most powerful words in the Forth language.
@Peter, as you know I value portability, which is one of the reasons I favor C over Forth. I was able to port lisp.c to a processor that only has 32K of RAM just by changing one #define. I didn't have to understand the program, or rewrite it to conform to some strange dialect of the C language.
I don't know if there are any Prop products that are based on C code. I would assume most Prop products are developed in Spin and PASM. I think C will be more widely used on P2 where there is more memory.
Your development of Tachyon is amazing. The OS functionality that you have built with Tachyon is just incredible. I'm looking forward to seeing what you come up with next in Tachyon.
+1 to this. It's always a bit of surprise to me when I encounter FORTH dialect that omits DOES> because it is so powerful.
@Loopy Byteloose,
sometimes you are really funny. Still smiling about it. I got my Degree at TU Berlin. More obvious. But Tu Wien? Yes I can follow you there.
nice catch!
Mike
I do understand. But I feel strongly that peeking, poking, and dinking around is where many users get started. Libraries and standards can be very overwhelming to beginners.
LISP seems to just not fit the smallness of Forth.
What is the minimum of feature set you need in a high level language so that you can write a compiler for said high level language in itself?
I guess Forth and Lisp being very minimal but Turing complete can do that.
Do people actually do that?
I have seen examples of writing Lisp interpreters/run times in Lisp. But they always seem to require a Lisp run time to run them!
I mean, say you have a Forth or Lisp system on a PC and want the same on some other CPU?
This whole "bootstrapping" thing gives me headache.
For example, my "tiny" compiler runs on a PC and generates code that runs on the Propeller.
So, I should be able to use that to compile the tiny compiler source code on the Propeller.
But no, tiny is not powerful enough to write a tiny compiler in. It does not understand strings for example.