Войти в систему
Home - Создать дневник - Написать в дневник - Подробный режим
LJ.Rossia.org - Новости сайта - Общие настройки - Sitemap - Оплата - ljr-fif
Редактировать... - Настройки - Список друзей - Дневник - Картинки - Пароль - Вид дневника
Сообщества
Настроить S2
Помощь - Забыли пароль? - FAQ - Тех. поддержка
(Добавить комментарий)
(Ответить)
(Ответить) (Ветвь дискуссии)
(Ответить) (Уровень выше)
(Ответить) (Уровень выше) (Ветвь дискуссии)
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