TSQL Lisp
Example Lisp interpreter running on top of Transact-SQL
unknown
sql
a year ago
14 kB
17
No Index
IF OBJECT_ID('Pairs', 'U') IS NOT NULL
DROP TABLE Pairs
GO
CREATE TABLE Pairs
(
ID int IDENTITY(0,1) PRIMARY KEY,
CAR int,
CDR int
);
GO
IF OBJECT_ID('Symbols', 'U') IS NOT NULL
DROP TABLE Symbols
GO
CREATE TABLE Symbols
(
ID int IDENTITY(0,1) PRIMARY KEY,
Name VARCHAR(255) NOT NULL,
Value INT NOT NULL
);
GO
IF OBJECT_ID('Functions', 'U') IS NOT NULL
DROP TABLE Functions
GO
CREATE TABLE Functions
(
ID int IDENTITY(0,1) PRIMARY KEY,
SEXP INT
);
GO
CREATE UNIQUE NONCLUSTERED INDEX IX_Name ON Symbols
(
Name ASC
)WITH (PAD_INDEX = OFF, STATISTICS_NORECOMPUTE = OFF, SORT_IN_TEMPDB = OFF, IGNORE_DUP_KEY = OFF, DROP_EXISTING = OFF, ONLINE = OFF, ALLOW_ROW_LOCKS = ON, ALLOW_PAGE_LOCKS = ON) ON [PRIMARY]
GO
IF OBJECT_ID('cons', 'P') IS NOT NULL
DROP PROCEDURE cons
GO
CREATE PROCEDURE cons (@CAR INT, @CDR INT)
AS BEGIN
SET NOCOUNT ON;
DECLARE @ResultTable TABLE(Value INT)
INSERT INTO Pairs (CAR, CDR)
OUTPUT Inserted.ID INTO @ResultTable -- gets the ID of new cons-pair
VALUES (@CAR, @CDR)
RETURN (SELECT Value FROM @ResultTable)*8 + 1
END
GO
IF OBJECT_ID('uncons', 'P') IS NOT NULL
DROP PROCEDURE uncons
GO
CREATE PROCEDURE uncons (@ID INT, @CAR INT OUT, @CDR INT OUT)
AS BEGIN
SET @ID = @ID/8
SELECT @CAR = CAR, @CDR = CDR FROM Pairs WHERE ID = @ID
END
GO
IF OBJECT_ID('typeof', 'P') IS NOT NULL
DROP PROCEDURE typeof
GO
CREATE PROCEDURE typeof (@ID INT)
AS RETURN (@ID & 7)
GO
IF OBJECT_ID('reverse_list', 'P') IS NOT NULL
DROP PROCEDURE reverse_list
GO
CREATE PROCEDURE reverse_list (@Xs INT)
AS BEGIN
DECLARE @Ys INT
DECLARE @X INT
SET @Ys = 1
WHILE @Xs <> 1
BEGIN
EXEC uncons @Xs, @X OUT, @Xs OUT
EXEC @Ys = cons @X, @Ys
END
RETURN @Ys
END
GO
IF OBJECT_ID('intern', 'P') IS NOT NULL
DROP PROCEDURE intern
GO
CREATE PROCEDURE intern (@Name VARCHAR(255))
AS BEGIN
SET NOCOUNT ON;
DECLARE @Result INT
SELECT @Result = ID FROM Symbols WHERE Name = @Name
IF @Result IS NULL
BEGIN
DECLARE @ResultTable TABLE(Value INT)
INSERT INTO Symbols (Name, Value)
OUTPUT Inserted.ID INTO @ResultTable -- gets the ID of new symbol
VALUES (@Name, 1)
SELECT @Result=Value FROM @ResultTable
END
RETURN @Result*8 + 2
END
GO
IF OBJECT_ID('make_function', 'P') IS NOT NULL
DROP PROCEDURE make_function
GO
CREATE PROCEDURE make_function (@SEXP INT)
AS BEGIN
SET NOCOUNT ON;
DECLARE @ResultTable TABLE(Value INT)
INSERT INTO Functions (SEXP)
OUTPUT Inserted.ID INTO @ResultTable -- gets the ID of new function
VALUES (@SEXP)
RETURN (SELECT Value FROM @ResultTable)*8 + 3
END
GO
IF OBJECT_ID('function_sexp', 'P') IS NOT NULL
DROP PROCEDURE function_sexp
GO
CREATE PROCEDURE function_sexp (@ID INT)
AS BEGIN
SET @ID = @ID/8
RETURN (SELECT SEXP FROM Functions WHERE ID = @ID)
END
GO
IF OBJECT_ID('symbol_name', 'P') IS NOT NULL
DROP PROCEDURE symbol_name
GO
CREATE PROCEDURE symbol_name (@ID INT, @Name VARCHAR(255) OUT) AS
BEGIN
SET @ID = @ID/8
SELECT @Name = Name FROM Symbols WHERE ID = @ID
END
GO
IF OBJECT_ID('symbol_value', 'P') IS NOT NULL
DROP PROCEDURE symbol_value
GO
CREATE PROCEDURE symbol_value (@ID INT) AS
BEGIN
SET @ID = @ID/8
RETURN (SELECT Value FROM Symbols WHERE ID = @ID)
END
GO
IF OBJECT_ID('set_symbol_value', 'P') IS NOT NULL
DROP PROCEDURE set_symbol_value
GO
CREATE PROCEDURE set_symbol_value (@ID INT, @Value INT) AS
BEGIN
SET @ID = @ID/8
UPDATE Symbols SET Value = @Value WHERE ID = @ID
END
GO
IF OBJECT_ID('parse_number', 'P') IS NOT NULL
DROP PROCEDURE parse_number
GO
CREATE PROCEDURE parse_number (@Chars VARCHAR(64))
AS RETURN CONVERT(INT,@Chars)*8
GO
IF OBJECT_ID('print_sexp', 'P') IS NOT NULL
DROP PROCEDURE print_sexp
GO
CREATE PROCEDURE print_sexp (@SEXP INT, @Result VARCHAR(4000) OUT)
AS BEGIN
SET @Result = ''
DECLARE @Type INT
DECLARE @X INT
DECLARE @Text VARCHAR(64)
DECLARE @Tmp VARCHAR(4000)
EXEC @Type = typeof @SEXP
IF @Type = 1 -- Pair
BEGIN
SET @Result = @Result + '('
WHILE @SEXP <> 1
BEGIN
EXEC uncons @SEXP, @X OUT, @SEXP OUT
EXEC print_sexp @X, @Tmp OUT
SET @Result = @Result + @Tmp
IF @SEXP <> 1 SET @Result = @Result + ' '
END
SET @Result = @Result + ')'
END
ELSE IF @Type = 2 -- symbol
BEGIN
EXEC symbol_name @SEXP, @Text OUT
SET @Result = @Result + @Text
END
ELSE IF @Type = 0 -- number
BEGIN
SET @Result = @Result + CONVERT(INT,@SEXP/8)
END
ELSE IF @Type = 3 -- function
BEGIN
SET @Result = '#function[' + CONVERT(VARCHAR(64),@SEXP/8) + ']'
END
END
GO
IF OBJECT_ID('read_sexp', 'P') IS NOT NULL
DROP PROCEDURE read_sexp
GO
CREATE PROCEDURE read_sexp (@Cs VARCHAR(4000))
AS BEGIN
SET NOCOUNT ON
SET @Cs = REPLACE(REPLACE(@Cs,'+','$add'),'-','$sub')
DECLARE @Chars VARCHAR(64)
DECLARE @C VARCHAR(1)
DECLARE @Stack TABLE(ID INT, Value INT)
DECLARE @SP INT -- Stack Pointer
SET @SP = 0
DECLARE @X INT
DECLARE @Xs INT
SET @Xs = 1
DECLARE @I INT
SET @I = 0
DECLARE @E INT
SET @E = LEN(@Cs)
WHILE @I < @E BEGIN
SET @C = SUBSTRING(@Cs,@I+1,1)
IF PATINDEX('%[0-9a-zA-Z_$*/<>=]%', @C) = 1
BEGIN
SET @Chars = ''
WHILE PATINDEX('%[0-9a-zA-Z_$*/<>=]%', @C) = 1 AND @I < @E
BEGIN
SET @Chars = @Chars + @C
SET @I = @I + 1
SET @C = SUBSTRING(@Cs,@I+1,1)
END
IF @I <> @E SET @I = @I - 1
IF PATINDEX('%[a-zA-Z_$*/<>=]%', @Chars) = 0
BEGIN
EXEC @X = parse_number @Chars
END
ELSE
BEGIN
SET @Chars = REPLACE(REPLACE(@Chars,'$add','+'),'$sub','-')
EXEC @X = intern @Chars
END
EXEC @Xs = cons @X, @Xs
END
ELSE IF @C = '('
BEGIN
INSERT INTO @Stack VALUES (@SP, @Xs)
SET @SP = @SP + 1
SET @Xs = 1
END
ELSE IF @C = ')'
BEGIN
SET @SP = @SP - 1
SELECT @X = Value FROM @Stack WHERE ID = @SP
DELETE FROM @Stack WHERE ID = @SP
EXEC @Xs = reverse_list @Xs
EXEC @Xs = cons @Xs, @X
END
ELSE IF @C = ' ' -- ignore
DECLARE @NOP0 bit
ELSE
BEGIN
PRINT 'ERROR: Invalid char: ' + @C
END
SET @I = @I + 1
END
EXEC @Xs = reverse_list @Xs
RETURN @Xs
END
GO
IF OBJECT_ID('eval_sexp', 'P') IS NOT NULL
DROP PROCEDURE eval_sexp
GO
CREATE PROCEDURE eval_sexp (@SEXP INT)
AS BEGIN
SET NOCOUNT ON
DECLARE @Result INT
DECLARE @Type INT
DECLARE @X INT
DECLARE @Xs INT
DECLARE @A INT -- arg
DECLARE @As INT -- args
DECLARE @V INT -- value
DECLARE @Vs INT -- values
DECLARE @Body INT
DECLARE @Save INT
EXEC @Type = typeof @SEXP
IF @Type = 1 -- pair
BEGIN
IF @SEXP = 1 RETURN 1
EXEC uncons @SEXP, @X OUT, @Xs OUT
IF @X = 2 -- quote
BEGIN
EXEC uncons @Xs, @Result OUT, @Xs OUT
END
ELSE IF @X = 10 -- lambda
BEGIN
EXEC uncons @Xs, @X OUT, @Xs OUT
EXEC @Xs = cons 26, @Xs -- implicit progn
EXEC @Xs = cons @X, @Xs
EXEC @Result = make_function @Xs
END
ELSE IF @X = 18 -- setq
BEGIN
EXEC uncons @Xs, @X OUT, @Xs OUT
EXEC uncons @Xs, @Result OUT, @Xs OUT
EXEC @Result = eval_sexp @Result
EXEC set_symbol_value @X, @Result
RETURN @Result
END
ELSE IF @X = 26 -- progn
BEGIN
SET @Result = 1
WHILE @Xs <> 1 BEGIN
EXEC uncons @Xs, @X OUT, @Xs OUT
EXEC @Result = eval_sexp @X
END
END
ELSE IF @X = 34 -- if
BEGIN
EXEC uncons @Xs, @X OUT, @Xs OUT
EXEC @Result = eval_sexp @X
EXEC uncons @Xs, @X OUT, @Xs OUT
IF @Result = 1 EXEC uncons @Xs, @X OUT, @Xs OUT
EXEC @Result = eval_sexp @X
END
ELSE -- funcall
BEGIN
SET @Vs = 1
SET @Xs = @SEXP
WHILE @Xs <> 1 BEGIN
EXEC uncons @Xs, @X OUT, @Xs OUT
EXEC @V = eval_sexp @X
EXEC @Vs = cons @V, @Vs
END
EXEC @Vs = reverse_list @Vs
EXEC uncons @Vs, @X OUT, @Vs OUT
EXEC @Result = typeof @X
IF @Result <> 3
BEGIN
PRINT 'ERROR: form head is not a function'
RETURN 1
END
IF @X = 3 -- cons
BEGIN
EXEC uncons @Vs, @X OUT, @Vs OUT
EXEC uncons @Vs, @V OUT, @Vs OUT
EXEC @Result = cons @X, @V
RETURN @Result
END
IF @X = 11 -- car
BEGIN
EXEC uncons @Vs, @V OUT, @Vs OUT
EXEC uncons @V, @Result OUT, @X OUT
RETURN @Result
END
IF @X = 19 -- cdr
BEGIN
EXEC uncons @Vs, @V OUT, @Vs OUT
EXEC uncons @V, @X OUT, @Result OUT
RETURN @Result
END
IF @X = 27 -- list
BEGIN
RETURN @Vs
END
IF @X = 35 -- +
BEGIN
EXEC uncons @Vs, @X OUT, @Vs OUT
EXEC uncons @Vs, @V OUT, @Vs OUT
RETURN @X + @V
END
IF @X = 43 -- -
BEGIN
EXEC uncons @Vs, @X OUT, @Vs OUT
EXEC uncons @Vs, @V OUT, @Vs OUT
RETURN @X - @V
END
IF @X = 51 -- *
BEGIN
EXEC uncons @Vs, @X OUT, @Vs OUT
EXEC uncons @Vs, @V OUT, @Vs OUT
RETURN @X * (@V/8)
END
IF @X = 59 -- /
BEGIN
EXEC uncons @Vs, @X OUT, @Vs OUT
EXEC uncons @Vs, @V OUT, @Vs OUT
RETURN (@X/@V)*8
END
IF @X = 67 -- =
BEGIN
EXEC uncons @Vs, @X OUT, @Vs OUT
EXEC uncons @Vs, @V OUT, @Vs OUT
IF @X = @V RETURN 0 -- return something non-NIL
RETURN 1
END
IF @X = 75 -- <
BEGIN
EXEC uncons @Vs, @X OUT, @Vs OUT
EXEC uncons @Vs, @V OUT, @Vs OUT
IF @X < @V RETURN 0 -- return something non-NIL
RETURN 1
END
IF @X = 83 -- >
BEGIN
EXEC uncons @Vs, @X OUT, @Vs OUT
EXEC uncons @Vs, @V OUT, @Vs OUT
IF @X > @V RETURN 0 -- return something non-NIL
RETURN 1
END
EXEC @X = function_sexp @X
EXEC uncons @X, @As OUT, @Body OUT
SET @Xs = @As
SET @Save = 1
WHILE @As <> 1 BEGIN -- setup environment
EXEC uncons @As, @A OUT, @As OUT
EXEC uncons @Vs, @V OUT, @Vs OUT
EXEC @X = symbol_value @A
EXEC @Save = cons @X, @Save
EXEC set_symbol_value @A, @V
END
EXEC @Result = eval_sexp @Body
EXEC @Vs = reverse_list @Save
WHILE @As <> 1 BEGIN -- restore environment
EXEC uncons @As, @A OUT, @As OUT
EXEC uncons @Vs, @V OUT, @Vs OUT
EXEC set_symbol_value @A, @V
END
END
END
ELSE IF @Type = 2 -- symbol
BEGIN
EXEC @Result = symbol_value @SEXP
END
ELSE IF @Type = 0 -- number
BEGIN
SET @Result = @SEXP
END
RETURN @Result
END
GO
IF OBJECT_ID('eval', 'P') IS NOT NULL
DROP PROCEDURE eval
GO
CREATE PROCEDURE eval (@Cs VARCHAR(4000))
AS BEGIN
DECLARE @Result INT
EXEC @Result = read_sexp @Cs
EXEC @Result = cons 26, @Result -- implicit progn
EXEC @Result = eval_sexp @Result
RETURN @Result
END
GO
EXEC cons 1, 1 -- NIL
GO
-- Pre-Intern standard symbols, so the get following values
EXEC intern 'quote' -- 2
EXEC intern 'lambda' -- 10
EXEC intern 'setq' -- 18
EXEC intern 'progn' -- 26
EXEC intern 'if' -- 34
GO
-- builtin functions stubs
exec eval '(setq cons (lambda () ))'
exec eval '(setq car (lambda () ))'
exec eval '(setq cdr (lambda () ))'
exec eval '(setq list (lambda () ))'
exec eval '(setq + (lambda () ))'
exec eval '(setq - (lambda () ))'
exec eval '(setq * (lambda () ))'
exec eval '(setq / (lambda () ))'
exec eval '(setq = (lambda () ))'
exec eval '(setq < (lambda () ))'
exec eval '(setq > (lambda () ))'
GO
-- predefined functions
exec eval '(setq map (lambda (_f _xs) (if _xs (cons (_f (car _xs)) (map _f (cdr _xs))))))'
exec eval '(setq fac (lambda (n) (if (< n 1) 1 (* n (fac (- n 1))))))'
DECLARE @Text VARCHAR(4000)
DECLARE @Result INT
exec @Result = eval '(fac 5)'
exec print_sexp @Result, @Text OUT
PRINT @Text
exec @Result = eval '(map (lambda (x) (* x x)) (list 1 2 3 4 5))'
exec print_sexp @Result, @Text OUT
PRINT @Text
Editor is loading...
Leave a Comment